diff --git a/Network/AWS/AWSConnection.hs b/Network/AWS/AWSConnection.hs --- a/Network/AWS/AWSConnection.hs +++ b/Network/AWS/AWSConnection.hs @@ -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 "") diff --git a/Network/AWS/ArrowUtils.hs b/Network/AWS/ArrowUtils.hs --- a/Network/AWS/ArrowUtils.hs +++ b/Network/AWS/ArrowUtils.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-monomorphism-restriction #-} +{-# LANGUAGE NoMonomorphismRestriction#-} ----------------------------------------------------------------------------- -- | -- Module : Network.AWS.ArrowUtils diff --git a/Network/AWS/Authentication.hs b/Network/AWS/Authentication.hs --- a/Network/AWS/Authentication.hs +++ b/Network/AWS/Authentication.hs @@ -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 diff --git a/Network/AWS/S3Bucket.hs b/Network/AWS/S3Bucket.hs --- a/Network/AWS/S3Bucket.hs +++ b/Network/AWS/S3Bucket.hs @@ -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 "" ++ location ++ "" + 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") &&& diff --git a/Network/AWS/S3Object.hs b/Network/AWS/S3Object.hs --- a/Network/AWS/S3Object.hs +++ b/Network/AWS/S3Object.hs @@ -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) diff --git a/README b/README --- a/README +++ b/README @@ -10,12 +10,16 @@ * Glasgow Haskell Compiler (GHC). Other compilers are untested. -* Haskell HTTP Library , the latest - version (>3000.0) is required, use the darcs repository. +* Haskell HTTP Library , at least + version 4000.0 is required. -* Haskell Cryptographic Library , the - latest version (>4.0.3) is required, use the darcs repository. +* Haskell Cryptographic Library , at + least version 4.1.0 is required. +* Dataenc library . + +* UTF8-String library . + * Haskell XML Toolbox (HXT) , 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). + +* for UTF-8 header compatibility and support for EU buckets. diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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) diff --git a/examples/deleteObject.hs b/examples/deleteObject.hs --- a/examples/deleteObject.hs +++ b/examples/deleteObject.hs @@ -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.")) diff --git a/examples/getObject.hs b/examples/getObject.hs --- a/examples/getObject.hs +++ b/examples/getObject.hs @@ -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 diff --git a/examples/listObjects.hs b/examples/listObjects.hs --- a/examples/listObjects.hs +++ b/examples/listObjects.hs @@ -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 ++ diff --git a/examples/sendObject.hs b/examples/sendObject.hs --- a/examples/sendObject.hs +++ b/examples/sendObject.hs @@ -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.")) diff --git a/examples/uploadFile.hs b/examples/uploadFile.hs --- a/examples/uploadFile.hs +++ b/examples/uploadFile.hs @@ -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 diff --git a/hS3.cabal b/hS3.cabal --- a/hS3.cabal +++ b/hS3.cabal @@ -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 Maintainer: Greg Heartsfield 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 diff --git a/hS3.hs b/hS3.hs new file mode 100644 --- /dev/null +++ b/hS3.hs @@ -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 [EU, US] : create bucket" + , "db : delete bucket" + , "do : delete object" + , "" + , "lbs : list buckets" + , "so : send object" + , "go : get object" + , "los : list objects" ]