hS3 (empty) → 0.1
raw patch · 11 files changed
+844/−0 lines, 11 filesdep +Cryptodep +HTTPdep +basebuild-type:Customsetup-changed
Dependencies added: Crypto, HTTP, base, hxt, network, regex-compat
Files
- LICENSE +31/−0
- Network/AWS/AWSConnection.hs +56/−0
- Network/AWS/AWSResult.hs +31/−0
- Network/AWS/ArrowUtils.hs +30/−0
- Network/AWS/Authentication.hs +256/−0
- Network/AWS/S3Bucket.hs +183/−0
- Network/AWS/S3Object.hs +82/−0
- README +41/−0
- Setup.hs +8/−0
- Tests.hs +99/−0
- hS3.cabal +27/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2007, Greg Heartsfield++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/AWS/AWSConnection.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.AWSConnection+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Connection and authentication info for an Amazon AWS request.+-----------------------------------------------------------------------------+module Network.AWS.AWSConnection (+ -- * Constants+ defaultAmazonS3Host, defaultAmazonS3Port,+ -- * Function Types+ amazonS3Connection, amazonS3ConnectionFromEnv,+ -- * Data Types+ AWSConnection(..)+ ) where++import System.Environment++-- | An Amazon Web Services connection. Everything needed to connect+-- and authenticate requests.+data AWSConnection =+ AWSConnection { awsHost :: String, -- ^ Service provider hostname+ awsPort :: Int, -- ^ Service provider port number+ awsAccessKey :: String, -- ^ Access Key ID+ awsSecretKey :: String -- ^ Secret Access Key+ } deriving (Show)++-- | Hostname used for connecting to Amazon's production S3 service (@s3.amazonaws.com@).+defaultAmazonS3Host :: String+defaultAmazonS3Host = "s3.amazonaws.com"++-- | Port number used for connecting to Amazon's production S3 service (@80@).+defaultAmazonS3Port :: Int+defaultAmazonS3Port = 80++-- | Create an AWSConnection to Amazon from credentials. Uses the+-- production service.+amazonS3Connection :: String -- ^ Access Key ID+ -> String -- ^ Secret Access Key+ -> AWSConnection -- ^ Connection to Amazon S3+amazonS3Connection = AWSConnection defaultAmazonS3Host defaultAmazonS3Port++-- | Retrieve Access and Secret keys from environment variables+-- AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET, 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)+ where getEnvKey s = do catch (getEnv s) (const $ return "")+
+ Network/AWS/AWSResult.hs view
@@ -0,0 +1,31 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.AWSResult+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Results from a query to Amazon Web Services.+-- API Version 2006-03-01+-- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/>+-----------------------------------------------------------------------------++module Network.AWS.AWSResult (+ -- * Data Types+ AWSResult,+ ReqError(..),+ prettyReqError+ ) where++import Network.Stream as Stream++type AWSResult a = Either ReqError {- some kind of failure to process the request -}+ a {- result -}+data ReqError =+ NetworkError Stream.ConnError |+ AWSError String String -- AWS error code and message+ deriving (Show, Eq)++prettyReqError :: ReqError -> String+prettyReqError r = case r of+ AWSError a b -> b+ NetworkError c -> show c
+ Network/AWS/ArrowUtils.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-monomorphism-restriction #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.ArrowUtils+-- Copyright :+-- License :+--+-- Helper functions for working with HXT. Scraped from <haskell.org>.+-----------------------------------------------------------------------------++module Network.AWS.ArrowUtils (+ split, unsplit, atTag, text+)++where++import Control.Arrow+import Text.XML.HXT.Arrow++-- misc. functions for working with arrows (and HXT)++split :: (Arrow a) => a b (b, b)+split = arr (\x -> (x,x))++unsplit :: (Arrow a) => (b -> c -> d) -> a (b, c) d+unsplit = arr . uncurry++atTag tag = deep (isElem >>> hasName tag)++text = getChildren >>> getText
+ Network/AWS/Authentication.hs view
@@ -0,0 +1,256 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.Authentication+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Implements authentication and low-level communication with Amazon+-- Web Services, such as S3, EC2, and others.+-- API Version 2006-03-01+-- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/>+-----------------------------------------------------------------------------++module Network.AWS.Authentication (+ -- * Function Types+ runAction,+ -- * Data Types+ S3Action(..)+ ) where++import Network.AWS.AWSResult+import Network.AWS.AWSConnection+import Network.AWS.ArrowUtils+import Network.HTTP as HTTP+import Network.URI as URI++import Data.HMAC+import Codec.Binary.Base64 (encode, decode)+import Codec.Utils (Octet)++import Data.Char (ord, toLower)+import Data.List (sortBy, groupBy, intersperse)+import Data.Maybe++import System.Time+import System.Locale++import Text.Regex++import Control.Arrow+import Text.XML.HXT.Arrow++-- | An action to be performed using S3.+data S3Action =+ S3Action { s3conn :: AWSConnection, -- ^ Connection and authentication+ -- information+ s3bucket :: String, -- ^ Name of bucket to act on+ s3object :: String, -- ^ Name of object to act on+ s3query :: String, -- ^ Query parameters, requires a prefix of @?@+ s3metadata :: [(String, String)], -- ^ Additional header fields to send+ s3body :: String, -- ^ Body of action, if sending data+ s3operation :: RequestMethod -- ^ Type of action, 'PUT', 'GET', etc.+ } deriving (Show)++-- | Transform an 'S3Action' into an HTTP request. Does not add+-- 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.+requestFromAction a =+ Request { rqURI = URI { uriScheme = "",+ uriAuthority = Nothing,+ uriPath = canonicalizeResource a,+ uriQuery = s3query a,+ uriFragment = "" },+ rqMethod = s3operation a,+ rqHeaders = [Header HdrHost (awsHost (s3conn a))] +++ (headersFromAction a),+ rqBody = s3body a+ }+ where path = (s3bucket a) ++ "/" ++ (s3object a)++-- | Create 'Header' objects from an action.+headersFromAction :: S3Action+ -> [Header]+headersFromAction a = map (\(k,v) -> (Header (HdrCustom k)) v)+ (s3metadata a)++-- | 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++-- | Add AWS authentication header to an HTTP request.+addAuthenticationHeader :: S3Action -- ^ Action with authentication data+ -> HTTP.Request -- ^ Request to transform+ -> HTTP.Request -- ^ Authenticated request+addAuthenticationHeader act req = insertHeader HdrAuthorization auth_string req+ where auth_string = "AWS " ++ (awsAccessKey conn) ++ ":" ++ signature+ signature = encode (hmac_sha1 keyOctets msgOctets)+ keyOctets = string2words (awsSecretKey conn)+ msgOctets = string2words (stringToSign act req)+ conn = s3conn act++-- | Generate text that will be signed and subsequently added to the+-- request.+stringToSign :: S3Action -> HTTP.Request -> String+stringToSign a r =+ (canonicalizeHeaders r) +++ (canonicalizeAmzHeaders r) +++ (canonicalizeResource a)++-- | Extract header data needed for signing.+canonicalizeHeaders :: HTTP.Request -> String+canonicalizeHeaders r =+ http_verb ++ "\n" +++ hdr_content_md5 ++ "\n" +++ hdr_content_type ++ "\n" +++ hdr_date ++ "\n"+ where http_verb = show (rqMethod r)+ 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)++-- | Extract @x-amz-*@ headers needed for signing.+-- find all headers with type HdrCustom that begin with amzHeader+-- lowercase key names+-- sort lexigraphically by key name+-- combine headers with same name+-- unfold multi-line headers+-- trim whitespace around the header+canonicalizeAmzHeaders :: HTTP.Request -> String+canonicalizeAmzHeaders r =+ let amzHeaders = filter isAmzHeader (rqHeaders r)+ amzHeaderKV = map headerToLCKeyValue amzHeaders+ sortedGroupedHeaders = groupHeaders (sortHeaders amzHeaderKV)+ uniqueHeaders = combineHeaders sortedGroupedHeaders+ in concat (map (\a -> a ++ "\n") (map showHeader uniqueHeaders))++-- | 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)++-- | 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 ""++-- | Combine same-named headers.+combineHeaders :: [[(String, String)]] -> [(String, String)]+combineHeaders h = map mergeSameHeaders h++-- | Headers with same name should have values merged.+mergeSameHeaders :: [(String, String)] -> (String, String)+mergeSameHeaders h@(x:xs) = let values = map snd h+ in ((fst x), (concat $ intersperse "," values))++-- | Group headers with the same name.+groupHeaders :: [(String, String)] -> [[(String, String)]]+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))++-- | Make 'Header' easier to work with, and lowercase keys.+headerToLCKeyValue :: Header -> (String, String)+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+ otherwise -> False++-- | is the first list a prefix of the second?+isPrefix :: Eq a => [a] -> [a] -> Bool+isPrefix a b = a == take (length a) b++-- | Prefix used by Amazon metadata headers+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)+ bucket = case (s3bucket a) of+ b@(x:xs) -> "/" ++ b+ otherwise -> case uri of+ [] -> "/" -- at the least we have a "/"+ otherwise -> ""++-- | Add a date string to a request.+addDateToReq :: HTTP.Request -- ^ Request to modify+ -> String -- ^ Date string, in RFC 2616 format+ -> HTTP.Request -- ^ Request with date header added+addDateToReq r d = r {HTTP.rqHeaders =+ (HTTP.Header HTTP.HdrDate d) : (HTTP.rqHeaders r)}++-- | 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,+-- we could send @+0000@ instead of @GMT@.+-- see:+-- <http://www.ietf.org/rfc/rfc2616.txt>+-- <http://www.ietf.org/rfc/rfc1123.txt>+-- <http://www.ietf.org/rfc/rfc822.txt>+httpCurrentDate :: IO String+httpCurrentDate =+ do c <- getClockTime+ let utc_time = (toUTCTime c) {ctTZName = "GMT"}+ return $ formatCalendarTime defaultTimeLocale rfc822DateFormat utc_time++-- | Convenience for dealing with HMAC-SHA1+string2words :: String -> [Octet]+string2words = map (fromIntegral . ord)+++-- | 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++-- | 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)++-- | Find the errors embedded in an XML message body from Amazon.+parseRestErrorXML :: String -> IO ReqError+parseRestErrorXML x =+ do e <- runX (readString [(a_validate,v_0)] x+ >>> processRestError)+ case e of+ [] -> return (AWSError "NoErrorInMsg"+ ("HTTP Error condition, but message body"+ ++ "did not contain error code."))+ x:xs -> return x+++-- | Find children of @Error@ entity, use their @Code@ and @Message@+-- entities to create an 'AWSError'.+processRestError = deep (isElem >>> hasName "Error") >>>+ split >>> first (text <<< atTag "Code") >>>+ second (text <<< atTag "Message") >>>+ unsplit (\x y -> AWSError x y)++
+ Network/AWS/S3Bucket.hs view
@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.S3Bucket+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Bucket interface for Amazon S3+-- API Version 2006-03-01+-- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/>+-----------------------------------------------------------------------------++module Network.AWS.S3Bucket (+ -- * Function Types+ createBucket, createBucketWithPrefix, deleteBucket, listBuckets, listObjects,+ -- * Data Types+ Bucket(Bucket, bucket_name, bucket_creation_date),+ ListRequest(..),+ ListResult(..)+ ) where++import Network.AWS.Authentication as Auth+import Network.AWS.AWSResult+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 Bucket = Bucket { bucket_name :: String,+ bucket_creation_date :: String+ } deriving (Show, Eq)++-- | 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+ -> String -- ^ Bucket name prefix+ -> IO (AWSResult String) -- ^ Server response, if+ -- successful, the bucket+ -- name is returned.++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+ return $ take 10 $ show $ hexdumpBy "" 999 (hash (toOctets 10 (abs rdata)))++-- | 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)++-- | 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)++-- | 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 [Bucket]) -- ^ Server response+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 [Bucket]+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 -> Bucket x y)++-- | List request parameters+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))++-- | Result from listing objects.+data ListResult =+ ListResult {+ key :: String, -- ^ Name of object+ last_modified :: String, -- ^ Last modification date+ etag :: String, -- ^ MD5+ size :: Integer -- ^ Bytes of object data+ } deriving (Show)++-- | List objects in a bucket, based on parameters from 'ListRequest'. See+-- the Amazon S3 developer resources for in depth explanation of how+-- the fields in 'ListRequest' can be used to query for objects.+-- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/ListingKeysRequest.html>+listObjects :: AWSConnection -- ^ AWS connection information+ -> String -- ^ Bucket name to search+ -> ListRequest -- ^ List parameters+ -> IO (AWSResult [ListResult]) -- ^ Server response+listObjects aws bucket lp =+ do res <- Auth.runAction (S3Action aws bucket ""+ ("?" ++ (show lp)) [] "" GET)+ case res of+ Left x -> do return (Left x)+ Right y -> do let objs = rspBody y+ tr <- isListTruncated objs+ lr <- getListResults objs+ case tr of+ True -> do let last_result = (key . head . reverse) lr+ next_set <- listObjects aws bucket+ (lp {marker = last_result,+ max_keys = (max_keys lp) - (length lr)})+ either (\x -> return (Left x))+ (\x -> return (Right (lr ++ x))) next_set+ False -> do return (Right lr)++-- | Determine if ListBucketResult is truncated. It would make sense+-- to combine this with the query for list results, so we didn't+-- have to parse the XML twice.+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)++-- | Learning arrows on the job.+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))++-- | Remove quote characters from a 'String'.+unquote :: String -> String+unquote = filter (/= '"')
+ Network/AWS/S3Object.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.S3Object+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Object interface for Amazon S3+-- API Version 2006-03-01+-- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/>+-----------------------------------------------------------------------------++module Network.AWS.S3Object (+ -- * Function Types+ sendObject, getObject, deleteObject,+ -- * Data Types+ S3Object(..)+ ) where++import Network.AWS.Authentication as Auth+import Network.AWS.AWSResult+import Network.AWS.AWSConnection+import Network.HTTP++-- | An object that can be stored and retrieved from S3.+data S3Object =+ S3Object { -- | Name of the bucket containing this object+ obj_bucket :: String,+ -- | URI of the object. Subresources ("?acl" or+ -- | "?torrent") should be suffixed onto this name.+ obj_name :: String,+ -- | A standard MIME type describing the format of the+ -- contents. If not specified, @binary/octet-stream@ is+ -- used.+ content_type :: String,+ -- | Object metadata in (key,value) pairs. Key names+ -- should use the prefix @x-amz-meta-@ to be stored with+ -- the object. The total HTTP request must be under 4KB,+ -- including these headers.+ obj_headers :: [(String, String)],+ -- | Object data.+ obj_data :: String+ } deriving (Show)++-- | Send data for an object.+sendObject :: AWSConnection -- ^ AWS connection information+ -> S3Object -- ^ Object to add to a bucket+ -> IO (AWSResult ()) -- ^ Server response+sendObject aws obj = do res <- Auth.runAction (S3Action aws (obj_bucket obj)+ (obj_name obj)+ ""+ (obj_headers obj)+ (obj_data obj) PUT)+ return (either (Left) (\x -> Right ()) res)++-- | Retrieve an object.+getObject :: AWSConnection -- ^ AWS connection information+ -> S3Object -- ^ Object to retrieve+ -> IO (AWSResult S3Object) -- ^ Server response+getObject aws obj =+ do res <- Auth.runAction (S3Action aws (obj_bucket obj)+ (obj_name obj)+ ""+ (obj_headers obj)+ "" GET)+ return (either (Left) (\x -> Right (populate_obj_from x)) res)+ where+ populate_obj_from x = obj {obj_data = (rspBody x)}++-- | Delete an object. Only bucket and object name need to be+-- specified in the S3Object. Deletion of a non-existent object+-- does not return an error.+deleteObject :: AWSConnection -- ^ AWS connection information+ -> S3Object -- ^ Object to delete+ -> IO (AWSResult ()) -- ^ Server response+deleteObject aws obj = do res <- Auth.runAction (S3Action aws (obj_bucket obj)+ (obj_name obj)+ ""+ (obj_headers obj)+ "" DELETE)+ return (either (Left) (\x -> Right ()) res)++
+ README view
@@ -0,0 +1,41 @@+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/>, the latest+ version (>3000.0) is required, use the darcs repository.++* Haskell Cryptographic Library <http://www.haskell.org/crypto/>, the+ latest version (>4.0.3) is required, use the darcs repository.++* 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)+
+ Setup.hs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ Tests.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------+-- |+-- Module : AWS S3 Tests+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Test hS3 library against Amazon S3. This requires the following+-- environment variables to be set with your Amazon keys:+-- AWS_ACCESS_KEY_ID+-- AWS_ACCESS_KEY_SECRET+-----------------------------------------------------------------------------++module Main(main) where++import Network.AWS.AWSConnection+import Network.AWS.AWSResult+import Network.AWS.S3Object+import Network.AWS.S3Bucket+import Data.Maybe (fromJust)++import Test.HUnit++-- | Run the tests+main = runTestTT tests++tests =+ TestList [s3operationsTest]++testBucket = "hS3-test"++testObjectTemplate = S3Object testBucket "hS3-object-test" "text/plain"+ [("x-amz-foo", "bar")] "Hello S3!"++-- | A sequence of several operations.+s3operationsTest =+ TestCase (+ do c <- getConn+ -- Bucket Creation+ bucket <- testCreateBucket c+ let testObj = testObjectTemplate {obj_bucket = bucket}+ -- Object send+ testSendObject c testObj+ -- Object get+ testGetObject c testObj+ -- Object list+ testListObject c bucket 1+ -- Object delete+ testDeleteObject c testObj+ -- Delete bucket+ testDeleteBucket c bucket+ )++testCreateBucket :: AWSConnection -> IO String+testCreateBucket c =+ do r <- createBucketWithPrefix c testBucket+ either (\x -> do assertFailure (show x)+ return ""+ )+ (\x -> do assertBool "bucket creation" True+ return x+ ) r++testSendObject :: AWSConnection -> S3Object -> IO ()+testSendObject c o =+ do r <- sendObject c o+ either (\x -> assertFailure (show x))+ (const $ assertBool "object send" True) r++testGetObject :: AWSConnection -> S3Object -> IO ()+testGetObject c o =+ do r <- getObject c o+ either (\x -> assertFailure (show x))+ (\x -> do assertEqual "object get body"+ (obj_data x) (obj_data o)+ assertEqual "object get metadata"+ (obj_headers x) (obj_headers o)+ ) r++-- test that a bucket has a given number of objects+testListObject :: AWSConnection -> String -> Int -> IO ()+testListObject c bucket count =+ do r <- listObjects c bucket (ListRequest "" "" "" 100)+ either (\x -> assertFailure (show x))+ (\x -> assertEqual "object list" count (length x)) r++testDeleteObject :: AWSConnection -> S3Object -> IO ()+testDeleteObject c o =+ do r <- deleteObject c o+ either (\x -> assertFailure (show x))+ (const $ assertBool "object delete" True) r++testDeleteBucket :: AWSConnection -> String -> IO ()+testDeleteBucket c bucket =+ do r <- deleteBucket c bucket+ either (\x -> assertFailure (show x))+ (const $ assertBool "bucket deletion" True) r++getConn = do mConn <- amazonS3ConnectionFromEnv+ return (fromJust mConn)
+ hS3.cabal view
@@ -0,0 +1,27 @@+Name: hS3+Version: 0.1+License: BSD3+License-file: LICENSE+Copyright: + Copyright (c) 2007, Greg Heartsfield+Author: Greg Heartsfield <scsibug@imap.cc>+Maintainer: Greg Heartsfield <scsibug@imap.cc>+Homepage: http://scsibug.com/hS3+Category: Network, Web+Stability: Alpha+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+ developers to reliably store and retrieve arbitrary amounts of+ data from anywhere on the Internet.+extra-source-files: README, Tests.hs+Build-depends: base, HTTP >= 3000.0.0, Crypto >= 4.0.3, hxt, network, regex-compat+GHC-options: -O+Exposed-modules:+ Network.AWS.S3Object,+ Network.AWS.S3Bucket,+ Network.AWS.AWSResult,+ Network.AWS.AWSConnection,+ Network.AWS.Authentication,+ Network.AWS.ArrowUtils+