module Network.AWS.S3Bucket (
createBucketIn, createBucket, createBucketWithPrefixIn,
createBucketWithPrefix, deleteBucket, getBucketLocation,
emptyBucket, listBuckets, listObjects, listAllObjects,
isBucketNameValid, getObjectStorageClass,
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, isAlphaNum)
import Data.List (isInfixOf)
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,
storageClass :: StorageClass
} 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)
getObjectStorageClass :: AWSConnection
-> S3Object
-> IO (AWSResult StorageClass)
getObjectStorageClass c obj =
do res <- listObjects c (obj_bucket obj) (ListRequest (obj_name obj) "" "" 1)
return (either Left (\(t,xs) -> Right (head (map storageClass xs))) res)
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") &&&
(text <<< atTag "StorageClass")) >>>
arr (\(a,(b,(c,(d,e)))) -> ListResult a b ((unquote . HTTP.urlDecode) c) (read d) (read e))
isBucketNameValid :: String -> Bool
isBucketNameValid n = and checks where
checks = [(length n >= 3),
(length n <= 63),
(isAlphaNum $ head n),
(not (elem '_' n)),
(not (isInfixOf ".-" n)),
(not (isInfixOf "-." n)),
((last n) /= '-')]
unquote :: String -> String
unquote = filter (/= '"')