hS3 0.3 → 0.4
raw patch · 14 files changed
+351/−135 lines, 14 filesdep +bytestringdep ~HTTPnew-component:exe:hs3
Dependencies added: bytestring
Dependency ranges changed: HTTP
Files
- Network/AWS/AWSConnection.hs +8/−5
- Network/AWS/ArrowUtils.hs +1/−1
- Network/AWS/Authentication.hs +126/−80
- Network/AWS/S3Bucket.hs +71/−24
- Network/AWS/S3Object.hs +9/−7
- README +11/−5
- Tests.hs +39/−1
- examples/deleteObject.hs +2/−1
- examples/getObject.hs +3/−2
- examples/listObjects.hs +1/−0
- examples/sendObject.hs +4/−2
- examples/uploadFile.hs +2/−1
- hS3.cabal +14/−6
- hS3.hs +60/−0
Network/AWS/AWSConnection.hs view
@@ -42,15 +42,18 @@ amazonS3Connection = AWSConnection defaultAmazonS3Host defaultAmazonS3Port -- | Retrieve Access and Secret keys from environment variables--- AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET, respectively.+-- AWS_ACCESS_KEY_ID and AWS_SECRET_ACCESS_KEY, respectively. -- Either variable being undefined or empty will result in -- 'Nothing'. amazonS3ConnectionFromEnv :: IO (Maybe AWSConnection) amazonS3ConnectionFromEnv = do ak <- getEnvKey "AWS_ACCESS_KEY_ID"- sk <- getEnvKey "AWS_ACCESS_KEY_SECRET"- return $ case ((null ak) || (null sk)) of- True -> Nothing- False -> Just (amazonS3Connection ak sk)+ sk0 <- getEnvKey "AWS_ACCESS_KEY_SECRET"+ sk1 <- getEnvKey "AWS_SECRET_ACCESS_KEY"+ return $ case (ak, sk0, sk1) of+ ("", _, _) -> Nothing+ ( _, "", "") -> Nothing+ ( _, "", _) -> Just (amazonS3Connection ak sk1)+ ( _, _, _) -> Just (amazonS3Connection ak sk0) where getEnvKey s = do catch (getEnv s) (const $ return "")
Network/AWS/ArrowUtils.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-monomorphism-restriction #-}+{-# LANGUAGE NoMonomorphismRestriction#-} ----------------------------------------------------------------------------- -- | -- Module : Network.AWS.ArrowUtils
Network/AWS/Authentication.hs view
@@ -23,16 +23,20 @@ import Network.AWS.AWSConnection import Network.AWS.ArrowUtils import Network.HTTP as HTTP+import Network.HTTP.HandleStream (simpleHTTP_)+import Network.Stream (Result) import Network.URI as URI+import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.Char8 (pack, unpack)+ import Data.HMAC import Codec.Binary.Base64 (encode, decode) import Codec.Utils (Octet) -import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)+import Data.Char (intToDigit, digitToInt, ord, chr, toLower) import Data.Bits ((.&.)) import qualified Codec.Binary.UTF8.String as US-import Codec.Utils (Octet) import Data.List (sortBy, groupBy, intersperse) import Data.Maybe@@ -42,7 +46,7 @@ import Text.Regex -import Control.Arrow+--import Control.Arrow() import Text.XML.HXT.Arrow -- | An action to be performed using S3.@@ -59,7 +63,7 @@ -- | Additional header fields to send s3metadata :: [(String, String)], -- | Body of action, if sending data- s3body :: String,+ s3body :: L.ByteString, -- | Type of action, 'PUT', 'GET', etc. s3operation :: RequestMethod } deriving (Show)@@ -68,19 +72,19 @@ -- authentication or date information, so it is not suitable for -- sending directly to AWS. requestFromAction :: S3Action -- ^ Action to transform- -> HTTP.Request -- ^ Action represented as an HTTP Request.+ -> HTTP.HTTPRequest L.ByteString -- ^ Action represented as an HTTP Request. requestFromAction a = Request { rqURI = URI { uriScheme = "", uriAuthority = Nothing,- uriPath = canonicalizeResource a,+ uriPath = qpath, uriQuery = s3query a, uriFragment = "" }, rqMethod = s3operation a,- rqHeaders = [Header HdrHost (awsHost (s3conn a))] +++ rqHeaders = [Header HdrHost (s3Hostname a)] ++ (headersFromAction a),- rqBody = s3body a+ rqBody = (s3body a) }- where path = (s3bucket a) ++ "/" ++ (s3object a)+ where qpath = "/" ++ (s3object a) -- | Create 'Header' objects from an action. headersFromAction :: S3Action@@ -92,13 +96,13 @@ -- | Inspect HTTP body, and add a @Content-Length@ header with the -- correct length.-addContentLengthHeader :: HTTP.Request -> HTTP.Request-addContentLengthHeader req = insertHeader HdrContentLength (show (length (rqBody req))) req+addContentLengthHeader :: HTTP.HTTPRequest L.ByteString -> HTTP.HTTPRequest L.ByteString+addContentLengthHeader req = insertHeader HdrContentLength (show (L.length (rqBody req))) req -- | Add AWS authentication header to an HTTP request. addAuthenticationHeader :: S3Action -- ^ Action with authentication data- -> HTTP.Request -- ^ Request to transform- -> HTTP.Request -- ^ Authenticated request+ -> HTTP.HTTPRequest L.ByteString -- ^ Request to transform+ -> HTTP.HTTPRequest L.ByteString -- ^ Authenticated request addAuthenticationHeader act req = insertHeader HdrAuthorization auth_string req where auth_string = "AWS " ++ (awsAccessKey conn) ++ ":" ++ signature signature = makeSignature conn (stringToSign act req)@@ -109,20 +113,20 @@ -> String -- ^ String to sign -> String -- ^ Base-64 encoded signature makeSignature c s =- encode (hmac_sha1 keyOctets msgOctets)+ encode (hmac_sha1 keyOctets msgOctets) where keyOctets = string2words (awsSecretKey c) msgOctets = string2words s -- | Generate text that will be signed and subsequently added to the -- request.-stringToSign :: S3Action -> HTTP.Request -> String+stringToSign :: S3Action -> HTTP.HTTPRequest L.ByteString -> String stringToSign a r = (canonicalizeHeaders r) ++ (canonicalizeAmzHeaders r) ++ (canonicalizeResource a) -- | Extract header data needed for signing.-canonicalizeHeaders :: HTTP.Request -> String+canonicalizeHeaders :: HTTP.HTTPRequest L.ByteString -> String canonicalizeHeaders r = http_verb ++ "\n" ++ hdr_content_md5 ++ "\n" ++@@ -142,7 +146,7 @@ -- combine headers with same name -- unfold multi-line headers -- trim whitespace around the header-canonicalizeAmzHeaders :: HTTP.Request -> String+canonicalizeAmzHeaders :: HTTP.HTTPRequest L.ByteString -> String canonicalizeAmzHeaders r = let amzHeaders = filter isAmzHeader (rqHeaders r) amzHeaderKV = map headerToLCKeyValue amzHeaders@@ -153,15 +157,15 @@ -- | Give the string representation of a (key,value) header pair. -- Uses rules for authenticated headers. showHeader :: (String, String) -> String-showHeader (k,v) = k ++ ":" ++ removeLeadingWhitespace(fold_whitespace v)+showHeader (k,v) = k ++ ":" ++ removeLeadingTrailingWhitespace(fold_whitespace v) -- | Replace CRLF followed by whitespace with a single space fold_whitespace :: String -> String fold_whitespace s = subRegex (mkRegex "\n\r( |\t)+") s " " --- | strip leading tabs/spaces-removeLeadingWhitespace :: String -> String-removeLeadingWhitespace s = subRegex (mkRegex "^( |\t)+") s ""+-- | strip leading/trailing whitespace+removeLeadingTrailingWhitespace :: String -> String+removeLeadingTrailingWhitespace s = subRegex (mkRegex "^\\s+") (subRegex (mkRegex "\\s+$") s "") "" -- | Combine same-named headers. combineHeaders :: [[(String, String)]] -> [(String, String)]@@ -169,7 +173,7 @@ -- | Headers with same name should have values merged. mergeSameHeaders :: [(String, String)] -> (String, String)-mergeSameHeaders h@(x:xs) = let values = map snd h+mergeSameHeaders h@(x:_) = let values = map snd h in ((fst x), (concat $ intersperse "," values)) -- | Group headers with the same name.@@ -182,13 +186,13 @@ -- | Make 'Header' easier to work with, and lowercase keys. headerToLCKeyValue :: Header -> (String, String)-headerToLCKeyValue (Header k v) = (map toLower (show k), (mimeEncodeQP v))+headerToLCKeyValue (Header k v) = (map toLower (show k), v) -- | Determine if a header belongs in the StringToSign isAmzHeader :: Header -> Bool isAmzHeader h = case h of- Header (HdrCustom k) v -> isPrefix amzHeader k+ Header (HdrCustom k) _ -> isPrefix amzHeader k otherwise -> False -- | is the first list a prefix of the second?@@ -196,33 +200,41 @@ isPrefix a b = a == take (length a) b -- | Prefix used by Amazon metadata headers+amzHeader :: String amzHeader = "x-amz-" -- | Extract resource name, as required for signing. canonicalizeResource :: S3Action -> String canonicalizeResource a = bucket ++ uri- where uri = case (s3object a) of- "" -> ""- otherwise -> "/" ++ (s3object a)+ where uri = "/" ++ (s3object a) bucket = case (s3bucket a) of- b@(x:xs) -> "/" ++ b- otherwise -> case uri of- [] -> "/" -- at the least we have a "/"- otherwise -> ""+ b@(_:_) -> "/" ++ map toLower b+ otherwise -> ""++ -- | Add a date string to a request.-addDateToReq :: HTTP.Request -- ^ Request to modify+addDateToReq :: HTTP.HTTPRequest L.ByteString -- ^ Request to modify -> String -- ^ Date string, in RFC 2616 format- -> HTTP.Request -- ^ Request with date header added+ -> HTTP.HTTPRequest L.ByteString-- ^ Request with date header added addDateToReq r d = r {HTTP.rqHeaders = (HTTP.Header HTTP.HdrDate d) : (HTTP.rqHeaders r)} --- | Add an expiration date to a request-addExpirationToReq :: HTTP.Request -> String -> HTTP.Request+-- | Add an expiration date to a request.+addExpirationToReq :: HTTP.HTTPRequest L.ByteString -> String -> HTTP.HTTPRequest L.ByteString addExpirationToReq r e = addHeaderToReq r (HTTP.Header HTTP.HdrExpires e) -addHeaderToReq :: HTTP.Request -> Header -> HTTP.Request+-- | Attach an HTTP header to a request.+addHeaderToReq :: HTTP.HTTPRequest L.ByteString -> Header -> HTTP.HTTPRequest L.ByteString addHeaderToReq r h = r {HTTP.rqHeaders = h : (HTTP.rqHeaders r)} +-- | Get hostname to connect to. Needed for european buckets+s3Hostname :: S3Action -> String+s3Hostname a =+ let s3host = awsHost (s3conn a) in+ case (s3bucket a) of+ b@(_:_) -> b ++ "." ++ s3host+ otherwise -> s3host+ -- | Get current time in HTTP 1.1 format (RFC 2616) -- Numeric time zones should be used, but I'd rather not subvert the -- intent of ctTZName, so we stick with the name format. Otherwise,@@ -243,15 +255,21 @@ -- | Construct the request specified by an S3Action, send to Amazon, -- and return the response. Todo: add MD5 signature.-runAction :: S3Action -> IO (AWSResult Response)-runAction a = do c <- openTCPPort (awsHost (s3conn a)) (awsPort (s3conn a))- cd <- httpCurrentDate- let aReq = addAuthenticationHeader a $- addContentLengthHeader $- addDateToReq (requestFromAction a) cd- result <- (simpleHTTP_ c aReq)- createAWSResult result+runAction :: S3Action -> IO (AWSResult (HTTPResponse L.ByteString))+runAction a = runAction' a (s3Hostname a) +runAction' :: S3Action -> String -> IO (AWSResult (HTTPResponse L.ByteString))+runAction' a hostname = do+ c <- (openTCPConnection hostname (awsPort (s3conn a)))+--bufferOps = lazyBufferOp+ cd <- httpCurrentDate+ let aReq = addAuthenticationHeader a $+ addContentLengthHeader $+ addDateToReq (requestFromAction a) cd+ result <- simpleHTTP_ c aReq+ close c+ createAWSResult a result+ -- | Construct a pre-signed URI, but don't act on it. This is useful -- for when an expiration date has been set, and the URI needs to be -- passed on to a client.@@ -261,36 +279,47 @@ -> URI -- ^ URI of resource preSignedURI a e = let c = (s3conn a)- server = (awsHost c)- port = (show (awsPort c))+ srv = (awsHost c)+ pt = (show (awsPort c)) accessKeyQuery = "AWSAccessKeyId=" ++ (awsAccessKey c)- secretKey = (awsSecretKey c) beginQuery = case (s3query a) of "" -> "?" x -> x ++ "&" expireQuery = "Expires=" ++ (show e) toSign = "GET\n\n\n" ++ (show e) ++ "\n/" ++ (s3bucket a) ++ "/" ++ (s3object a) sigQuery = "Signature=" ++ (urlEncode (makeSignature c toSign))- query = beginQuery ++ accessKeyQuery ++ "&" +++ q = beginQuery ++ accessKeyQuery ++ "&" ++ expireQuery ++ "&" ++ sigQuery in URI { uriScheme = "http:",- uriAuthority = Just (URIAuth "" server (":" ++ port)),+ uriAuthority = Just (URIAuth "" srv (":" ++ pt)), uriPath = "/" ++ (s3bucket a) ++ "/" ++ (s3object a),- uriQuery = query,+ uriQuery = q, uriFragment = "" } -- | Inspect a response for network errors, HTTP error codes, and -- Amazon error messages.-createAWSResult :: Result Response -> IO (AWSResult Response)-createAWSResult b = either (handleError) (handleSuccess) b- where handleError x = return (Left (NetworkError x))- handleSuccess x = case (rspCode x) of- (2,y,z) -> return (Right x)- otherwise -> do err <- parseRestErrorXML (rspBody x)- return (Left err)-+-- We need the original action in case we get a 307 (temporary redirect)+createAWSResult :: S3Action -> Result (HTTPResponse L.ByteString) -> IO (AWSResult (HTTPResponse L.ByteString))+createAWSResult a b = either (handleError) (handleSuccess) b+ where handleError e = return (Left (NetworkError e))+ handleSuccess s = case (rspCode s) of+ (2,_,_) -> return (Right s)+ -- temporary redirect+ (3,0,7) -> case (findHeader HdrLocation s) of+ Just l -> runAction' a (getHostname l)+ Nothing -> return (Left $ AWSError "Temporary Redirect" "Redirect without location header") -- not good+ (4,0,4) -> return (Left $ AWSError "NotFound" "404 Not Found") -- no body, so no XML to parse+ otherwise -> do e <- parseRestErrorXML (L.unpack (rspBody s))+ return (Left e)+ -- Get hostname part from http url.+ getHostname :: String -> String+ getHostname h = case parseURI h of+ Just u -> case (uriAuthority u) of+ Just auth -> (uriRegName auth)+ Nothing -> ""+ Nothing -> "" -- | Find the errors embedded in an XML message body from Amazon. parseRestErrorXML :: String -> IO ReqError parseRestErrorXML x =@@ -313,42 +342,59 @@ --- mime header encoding mimeEncodeQP, mimeDecode :: String -> String --- | Decode a mime string, we only know about quoted printable UTF-8-mimeDecode a =- if isPrefix utf8qp a- -- =?UTF-8?Q?....?= -> decoded UTF-8 string- then US.decodeString $ mimeDecode' $ reverse $ drop 2 $ reverse $ drop (length utf8qp) a- else a+-- | Decode a mime string, we know about quoted printable and base64 encoded UTF-8+-- S3 may convert quoted printable to base64+mimeDecode a+ | isPrefix utf8qp a =+ mimeDecodeQP $ encoded_payload utf8qp a+ | isPrefix utf8b64 a =+ mimeDecodeB64 $ encoded_payload utf8b64 a+ | otherwise =+ a where- utf8qp = "=?UTF-8?Q?"+ utf8qp = "=?UTF-8?Q?"+ utf8b64 = "=?UTF-8?B?"+ -- '=?UTF-8?Q?foobar?=' -> 'foobar'+ encoded_payload prefix = reverse . drop 2 . reverse . drop (length prefix) -mimeDecode' :: String -> String-mimeDecode' ('=':a:b:rest) =+mimeDecodeQP :: String -> String+mimeDecodeQP =+ US.decodeString . mimeDecodeQP'++mimeDecodeQP' :: String -> String+mimeDecodeQP' ('=':a:b:rest) = chr (16 * digitToInt a + digitToInt b)- : mimeDecode' rest-mimeDecode' (h:t) = h : mimeDecode' t-mimeDecode' [] = []+ : mimeDecodeQP' rest+mimeDecodeQP' (h:t) =h : mimeDecodeQP' t+mimeDecodeQP' [] = [] +mimeDecodeB64 :: String -> String+mimeDecodeB64 s =+ case decode s of+ Nothing -> ""+ Just a -> US.decode a+ -- Encode a String into quoted printable, if needed. -- eq: =?UTF-8?Q?=aa?= mimeEncodeQP s =- if (any (\x -> ord x > 128) s )+ if any reservedChar s then "=?UTF-8?Q?" ++ (mimeEncodeQP' $ US.encodeString s) ++ "?=" else s mimeEncodeQP' :: String -> String+mimeEncodeQP' [] = [] mimeEncodeQP' (h:t) =- let str = if reserved (ord h) then escape h else [h]+ let str = if reservedChar h then escape h else [h] in str ++ mimeEncodeQP' t where- reserved x- | x >= ord 'a' && x <= ord 'z' = False- | x >= ord 'A' && x <= ord 'Z' = False- | x >= ord '0' && x <= ord '9' = False- | x == ord ' ' = False- | x <= 0x20 || x >= 0x7F = True- | otherwise = True escape x = let y = ord x in [ '=', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]-mimeEncodeQP' [] = []++-- Char needs escaping?+reservedChar :: Char -> Bool+reservedChar x+ -- from space (0x20) till '~' everything is fine. The rest are control chars, or high bit.+ | xi >= 0x20 && xi <= 0x7e = False+ | otherwise = True+ where xi = ord x
Network/AWS/S3Bucket.hs view
@@ -11,7 +11,8 @@ module Network.AWS.S3Bucket ( -- * Function Types- createBucket, createBucketWithPrefix, deleteBucket,+ createBucketIn, createBucket, createBucketWithPrefixIn,+ createBucketWithPrefix, deleteBucket, getBucketLocation, emptyBucket, listBuckets, listObjects, listAllObjects, -- * Data Types S3Bucket(S3Bucket, bucket_name, bucket_creation_date),@@ -27,12 +28,14 @@ import Network.AWS.ArrowUtils import Network.HTTP as HTTP-import Network.URI as URI-import Network.Stream+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@@ -48,44 +51,86 @@ -- | Create a new bucket on S3 with the given prefix, and a random -- suffix. This can be used to programatically create buckets -- without of naming conflicts.-createBucketWithPrefix :: AWSConnection -- ^ AWS connection information+createBucketWithPrefixIn :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name prefix+ -> String -- ^ "US" or "EU" -> IO (AWSResult String) -- ^ Server response, if -- successful, the bucket -- name is returned.--createBucketWithPrefix aws pre =+createBucketWithPrefixIn aws pre location = do suffix <- randomName let name = pre ++ "-" ++ suffix- res <- createBucket aws name+ res <- createBucketIn aws name location either (\x -> case x of- AWSError c m -> createBucketWithPrefix aws pre+ AWSError _ _ -> createBucketWithPrefixIn aws pre location otherwise -> return (Left x))- (\x -> return (Right name)) res+ (\_ -> return (Right name)) res +-- | see createBucketWithPrefixIn, but hardcoded for the US+createBucketWithPrefix :: AWSConnection -- ^ AWS connection information+ -> String -- ^ Bucket name prefix+ -> IO (AWSResult String) -- ^ Server response, with bucket name+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 (abs rdata)))+ (hash (toOctets (10::Integer) (abs rdata))) -- | Create a new bucket on S3 with the given name.+createBucketIn :: AWSConnection -- ^ AWS connection information+ -> String -- ^ Proposed bucket name+ -> String -- ^ "US" or "EU"+ -> IO (AWSResult ()) -- ^ Server response+createBucketIn aws bucket location =+ let constraint = if location == "US"+ then "" -- US == no body+ else "<CreateBucketConfiguration><LocationConstraint>" ++ location ++ "</LocationConstraint></CreateBucketConfiguration>"+ in+ do res <- Auth.runAction (S3Action aws bucket "" "" [] (L.pack constraint) PUT)+ -- throw away the server response, return () on success+ return (either (Left) (\_ -> Right ()) res)++-- | Create a new bucket on S3 with the given name. createBucket :: AWSConnection -- ^ AWS connection information -> String -- ^ Proposed bucket name -> IO (AWSResult ()) -- ^ Server response createBucket aws bucket =- do res <- Auth.runAction (S3Action aws bucket "" "" [] "" PUT)- -- throw away the server response, return () on success- return (either (Left) (\x -> Right ()) res)+ createBucketIn aws bucket "US" +-- | Physical location of the bucket. "US" or "EU"+getBucketLocation :: AWSConnection -- ^ AWS connection information+ -> String -- ^ Bucket name+ -> IO (AWSResult String) -- ^ Server response ("US" or "EU")+getBucketLocation aws bucket =+ do res <- Auth.runAction (S3Action aws bucket "?location" "" [] L.empty GET)+ case res of+ Left x -> do 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" -- not specified by S3, but they are in the US+ x:_ -> x++processLocation :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) String+processLocation = (text <<< atTag "LocationConstraint")+ >>> arr (\x -> x)+ -- | Delete a bucket with the given name on S3. The bucket must be -- empty for deletion to succeed. deleteBucket :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name to delete -> IO (AWSResult ()) -- ^ Server response deleteBucket aws bucket =- do res <- Auth.runAction (S3Action aws bucket "" "" [] "" DELETE)- return (either (Left) (\x -> Right ()) res)+ do res <- Auth.runAction (S3Action aws bucket "" "" [] L.empty DELETE)+ return (either (Left) (\_ -> Right ()) res) -- | Empty a bucket of all objects. Iterates through all objects -- issuing delete commands, so time is proportional to number of@@ -96,7 +141,7 @@ -> IO (AWSResult ()) -- ^ Server response emptyBucket aws bucket = do res <- listAllObjects aws bucket (ListRequest "" "" "" 0)- let objFromRes x = S3Object bucket (key x) "" [] ""+ let objFromRes x = S3Object bucket (key x) "" [] L.empty case res of Left x -> return (Left x) Right y -> deleteObjects aws (map objFromRes y)@@ -109,23 +154,24 @@ deleteObjects aws (x:xs) = do dr <- deleteObject aws x case dr of- Left x -> return (Left x)- Right x -> deleteObjects aws xs+ Left o -> return (Left o)+ Right _ -> deleteObjects aws xs -- | Return a list of all bucket names and creation dates. S3 -- allows a maximum of 100 buckets per user. listBuckets :: AWSConnection -- ^ AWS connection information -> IO (AWSResult [S3Bucket]) -- ^ Server response listBuckets aws =- do res <- Auth.runAction (S3Action aws "" "" "" [] "" GET)+ do res <- Auth.runAction (S3Action aws "" "" "" [] L.empty GET) case res of Left x -> do return (Left x)- Right y -> do bs <- parseBucketListXML (rspBody y)+ 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") >>>@@ -167,10 +213,10 @@ -> IO (AWSResult (IsTruncated, [ListResult])) -- ^ Server response listObjects aws bucket lreq = do res <- Auth.runAction (S3Action aws bucket ""- ("?" ++ (show lreq)) [] "" GET)+ ("?" ++ (show lreq)) [] L.empty GET) case res of Left x -> do return (Left x)- Right y -> do let objs = rspBody y+ Right y -> do let objs = L.unpack (rspBody y) tr <- isListTruncated objs lr <- getListResults objs return (Right (tr, lr))@@ -201,8 +247,9 @@ do results <- runX (readString [(a_validate,v_0)] s >>> processTruncation) return $ case results of [] -> False- x:xs -> x+ 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@@ -213,7 +260,7 @@ getListResults :: String -> IO [ListResult] getListResults s = runX (readString [(a_validate,v_0)] s >>> processListResults) --- | Learning arrows on the job.+processListResults :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) ListResult processListResults = deep (isElem >>> hasName "Contents") >>> ((text <<< atTag "Key") &&& (text <<< atTag "LastModified") &&&
Network/AWS/S3Object.hs view
@@ -24,6 +24,8 @@ import Network.URI import System.Time +import qualified Data.ByteString.Lazy.Char8 as L+ -- | An object that can be stored and retrieved from S3. data S3Object = S3Object { -- | Name of the bucket containing this object@@ -41,7 +43,7 @@ -- including these headers. obj_headers :: [(String, String)], -- | Object data.- obj_data :: String+ obj_data :: L.ByteString } deriving (Read, Show) -- | Send data for an object.@@ -55,7 +57,7 @@ (("Content-Type", (content_type obj)) : (obj_headers obj)) (obj_data obj) PUT)- return (either (Left) (\x -> Right ()) res)+ return (either (Left) (\_ -> Right ()) res) -- | Create a pre-signed request URI. Anyone can use this to request -- an object until the specified date.@@ -65,7 +67,7 @@ -- 00:00:00 UTC on January 1, 1970 -> URI -- ^ URI for the object publicUriUntilTime c obj time =- let act = S3Action c (obj_bucket obj) (obj_name obj) "" [] "" GET+ let act = S3Action c (obj_bucket obj) (obj_name obj) "" [] (L.empty) GET in preSignedURI act time -- | Create a pre-signed request URI. Anyone can use this to request@@ -101,14 +103,14 @@ (obj_name obj) "" (obj_headers obj)- "" m)+ (L.empty) m) return (either (Left) (\x -> Right (populate_obj_from x)) res) where populate_obj_from x = obj { obj_data = (rspBody x), obj_headers = (headersFromResponse x) } -headersFromResponse :: Response -> [(String,String)]+headersFromResponse :: HTTPResponse L.ByteString -> [(String,String)] headersFromResponse r = let respheaders = rspHeaders r in map (\x -> case x of@@ -125,7 +127,7 @@ (obj_name obj) "" (obj_headers obj)- "" DELETE)- return (either (Left) (\x -> Right ()) res)+ L.empty DELETE)+ return (either (Left) (\_ -> Right ()) res)
README view
@@ -10,12 +10,16 @@ * Glasgow Haskell Compiler (GHC). Other compilers are untested. -* Haskell HTTP Library <http://www.haskell.org/http/>, the latest- version (>3000.0) is required, use the darcs repository.+* Haskell HTTP Library <http://www.haskell.org/http/>, at least+ version 4000.0 is required. -* Haskell Cryptographic Library <http://www.haskell.org/crypto/>, the- latest version (>4.0.3) is required, use the darcs repository.+* Haskell Cryptographic Library <http://www.haskell.org/crypto/>, at+ least version 4.1.0 is required. +* Dataenc library <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/dataenc-0.10.2>.++* UTF8-String library <http://code.haskell.org/utf8-string/>.+ * Haskell XML Toolbox (HXT) <http://www.fh-wedel.de/~si/HXmlToolbox/>, tested with version 7.3, earlier versions may work. @@ -37,5 +41,7 @@ * Authors and contributors to the HTTP, Crypto, and HXT projects. -* Jinesh Varia (Amazon Web Services Evangelist)+* Jinesh Varia (Amazon Web Services Evangelist).++* <harmen@millionmonkeys.nl> for UTF-8 header compatibility and support for EU buckets.
Tests.hs view
@@ -17,6 +17,7 @@ import Network.AWS.S3Object import Network.AWS.S3Bucket import Data.Maybe (fromJust)+import qualified Data.ByteString.Lazy.Char8 as L import Test.HUnit @@ -29,14 +30,19 @@ testBucket = "hS3-test" testObjectTemplate = S3Object testBucket "hS3-object-test" "text/plain"- [("x-amz-meta-foo", "bar")] "Hello S3!"+ [("x-amz-meta-foo", "bar"),+ ("x-amz-meta-french", "Bonjour, ça va?"),+ ("x-amz-meta-smiley", "☺")+ ] (L.pack "Hello S3!") + -- | A sequence of several operations. s3operationsTest = TestCase ( do c <- getConn -- Bucket Creation bucket <- testCreateBucket c+ testGetBucketLocation c bucket "US" let testObj = testObjectTemplate {obj_bucket = bucket} -- Object send testSendObject c testObj@@ -55,6 +61,17 @@ testListAllObjects c bucket 0 -- Delete bucket testDeleteBucket c bucket+ -- Bucket should be gone+ testBucketGone c bucket++ -- Bucket in europe+ euBucket <- testCreateBucketIn c "EU"+ testGetBucketLocation c euBucket "EU"+ let euTestObj = testObjectTemplate {obj_bucket = euBucket}+ testSendObject c euTestObj+ testGetObject c euTestObj+ testDeleteObject c euTestObj+ testDeleteBucket c euBucket ) failOnError :: (Show a) =>@@ -73,6 +90,18 @@ return x ) +testCreateBucketIn :: AWSConnection -> String -> IO String+testCreateBucketIn c location =+ do r <- createBucketWithPrefixIn c testBucket location+ failOnError r "" (\x -> do assertBool ("bucket creation in " ++ location) True+ return x+ )++testGetBucketLocation :: AWSConnection -> String -> String -> IO ()+testGetBucketLocation c bucket expectedLocation =+ do r <- getBucketLocation c bucket+ failOnError r () (\x -> do assertEqual ("Bucket in the " ++ expectedLocation) expectedLocation x)+ testSendObject :: AWSConnection -> S3Object -> IO () testSendObject c o = do r <- sendObject c o@@ -122,6 +151,15 @@ do r <- deleteBucket c bucket failOnError r () (const $ assertBool "bucket deletion" True)++-- test if a bucket is not present+testBucketGone :: AWSConnection -> String -> IO ()+testBucketGone c bucket =+ do r <- getBucketLocation c bucket+ either (\(AWSError code msg) -> assertEqual "Bucket is gone" "NotFound" code)+ (\x -> do assertFailure "Bucket still there, should be gone"+ return ())+ r getConn = do mConn <- amazonS3ConnectionFromEnv return (fromJust mConn)
examples/deleteObject.hs view
@@ -22,12 +22,13 @@ import Network.AWS.AWSResult import System.Environment import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn let bucket : key : xs = argv- let obj = S3Object bucket key "" [] ""+ let obj = S3Object bucket key "" [] L.empty res <- deleteObject conn obj either (putStrLn . prettyReqError) (const $ putStrLn ("Key " ++ key ++ " has been removed, if it existed before."))
examples/getObject.hs view
@@ -22,14 +22,15 @@ import Network.AWS.AWSResult import System.Environment import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs let bucket : key : xs = argv- let obj = S3Object bucket key "" [] ""+ let obj = S3Object bucket key "" [] L.empty mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- getObject conn obj either (putStrLn . prettyReqError) (\x -> do putStrLn ("Key " ++ key ++ " has been retrieved. Content follows:")- putStrLn (obj_data x))+ L.putStrLn (obj_data x)) res
examples/listObjects.hs view
@@ -28,6 +28,7 @@ mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- listAllObjects conn bucket (ListRequest "" "" "" 1000)+ putStrLn (show (ListRequest "" "" "" 1000)) either (putStrLn . prettyReqError) (\x -> do putStrLn ("Key list from bucket " ++ bucket ++
examples/sendObject.hs view
@@ -9,7 +9,7 @@ -- Create a new public object with some content. This can be viewed through -- a web browser afterwards by visiting http://bucket.s3.amazonaws.com/object -- Usage:--- listObjects.hs bucket-name object-name "Some Object Content."+-- sendObject.hs bucket-name object-name "Some Object Content." -- -- This requires the following environment variables to be set with -- your Amazon keys:@@ -23,12 +23,14 @@ import Network.AWS.AWSResult import System.Environment import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs let bucket : key : content : xs = argv mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn- let obj = S3Object bucket key "text/html" [("x-amz-acl", "public-read")] content+ let obj = S3Object bucket key "text/html" [("x-amz-acl", "public-read")]+ (L.pack content) res <- sendObject conn obj either (putStrLn . prettyReqError) (const $ putStrLn ("Creation of " ++ key ++ " successful."))
examples/uploadFile.hs view
@@ -23,10 +23,11 @@ import System.Environment import Data.Maybe import System.IO+import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs let bucket : key : filename : xs = argv- f <- readFile filename+ f <- L.readFile filename mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn let obj = S3Object bucket key "text/plain" [] f
hS3.cabal view
@@ -1,14 +1,16 @@ Name: hS3-Version: 0.3+Version: 0.4 License: BSD3 License-file: LICENSE+Cabal-Version: >= 1.2 Copyright: - Copyright (c) 2007, Greg Heartsfield+ Copyright (c) 2008, Greg Heartsfield Author: Greg Heartsfield <scsibug@imap.cc> Maintainer: Greg Heartsfield <scsibug@imap.cc> Homepage: http://gregheartsfield.com/repos/hS3/doc/ Category: Network, Web Stability: Alpha+build-type: Simple Synopsis: Interface to Amazon's Simple Storage Service (S3) Description: This is the Haskell S3 library. It provides an interface to Amazon's Simple Storage Service (S3), allowing Haskell@@ -23,13 +25,19 @@ examples/getObject.hs examples/listObjects.hs examples/uploadFile.hs-Build-depends: base, HTTP >= 3000.0.0, Crypto >= 4.1.0, hxt, network,- regex-compat, old-time, random, old-locale, dataenc, utf8-string-Build-type: Simple-Exposed-modules:++Library++ Build-depends: base, HTTP >= 4000.0.0, Crypto >= 4.1.0, hxt, network,+ regex-compat, old-time, random, old-locale, dataenc, utf8-string, bytestring++ Exposed-modules: Network.AWS.S3Object, Network.AWS.S3Bucket, Network.AWS.AWSResult, Network.AWS.AWSConnection, Network.AWS.Authentication, Network.AWS.ArrowUtils++Executable hs3+ main-is: hS3.hs
+ hS3.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- |+-- Module : hS3+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Command-line program for interacting with S3.+-----------------------------------------------------------------------------+module Main where++import Network.AWS.S3Bucket+import Network.AWS.AWSConnection+import Network.AWS.AWSResult+import System.Environment+import System.IO+import Data.Maybe+import Network.AWS.S3Object+import qualified Data.ByteString.Lazy.Char8 as L++withConn :: ( AWSConnection -> IO (AWSResult a)) -> IO a+withConn f = do+ mConn <- amazonS3ConnectionFromEnv+ case mConn of+ Just c -> fmap (either (error . prettyReqError) -- failure+ id ) $ f c+ Nothing -> error "couldn't connect"++main :: IO ()+main = do+ args <- getArgs+ case args of+ -- create / delete bucket+ ["cb", name, location] -> withConn $ \g -> createBucketIn g name location+ ["db", name ] -> withConn $ \g -> deleteBucket g name+ -- objects+ ["go", bucket, gkey ] ->+ do c <- withConn $ \g -> getObject g $ S3Object bucket gkey "" [] L.empty+ L.putStr $ obj_data c+ ["so", bucket, skey ] ->+ (\c -> withConn $ \g -> sendObject g $ S3Object bucket skey "" [] c)+ =<< L.getContents+ ["los", bucket] ->+ do l <- withConn $ \g -> listObjects g bucket (ListRequest "" "" "" 1000)+ print l+ ["lbs"] -> do l <- withConn listBuckets+ print l+ _ -> usage++usage :: IO ()+usage = putStr $ unlines [+ "export AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET"+ , ""+ , "cb <name> [EU, US] : create bucket"+ , "db <name> : delete bucket"+ , "do <bucket> <key> : delete object"+ , ""+ , "lbs : list buckets"+ , "so : send object"+ , "go : get object"+ , "los : list objects" ]