module Network.AWS.S3Bucket (
createBucket, createBucketWithPrefix, deleteBucket,
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.URI as URI
import Network.Stream
import Data.Char (toLower)
import Text.XML.HXT.Arrow
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)
createBucketWithPrefix :: AWSConnection
-> String
-> IO (AWSResult String)
createBucketWithPrefix aws pre =
do suffix <- randomName
let name = pre ++ "-" ++ suffix
res <- createBucket aws name
either (\x -> case x of
AWSError c m -> createBucketWithPrefix aws pre
otherwise -> return (Left x))
(\x -> return (Right name)) res
randomName :: IO String
randomName =
do rdata <- randomIO :: IO Integer
return $ take 10 $ show $ hexdumpBy "" 999
(hash (toOctets 10 (abs rdata)))
createBucket :: AWSConnection
-> String
-> IO (AWSResult ())
createBucket aws bucket =
do res <- Auth.runAction (S3Action aws bucket "" "" [] "" PUT)
return (either (Left) (\x -> Right ()) res)
deleteBucket :: AWSConnection
-> String
-> IO (AWSResult ())
deleteBucket aws bucket =
do res <- Auth.runAction (S3Action aws bucket "" "" [] "" DELETE)
return (either (Left) (\x -> Right ()) res)
emptyBucket :: AWSConnection
-> String
-> IO (AWSResult ())
emptyBucket aws bucket =
do res <- listAllObjects aws bucket (ListRequest "" "" "" 0)
let objFromRes x = S3Object bucket (key x) "" [] ""
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 x -> return (Left x)
Right x -> deleteObjects aws xs
listBuckets :: AWSConnection
-> IO (AWSResult [S3Bucket])
listBuckets aws =
do res <- Auth.runAction (S3Action aws "" "" "" [] "" GET)
case res of
Left x -> do return (Left x)
Right y -> do bs <- parseBucketListXML (rspBody y)
return (Right bs)
parseBucketListXML :: String -> IO [S3Bucket]
parseBucketListXML x = runX (readString [(a_validate,v_0)] x >>> processBuckets)
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)) [] "" GET)
case res of
Left x -> do return (Left x)
Right y -> do let objs = 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 -> do return (Left x)
Right y -> case y of
(True,lr) -> do let last_result = (key . head . reverse) 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:xs -> x
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 = 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 (/= '"')