module Network.AWS.S3Bucket (
createBucketIn, createBucket, createBucketWithPrefixIn,
createBucketWithPrefix, deleteBucket, getBucketLocation,
emptyBucket, listBuckets, listObjects, listAllObjects,
S3Bucket(S3Bucket, bucket_name, bucket_creation_date),
ListRequest(..),
ListResult(..),
IsTruncated
) where
import Network.AWS.Authentication as Auth
import Network.AWS.AWSResult
import Network.AWS.S3Object
import Network.AWS.AWSConnection
import Network.AWS.ArrowUtils
import Network.HTTP as HTTP
import Network.Stream()
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char (toLower)
import Text.XML.HXT.Arrow
import qualified Data.Tree.NTree.TypeDefs
import Control.Arrow
import Control.Monad
import System.Random (randomIO)
import Codec.Utils
import Data.Digest.MD5
import Codec.Text.Raw
data S3Bucket = S3Bucket { bucket_name :: String,
bucket_creation_date :: String
} deriving (Show, Eq)
createBucketWithPrefixIn :: AWSConnection
-> String
-> String
-> IO (AWSResult String)
createBucketWithPrefixIn aws pre location =
do suffix <- randomName
let name = pre ++ "-" ++ suffix
res <- createBucketIn aws name location
either (\x -> case x of
AWSError _ _ -> createBucketWithPrefixIn aws pre location
otherwise -> return (Left x))
(\_ -> return (Right name)) res
createBucketWithPrefix :: AWSConnection
-> String
-> IO (AWSResult String)
createBucketWithPrefix aws pre =
createBucketWithPrefixIn aws pre "US"
randomName :: IO String
randomName =
do rdata <- randomIO :: IO Integer
return $ take 10 $ show $ hexdumpBy "" 999
(hash (toOctets (10::Integer) (abs rdata)))
createBucketIn :: AWSConnection
-> String
-> String
-> IO (AWSResult ())
createBucketIn aws bucket location =
let constraint = if location == "US"
then ""
else "<CreateBucketConfiguration><LocationConstraint>" ++ location ++ "</LocationConstraint></CreateBucketConfiguration>"
in
do res <- Auth.runAction (S3Action aws bucket "" "" [] (L.pack constraint) PUT)
return (either Left (\_ -> Right ()) res)
createBucket :: AWSConnection
-> String
-> IO (AWSResult ())
createBucket aws bucket =
createBucketIn aws bucket "US"
getBucketLocation :: AWSConnection
-> String
-> IO (AWSResult String)
getBucketLocation aws bucket =
do res <- Auth.runAction (S3Action aws bucket "?location" "" [] L.empty GET)
case res of
Left x -> return (Left x)
Right y -> do bs <- parseBucketLocationXML (L.unpack (rspBody y))
return (Right bs)
parseBucketLocationXML :: String -> IO String
parseBucketLocationXML s =
do results <- runX (readString [(a_validate,v_0)] s >>> processLocation)
return $ case results of
[] -> "US"
x:_ -> x
processLocation :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) String
processLocation = (text <<< atTag "LocationConstraint")
>>> arr id
deleteBucket :: AWSConnection
-> String
-> IO (AWSResult ())
deleteBucket aws bucket =
do res <- Auth.runAction (S3Action aws bucket "" "" [] L.empty DELETE)
return (either Left (\_ -> Right ()) res)
emptyBucket :: AWSConnection
-> String
-> IO (AWSResult ())
emptyBucket aws bucket =
do res <- listAllObjects aws bucket (ListRequest "" "" "" 0)
let objFromRes x = S3Object bucket (key x) "" [] L.empty
case res of
Left x -> return (Left x)
Right y -> deleteObjects aws (map objFromRes y)
deleteObjects :: AWSConnection
-> [S3Object]
-> IO (AWSResult ())
deleteObjects _ [] = return (Right ())
deleteObjects aws (x:xs) =
do dr <- deleteObject aws x
case dr of
Left o -> return (Left o)
Right _ -> deleteObjects aws xs
listBuckets :: AWSConnection
-> IO (AWSResult [S3Bucket])
listBuckets aws =
do res <- Auth.runAction (S3Action aws "" "" "" [] L.empty GET)
case res of
Left x -> return (Left x)
Right y -> do bs <- parseBucketListXML (L.unpack (rspBody y))
return (Right bs)
parseBucketListXML :: String -> IO [S3Bucket]
parseBucketListXML x = runX (readString [(a_validate,v_0)] x >>> processBuckets)
processBuckets :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) S3Bucket
processBuckets = deep (isElem >>> hasName "Bucket") >>>
split >>> first (text <<< atTag "Name") >>>
second (text <<< atTag "CreationDate") >>>
unsplit (\x y -> S3Bucket x y)
data ListRequest =
ListRequest { prefix :: String,
marker :: String,
delimiter :: String,
max_keys :: Int
}
instance Show ListRequest where
show x = "prefix=" ++ urlEncode (prefix x) ++ "&" ++
"marker=" ++ urlEncode (marker x) ++ "&" ++
"delimiter=" ++ urlEncode (delimiter x) ++ "&" ++
"max-keys=" ++ show (max_keys x)
data ListResult =
ListResult {
key :: String,
last_modified :: String,
etag :: String,
size :: Integer
} deriving (Show)
type IsTruncated = Bool
listObjects :: AWSConnection
-> String
-> ListRequest
-> IO (AWSResult (IsTruncated, [ListResult]))
listObjects aws bucket lreq =
do res <- Auth.runAction (S3Action aws bucket ""
('?' : show lreq) [] L.empty GET)
case res of
Left x -> return (Left x)
Right y -> do let objs = L.unpack (rspBody y)
tr <- isListTruncated objs
lr <- getListResults objs
return (Right (tr, lr))
listAllObjects :: AWSConnection
-> String
-> ListRequest
-> IO (AWSResult [ListResult])
listAllObjects aws bucket lp =
do let lp_max = lp {max_keys = 1000}
res <- listObjects aws bucket lp_max
case res of
Left x -> return (Left x)
Right y -> case y of
(True,lr) -> do let last_result = (key . last) lr
next_set <- listAllObjects aws bucket
(lp_max {marker = last_result})
either (\x -> return (Left x))
(\x -> return (Right (lr ++ x))) next_set
(False,lr) -> return (Right lr)
isListTruncated :: String -> IO Bool
isListTruncated s =
do results <- runX (readString [(a_validate,v_0)] s >>> processTruncation)
return $ case results of
[] -> False
x:_ -> x
processTruncation :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) Bool
processTruncation = (text <<< atTag "IsTruncated")
>>> arr (\x -> case (map toLower x) of
"true" -> True
"false" -> False
otherwise -> False)
getListResults :: String -> IO [ListResult]
getListResults s = runX (readString [(a_validate,v_0)] s >>> processListResults)
processListResults :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) ListResult
processListResults = deep (isElem >>> hasName "Contents") >>>
((text <<< atTag "Key") &&&
(text <<< atTag "LastModified") &&&
(text <<< atTag "ETag") &&&
(text <<< atTag "Size")) >>>
arr (\(a,(b,(c,d))) -> ListResult a b ((unquote . HTTP.urlDecode) c) (read d))
unquote :: String -> String
unquote = filter (/= '"')