hS3 0.4 → 0.5
raw patch · 12 files changed
+110/−112 lines, 12 files
Files
- CONTRIBUTORS +2/−0
- Network/AWS/AWSConnection.hs +1/−1
- Network/AWS/Authentication.hs +30/−31
- Network/AWS/S3Bucket.hs +14/−14
- Network/AWS/S3Object.hs +6/−6
- README +1/−43
- Tests.hs +10/−7
- examples/listBuckets.hs +1/−1
- examples/listObjects.hs +3/−3
- examples/preSignedRequest.hs +31/−0
- hS3.cabal +7/−3
- hS3.hs +4/−3
+ CONTRIBUTORS view
@@ -0,0 +1,2 @@+- <harmen@millionmonkeys.nl>+- Marc Weber <marco-oweber@gmx.de>
Network/AWS/AWSConnection.hs view
@@ -55,5 +55,5 @@ ( _, "", "") -> Nothing ( _, "", _) -> Just (amazonS3Connection ak sk1) ( _, _, _) -> Just (amazonS3Connection ak sk0)- where getEnvKey s = do catch (getEnv s) (const $ return "")+ where getEnvKey s = catch (getEnv s) (const $ return "")
Network/AWS/Authentication.hs view
@@ -80,19 +80,19 @@ uriQuery = s3query a, uriFragment = "" }, rqMethod = s3operation a,- rqHeaders = [Header HdrHost (s3Hostname a)] ++- (headersFromAction a),+ rqHeaders = Header HdrHost (s3Hostname a) :+ headersFromAction a, rqBody = (s3body a) }- where qpath = "/" ++ (s3object a)+ where qpath = '/' : s3object a -- | Create 'Header' objects from an action. headersFromAction :: S3Action -> [Header]-headersFromAction a = map (\(k,v) -> case k of- "Content-Type" -> Header HdrContentType v- otherwise -> (Header (HdrCustom k)) (mimeEncodeQP v))- (s3metadata a)+headersFromAction = map (\(k,v) -> case k of+ "Content-Type" -> Header HdrContentType v+ otherwise -> Header (HdrCustom k) (mimeEncodeQP v))+ . s3metadata -- | Inspect HTTP body, and add a @Content-Length@ header with the -- correct length.@@ -104,7 +104,7 @@ -> 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+ where auth_string = "AWS " ++ awsAccessKey conn ++ ":" ++ signature signature = makeSignature conn (stringToSign act req) conn = s3conn act @@ -121,9 +121,9 @@ -- request. stringToSign :: S3Action -> HTTP.HTTPRequest L.ByteString -> String stringToSign a r =- (canonicalizeHeaders r) ++- (canonicalizeAmzHeaders r) ++- (canonicalizeResource a)+ canonicalizeHeaders r +++ canonicalizeAmzHeaders r +++ canonicalizeResource a -- | Extract header data needed for signing. canonicalizeHeaders :: HTTP.HTTPRequest L.ByteString -> String@@ -136,8 +136,8 @@ hdr_content_md5 = get_header HdrContentMD5 hdr_date = get_header HdrDate hdr_content_type = get_header HdrContentType- get_header h = maybe "" id (findHeader h r)- dateOrExpiration = maybe hdr_date id (findHeader HdrExpires r)+ get_header h = fromMaybe "" (findHeader h r)+ dateOrExpiration = fromMaybe hdr_date (findHeader HdrExpires r) -- | Extract @x-amz-*@ headers needed for signing. -- find all headers with type HdrCustom that begin with amzHeader@@ -152,7 +152,7 @@ amzHeaderKV = map headerToLCKeyValue amzHeaders sortedGroupedHeaders = groupHeaders (sortHeaders amzHeaderKV) uniqueHeaders = combineHeaders sortedGroupedHeaders- in concat (map (\a -> a ++ "\n") (map showHeader uniqueHeaders))+ in concatMap (\a -> a ++ "\n") (map showHeader uniqueHeaders) -- | Give the string representation of a (key,value) header pair. -- Uses rules for authenticated headers.@@ -169,7 +169,7 @@ -- | Combine same-named headers. combineHeaders :: [[(String, String)]] -> [(String, String)]-combineHeaders h = map mergeSameHeaders h+combineHeaders = map mergeSameHeaders -- | Headers with same name should have values merged. mergeSameHeaders :: [(String, String)] -> (String, String)@@ -178,11 +178,11 @@ -- | Group headers with the same name. groupHeaders :: [(String, String)] -> [[(String, String)]]-groupHeaders = groupBy (\a b -> (fst a) == (fst b))+groupHeaders = groupBy (\a b -> fst a == fst b) -- | Sort by key name. sortHeaders :: [(String, String)] -> [(String, String)]-sortHeaders = sortBy (\a b -> (fst a) `compare` (fst b))+sortHeaders = sortBy (\a b -> fst a `compare` fst b) -- | Make 'Header' easier to work with, and lowercase keys. headerToLCKeyValue :: Header -> (String, String)@@ -206,9 +206,9 @@ -- | Extract resource name, as required for signing. canonicalizeResource :: S3Action -> String canonicalizeResource a = bucket ++ uri- where uri = "/" ++ (s3object a)+ where uri = '/' : s3object a bucket = case (s3bucket a) of- b@(_:_) -> "/" ++ map toLower b+ b@(_:_) -> '/' : map toLower b otherwise -> "" @@ -217,15 +217,15 @@ -> String -- ^ Date string, in RFC 2616 format -> HTTP.HTTPRequest L.ByteString-- ^ Request with date header added addDateToReq r d = r {HTTP.rqHeaders =- (HTTP.Header HTTP.HdrDate d) : (HTTP.rqHeaders r)}+ HTTP.Header HTTP.HdrDate d : HTTP.rqHeaders r} -- | 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)+addExpirationToReq r = addHeaderToReq r . HTTP.Header HTTP.HdrExpires -- | 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)}+addHeaderToReq r h = r {HTTP.rqHeaders = h : HTTP.rqHeaders r} -- | Get hostname to connect to. Needed for european buckets s3Hostname :: S3Action -> String@@ -281,18 +281,18 @@ let c = (s3conn a) srv = (awsHost c) pt = (show (awsPort c))- accessKeyQuery = "AWSAccessKeyId=" ++ (awsAccessKey c)+ accessKeyQuery = "AWSAccessKeyId=" ++ awsAccessKey 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))+ expireQuery = "Expires=" ++ show e+ toSign = "GET\n\n\n" ++ show e ++ "\n/" ++ s3bucket a ++ "/" ++ s3object a+ sigQuery = "Signature=" ++ urlEncode (makeSignature c toSign) q = beginQuery ++ accessKeyQuery ++ "&" ++ expireQuery ++ "&" ++ sigQuery in URI { uriScheme = "http:",- uriAuthority = Just (URIAuth "" srv (":" ++ pt)),- uriPath = "/" ++ (s3bucket a) ++ "/" ++ (s3object a),+ uriAuthority = Just (URIAuth "" srv (':' : pt)),+ uriPath = "/" ++ s3bucket a ++ "/" ++ s3object a, uriQuery = q, uriFragment = "" }@@ -302,8 +302,8 @@ -- Amazon error messages. -- 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))+createAWSResult a b = either handleError handleSuccess b+ where handleError = return . Left . NetworkError handleSuccess s = case (rspCode s) of (2,_,_) -> return (Right s) -- temporary redirect@@ -341,7 +341,6 @@ --- mime header encoding mimeEncodeQP, mimeDecode :: String -> String- -- | Decode a mime string, we know about quoted printable and base64 encoded UTF-8 -- S3 may convert quoted printable to base64 mimeDecode a
Network/AWS/S3Bucket.hs view
@@ -91,7 +91,7 @@ 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)+ return (either Left (\_ -> Right ()) res) -- | Create a new bucket on S3 with the given name. createBucket :: AWSConnection -- ^ AWS connection information@@ -107,7 +107,7 @@ getBucketLocation aws bucket = do res <- Auth.runAction (S3Action aws bucket "?location" "" [] L.empty GET) case res of- Left x -> do return (Left x)+ Left x -> return (Left x) Right y -> do bs <- parseBucketLocationXML (L.unpack (rspBody y)) return (Right bs) @@ -121,7 +121,7 @@ processLocation :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) String processLocation = (text <<< atTag "LocationConstraint")- >>> arr (\x -> x)+ >>> arr id -- | Delete a bucket with the given name on S3. The bucket must be -- empty for deletion to succeed.@@ -130,7 +130,7 @@ -> IO (AWSResult ()) -- ^ Server response deleteBucket aws bucket = do res <- Auth.runAction (S3Action aws bucket "" "" [] L.empty DELETE)- return (either (Left) (\_ -> Right ()) res)+ 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@@ -164,7 +164,7 @@ listBuckets aws = do res <- Auth.runAction (S3Action aws "" "" "" [] L.empty GET) case res of- Left x -> do return (Left x)+ Left x -> return (Left x) Right y -> do bs <- parseBucketListXML (L.unpack (rspBody y)) return (Right bs) @@ -186,10 +186,10 @@ } instance Show ListRequest where- show x = "prefix=" ++ (urlEncode (prefix x)) ++ "&" ++- "marker=" ++ (urlEncode (marker x)) ++ "&" ++- "delimiter=" ++ (urlEncode (delimiter x)) ++ "&" ++- "max-keys=" ++ (show (max_keys x))+ show x = "prefix=" ++ urlEncode (prefix x) ++ "&" +++ "marker=" ++ urlEncode (marker x) ++ "&" +++ "delimiter=" ++ urlEncode (delimiter x) ++ "&" +++ "max-keys=" ++ show (max_keys x) -- | Result from listing objects. data ListResult =@@ -213,9 +213,9 @@ -> IO (AWSResult (IsTruncated, [ListResult])) -- ^ Server response listObjects aws bucket lreq = do res <- Auth.runAction (S3Action aws bucket ""- ("?" ++ (show lreq)) [] L.empty GET)+ ('?' : show lreq) [] L.empty GET) case res of- Left x -> do return (Left x)+ Left x -> return (Left x) Right y -> do let objs = L.unpack (rspBody y) tr <- isListTruncated objs lr <- getListResults objs@@ -230,9 +230,9 @@ do let lp_max = lp {max_keys = 1000} res <- listObjects aws bucket lp_max case res of- Left x -> do return (Left x)+ Left x -> return (Left x) Right y -> case y of- (True,lr) -> do let last_result = (key . head . reverse) lr+ (True,lr) -> do let last_result = (key . last) lr next_set <- listAllObjects aws bucket (lp_max {marker = last_result}) either (\x -> return (Left x))@@ -266,7 +266,7 @@ (text <<< atTag "LastModified") &&& (text <<< atTag "ETag") &&& (text <<< atTag "Size")) >>>- arr (\(a,(b,(c,d))) -> ListResult a b (unquote . HTTP.urlDecode $ c) (read d))+ arr (\(a,(b,(c,d))) -> ListResult a b ((unquote . HTTP.urlDecode) c) (read d)) -- | Remove quote characters from a 'String'. unquote :: String -> String
Network/AWS/S3Object.hs view
@@ -55,9 +55,9 @@ (obj_name obj) "" (("Content-Type", (content_type obj)) :- (obj_headers obj))+ obj_headers obj) (obj_data obj) PUT)- return (either (Left) (\_ -> 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.@@ -67,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) "" [] (L.empty) 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@@ -103,8 +103,8 @@ (obj_name obj) "" (obj_headers obj)- (L.empty) m)- return (either (Left) (\x -> Right (populate_obj_from x)) res)+ L.empty m)+ return (either Left (\x -> Right (populate_obj_from x)) res) where populate_obj_from x = obj { obj_data = (rspBody x),@@ -128,6 +128,6 @@ "" (obj_headers obj) L.empty DELETE)- return (either (Left) (\_ -> Right ()) res)+ return (either Left (\_ -> Right ()) res)
README view
@@ -1,47 +1,5 @@-DESCRIPTION- This is the Haskell S3 library (hS3). It provides an interface to Amazon's Simple Storage Service, allowing Haskell developers to reliably store and retrieve arbitrary amounts of data from anywhere on the Internet. To learn more about Amazon S3, and sign up for an-account, visit <http://aws.amazon.com/s3>.--REQUIREMENTS--* Glasgow Haskell Compiler (GHC). Other compilers are untested.--* Haskell HTTP Library <http://www.haskell.org/http/>, at least- version 4000.0 is required.--* 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.--INSTALLATION--* Configure:--$ runhaskell Setup.hs configure--* Compile:--$ runhaskell Setup.hs build--* Install (as root):--# runhaskell Setup.hs install--ACKNOWLEDGEMENTS--* Authors and contributors to the HTTP, Crypto, and HXT projects.--* Jinesh Varia (Amazon Web Services Evangelist).--* <harmen@millionmonkeys.nl> for UTF-8 header compatibility and support for EU buckets.-+account, visit [http://aws.amazon.com/s3].
Tests.hs view
@@ -79,9 +79,11 @@ -> t -- ^ Value to return on failure -> (b -> IO t) -- ^ Assertions to run on success -> IO t-failOnError r f d = do either (\x -> do assertFailure (show x)- return f)- (\x -> do d x) r+failOnError r f d = either+ (\x ->+ do assertFailure (show x)+ return f)+ (\x -> d x) r testCreateBucket :: AWSConnection -> IO String testCreateBucket c =@@ -100,7 +102,9 @@ 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)+ failOnError r () (\x ->+ assertEqual ("Bucket in the " ++ expectedLocation)+ expectedLocation x) testSendObject :: AWSConnection -> S3Object -> IO () testSendObject c o =@@ -155,11 +159,10 @@ -- test if a bucket is not present testBucketGone :: AWSConnection -> String -> IO () testBucketGone c bucket =- do r <- getBucketLocation c bucket+ 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)@@ -169,5 +172,5 @@ headersToIgnore = ["x-amz-id-2", "x-amz-request-id"] realMetadata :: [(String, b)] -> [(String, b)]-realMetadata = filter (\x -> (fst x) `notElem` headersToIgnore)+realMetadata = filter (\x -> fst x `notElem` headersToIgnore)
examples/listBuckets.hs view
@@ -26,4 +26,4 @@ main = do mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- listBuckets conn- either (putStrLn . show) (mapM_ (putStrLn . bucket_name)) res+ either print (mapM_ (putStrLn . bucket_name)) res
examples/listObjects.hs view
@@ -28,12 +28,12 @@ mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- listAllObjects conn bucket (ListRequest "" "" "" 1000)- putStrLn (show (ListRequest "" "" "" 1000))+ print (ListRequest "" "" "" 1000) either (putStrLn . prettyReqError) (\x -> do putStrLn ("Key list from bucket " ++ bucket ++ " has been retrieved. Key/Etag follows:")- mapM_ (\x -> putStrLn ((key x) +++ mapM_ (\x -> putStrLn (key x ++ " " ++- (etag x))) x+ etag x)) x ) res
+ examples/preSignedRequest.hs view
@@ -0,0 +1,31 @@+#!/usr/local/bin/runhaskell++-----------------------------------------------------------------------------+-- |+-- Program : PreSigned Request+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Generate a pre-signed object request, suitable for sending to a 3rd party.+-- Usage:+-- preSignedRequest.hs bucket-name object-name seconds-request-valid+--+-- This requires the following environment variables to be set with+-- your Amazon keys:+-- AWS_ACCESS_KEY_ID+-- AWS_ACCESS_KEY_SECRET+-----------------------------------------------------------------------------++import Network.AWS.S3Object+import Network.AWS.AWSConnection+import System.Environment+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L++main = do argv <- getArgs+ let bucket : key : seconds : xs = argv+ mConn <- amazonS3ConnectionFromEnv+ let conn = fromJust mConn+ let obj = S3Object bucket key "" [] L.empty+ uri <- (publicUriForSeconds conn obj (read seconds))+ print uri
hS3.cabal view
@@ -1,13 +1,13 @@ Name: hS3-Version: 0.4+Version: 0.5 License: BSD3 License-file: LICENSE-Cabal-Version: >= 1.2+Cabal-Version: >= 1.6 Copyright: Copyright (c) 2008, Greg Heartsfield Author: Greg Heartsfield <scsibug@imap.cc> Maintainer: Greg Heartsfield <scsibug@imap.cc>-Homepage: http://gregheartsfield.com/repos/hS3/doc/+Homepage: http://gregheartsfield.com/hS3/ Category: Network, Web Stability: Alpha build-type: Simple@@ -25,6 +25,10 @@ examples/getObject.hs examples/listObjects.hs examples/uploadFile.hs++source-repository head+ type: darcs+ location: http://gregheartsfield.com/repos/hS3/ Library
hS3.hs view
@@ -36,14 +36,15 @@ ["go", bucket, gkey ] -> do c <- withConn $ \g -> getObject g $ S3Object bucket gkey "" [] L.empty L.putStr $ obj_data c+ ["do", bucket, key] ->+ do withConn $ \g -> deleteObject g $ S3Object bucket key "" [] L.empty ["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+ mapM_ (putStrLn . key) (snd l)+ ["lbs"] -> withConn listBuckets >>= mapM_ (putStrLn . bucket_name) _ -> usage usage :: IO ()