diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/AWS/AWSConnection.hs b/Network/AWS/AWSConnection.hs new file mode 100644 --- /dev/null +++ b/Network/AWS/AWSConnection.hs @@ -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 "") + diff --git a/Network/AWS/AWSResult.hs b/Network/AWS/AWSResult.hs new file mode 100644 --- /dev/null +++ b/Network/AWS/AWSResult.hs @@ -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 +-- +----------------------------------------------------------------------------- + +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 diff --git a/Network/AWS/ArrowUtils.hs b/Network/AWS/ArrowUtils.hs new file mode 100644 --- /dev/null +++ b/Network/AWS/ArrowUtils.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fno-monomorphism-restriction #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.AWS.ArrowUtils +-- Copyright : +-- License : +-- +-- Helper functions for working with HXT. Scraped from . +----------------------------------------------------------------------------- + +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 diff --git a/Network/AWS/Authentication.hs b/Network/AWS/Authentication.hs new file mode 100644 --- /dev/null +++ b/Network/AWS/Authentication.hs @@ -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 +-- +----------------------------------------------------------------------------- + +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: +-- +-- +-- +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) + + diff --git a/Network/AWS/S3Bucket.hs b/Network/AWS/S3Bucket.hs new file mode 100644 --- /dev/null +++ b/Network/AWS/S3Bucket.hs @@ -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 +-- +----------------------------------------------------------------------------- + +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. +-- +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 (/= '"') diff --git a/Network/AWS/S3Object.hs b/Network/AWS/S3Object.hs new file mode 100644 --- /dev/null +++ b/Network/AWS/S3Object.hs @@ -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 +-- +----------------------------------------------------------------------------- + +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) + + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 . + +REQUIREMENTS + +* Glasgow Haskell Compiler (GHC). Other compilers are untested. + +* Haskell HTTP Library , the latest + version (>3000.0) is required, use the darcs repository. + +* Haskell Cryptographic Library , the + latest version (>4.0.3) is required, use the darcs repository. + +* Haskell XML Toolbox (HXT) , + 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) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -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) diff --git a/hS3.cabal b/hS3.cabal new file mode 100644 --- /dev/null +++ b/hS3.cabal @@ -0,0 +1,27 @@ +Name: hS3 +Version: 0.1 +License: BSD3 +License-file: LICENSE +Copyright: + Copyright (c) 2007, Greg Heartsfield +Author: Greg Heartsfield +Maintainer: Greg Heartsfield +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 +