diff --git a/FEATURES b/FEATURES new file mode 100644 --- /dev/null +++ b/FEATURES @@ -0,0 +1,35 @@ +The Amazon S3 service has a large number of features. Those which are +supported by hS3 are listed below. + + * Creating buckets + * Creating bucket in a specified region (US/EU) + * Creating buckets with prefix and random suffix + * Deleting buckets + * Retrieving physical location of bucket + * Empty a bucket of all objects + * List buckets for an account + * List objects using prefix/marker/delimiter/maxkeys API + * List all objects, using multiple queries + * Sending objects + * Copying objects (preserving metadata) + * Deleting objects + * Retrieving object metadata + * Assigning custom 'amz-meta' headers to objects + * Forming pre-signed/expiring URLs for objects + * Expiring either on a given date, or number of seconds from current time + * Setting the storage class (Reduced Redundancy or Standard) for new objects + * Rewrite storage class of existing objects + + +Missing feature list (incomplete). We know the following features are not +yet supported. Some features may be available without changing the +hS3 library, if you understand the S3 API in sufficient detail. Patches to +add this functionality would be greatly appreciated! + + * ACLs (Access Control Lists) + * Object versioning + * Any bittorrent functionality + * Delete markers + * Enabling/disabling bucket logging + * Distributions + * Payment configurations diff --git a/Network/AWS/S3Bucket.hs b/Network/AWS/S3Bucket.hs --- a/Network/AWS/S3Bucket.hs +++ b/Network/AWS/S3Bucket.hs @@ -14,7 +14,7 @@ createBucketIn, createBucket, createBucketWithPrefixIn, createBucketWithPrefix, deleteBucket, getBucketLocation, emptyBucket, listBuckets, listObjects, listAllObjects, - isBucketNameValid, + isBucketNameValid, getObjectStorageClass, -- * Data Types S3Bucket(S3Bucket, bucket_name, bucket_creation_date), ListRequest(..), @@ -55,7 +55,7 @@ -- without of naming conflicts. createBucketWithPrefixIn :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name prefix - -> String -- ^ "US" or "EU" + -> String -- ^ Location ("US", "EU", "us-west-1", "ap-southeast-1") -> IO (AWSResult String) -- ^ Server response, if -- successful, the bucket -- name is returned. @@ -84,7 +84,7 @@ -- | Create a new bucket on S3 with the given name. createBucketIn :: AWSConnection -- ^ AWS connection information -> String -- ^ Proposed bucket name - -> String -- ^ "US" or "EU" + -> String -- ^ Location ("US", "EU", "us-west-1", "ap-southeast-1") -> IO (AWSResult ()) -- ^ Server response createBucketIn aws bucket location = let constraint = if location == "US" @@ -105,7 +105,7 @@ -- | Physical location of the bucket. "US" or "EU" getBucketLocation :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name - -> IO (AWSResult String) -- ^ Server response ("US" or "EU") + -> IO (AWSResult String) -- ^ Server response ("US", "EU", "us-west-1", "ap-southeast-1", etc.) getBucketLocation aws bucket = do res <- Auth.runAction (S3Action aws bucket "?location" "" [] L.empty GET) case res of @@ -199,7 +199,8 @@ key :: String, -- ^ Name of object last_modified :: String, -- ^ Last modification date etag :: String, -- ^ MD5 - size :: Integer -- ^ Bytes of object data + size :: Integer, -- ^ Bytes of object data + storageClass :: StorageClass -- ^ Storage class of the object } deriving (Show) -- | Is a result set response truncated? @@ -241,6 +242,16 @@ (\x -> return (Right (lr ++ x))) next_set (False,lr) -> return (Right lr) +-- | Retrieve the storage class of an object from S3. +-- For checking more than one object's storage class efficiently, +-- use listObjects. +getObjectStorageClass :: AWSConnection + -> S3Object + -> IO (AWSResult StorageClass) +getObjectStorageClass c obj = + do res <- listObjects c (obj_bucket obj) (ListRequest (obj_name obj) "" "" 1) + return (either Left (\(t,xs) -> Right (head (map storageClass xs))) res) + -- | 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. @@ -267,8 +278,9 @@ ((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)) + (text <<< atTag "Size") &&& + (text <<< atTag "StorageClass")) >>> + arr (\(a,(b,(c,(d,e)))) -> ListResult a b ((unquote . HTTP.urlDecode) c) (read d) (read e)) -- | Check Amazon guidelines on bucket naming. (missing test for IP-like names) isBucketNameValid :: String -> Bool diff --git a/Network/AWS/S3Object.hs b/Network/AWS/S3Object.hs --- a/Network/AWS/S3Object.hs +++ b/Network/AWS/S3Object.hs @@ -11,10 +11,12 @@ module Network.AWS.S3Object ( -- * Function Types - sendObject, copyObject, getObject, getObjectInfo, deleteObject, - publicUriForSeconds, publicUriUntilTime, + sendObject, copyObject, copyObjectWithReplace, getObject, + getObjectInfo, deleteObject, publicUriForSeconds, + publicUriUntilTime, setStorageClass, getStorageClass, + rewriteStorageClass, -- * Data Types - S3Object(..) + S3Object(..), StorageClass(..) ) where import Network.AWS.Authentication as Auth @@ -23,6 +25,7 @@ import Network.HTTP import Network.URI import System.Time +import Data.List.Utils import qualified Data.ByteString.Lazy.Char8 as L @@ -46,6 +49,51 @@ obj_data :: L.ByteString } deriving (Read, Show) +data StorageClass = STANDARD | REDUCED_REDUNDANCY + deriving (Read, Show, Eq) + +-- Amazon header key for storage class +storageHeader = "x-amz-storage-class" + +-- | Add required headers for the storage class. +-- Use this in combination with 'sendObject' for new objects. To +-- modify the storage class of existing objects, use +-- 'rewriteStorageClass'. Using reduced redundancy for object storage +-- trades off redundancy for storage costs. +setStorageClass :: StorageClass -- ^ Storage class to request + -> S3Object -- ^ Object to modify + -> S3Object -- ^ Object with storage class headers set, ready to be sent +setStorageClass sc obj = obj {obj_headers = addToAL + (obj_headers obj) + storageHeader (show sc)} + +-- | Retrieve the storage class of a local S3Object. +-- Does not work for objects retrieved with 'getObject', since the +-- required header values are not returned. Use +-- 'getObjectStorageClass' or 'listObjects' from S3Bucket module to +-- determine storage class of existing objects. +getStorageClass :: S3Object -- ^ Object to inspect + -> Maybe StorageClass -- ^ Requested storage class, Nothing if unspecified +getStorageClass obj = case stg_values of + [] -> Nothing + x -> Just (read (head x)) + where + hdrs = obj_headers obj + stg_hdrs = filter (\x -> fst x == storageHeader) hdrs + stg_values = map fst stg_hdrs + +-- | Change the storage class (and only the storage class) of an existing object. +-- This actually performs a copy to the same location, preserving metadata. +-- It is not clear to me whether ACLs are preserved when copying to the same location. +-- For best performance, we must not change other headers during storage class +-- changes. +rewriteStorageClass :: AWSConnection -- ^ AWS connection information + -> StorageClass -- ^ New storage class for object + -> S3Object -- ^ Object to modify + -> IO (AWSResult S3Object) -- ^ Server response +rewriteStorageClass aws sc obj = + copyObject aws obj (setStorageClass sc (obj {obj_headers = []})) + -- | Send data for an object. sendObject :: AWSConnection -- ^ AWS connection information -> S3Object -- ^ Object to add to a bucket @@ -130,11 +178,21 @@ L.empty DELETE) return (either Left (\_ -> Right ()) res) --- | Copy object from one bucket to another (or the same bucket). +-- | Copy object from one bucket to another (or the same bucket), preserving the original headers. +-- Headers from @destobj@ are sent, while only the +-- bucket and name of @srcobj@ are used. For the best +-- performance, when changing headers during a copy, use the +-- 'copyObjectWithReplace' function. For conditional copying, the +-- following headers set on the destination object may be used: +-- @x-amz-copy-source-if-match@, @x-amz-copy-source-if-none-match@, +-- @x-amz-copy-source-if-unmodified-since@, or +-- @x-amz-copy-source-if-modified-since@. See +-- +-- for more details. copyObject :: AWSConnection -- ^ AWS connection information - -> S3Object -- ^ Source object + -> S3Object -- ^ Source object (bucket+name only) -> S3Object -- ^ Destination object - -> IO (AWSResult S3Object) -- ^ Server response + -> IO (AWSResult S3Object) -- ^ Server response, headers include version information copyObject aws srcobj destobj = do res <- Auth.runAction (S3Action aws (urlEncode (obj_bucket destobj)) (urlEncode (obj_name destobj)) @@ -149,4 +207,18 @@ copy_headers = [("x-amz-copy-source", ("/"++ (urlEncode (obj_bucket srcobj)) ++ "/" ++ (urlEncode (obj_name srcobj))))] + ++ (obj_headers destobj) +-- | Copy object from one bucket to another (or the same bucket), replacing headers. +-- Any headers from @srcobj@ are ignored, and only those +-- set in @destobj@ are used. +copyObjectWithReplace :: AWSConnection -- ^ AWS connection information + -> S3Object -- ^ Source object (bucket+name only) + -> S3Object -- ^ Destination object + -> IO (AWSResult S3Object) -- ^ Server response, headers include version information +copyObjectWithReplace aws srcobj destobj = + copyObject aws srcobj (destobj {obj_headers = + (addToAL (obj_headers destobj) + "x-amz-metadata-directive" + "REPLACE") + }) diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -20,7 +20,8 @@ import qualified Data.ByteString.Lazy.Char8 as L import Control.Exception(finally) import IO(bracket) - +import Control.Concurrent(threadDelay) +import Data.List.Utils(hasKeyAL) import Test.HUnit -- | Run the tests @@ -31,8 +32,11 @@ [ TestLabel "S3 Operations Test" s3OperationsTest, TestLabel "S3 Copy Test" s3CopyTest, + TestLabel "S3 Copy/Replace Test" s3CopyReplaceTest, TestLabel "S3 Location Test" s3LocationTest, - TestLabel "Bucket Naming Test" bucketNamingTest + TestLabel "Bucket Naming Test" bucketNamingTest, + TestLabel "Reduced Redundancy Creation Test" reducedRedundancyCreateTest, + TestLabel "Reduced Redundancy Existing Test" reducedRedundancyExistingTest ] testBucket = "hs3-test" @@ -73,6 +77,7 @@ -- Delete bucket testDeleteBucket c bucket -- Bucket should be gone + threadDelay 3000000 -- sleep 3 sec, since bucket isn't always unavailable immediately testBucketGone c bucket ) @@ -123,15 +128,60 @@ -- Bucket Creation b <- testCreateBucket c d <- testCreateBucket c + let srcHeader = "x-amz-meta-src" + let srcValue = "foo" finally ( - do let srcObj = testSourceTemplate {obj_bucket = d} + do let srcObj = testSourceTemplate {obj_bucket = d, obj_headers = [(srcHeader,srcValue)]} let destObj = testDestinationTemplate {obj_bucket = b} -- Object send testSendObject c srcObj + -- Verify headers were set on original object + sr <- getObject c srcObj + failOnError sr () + (\x -> assertBool "Original sent object has custom headers" + (hasKeyAL srcHeader (obj_headers x)) + ) -- Object copy testCopyObject c srcObj destObj + -- Verify destination object contains same added header as source object + testGetObjectInfo c (destObj {obj_headers = [(srcHeader,srcValue)]}) + ) ( + -- Empty buckets + do testEmptyBucket c b + testEmptyBucket c d + -- Destroy buckets + testDeleteBucket c b + testDeleteBucket c d + ) + ) + +s3CopyReplaceTest = + TestCase ( + do c <- getConn + -- Bucket Creation + b <- testCreateBucket c + d <- testCreateBucket c + let srcHeader = "x-amz-meta-src" + let srcValue = "foo" + finally ( + do let srcObj = testSourceTemplate {obj_bucket = d, obj_headers = [(srcHeader,srcValue)]} + let destObj = testDestinationTemplate {obj_bucket = b} + -- Object send + testSendObject c srcObj + sr <- getObject c srcObj + failOnError sr () + (\x -> assertBool "Original sent object has custom headers" + (hasKeyAL srcHeader (obj_headers x)) + ) + -- Object copy + testCopyObjectWithReplace c srcObj destObj -- Object get info from copied object testGetObjectInfo c destObj + dr <- getObject c destObj + failOnError dr () + (\x -> assertBool "Copied object w/ replace does not have source headers" + (not (hasKeyAL srcHeader (obj_headers x))) + ) ) ( -- Empty buckets do testEmptyBucket c b @@ -192,6 +242,12 @@ failOnError r () (const $ assertBool "object copied" True) +testCopyObjectWithReplace :: AWSConnection -> S3Object -> S3Object -> IO () +testCopyObjectWithReplace c srco desto = + do r <- copyObjectWithReplace c srco desto + failOnError r () + (const $ assertBool "object copied" True) + testGetObject :: AWSConnection -> S3Object -> IO () testGetObject c o = do r <- getObject c o @@ -203,6 +259,7 @@ (realMetadata (obj_headers x)) ) +-- Test to ensure an object on S3 matches the headers passed to this function. testGetObjectInfo :: AWSConnection -> S3Object -> IO () testGetObjectInfo c o = do r <- getObject c o @@ -246,6 +303,40 @@ (\x -> do assertFailure "Bucket still there, should be gone (sometimes slow, not fatal)" return ()) +reducedRedundancyCreateTest = + TestCase ( + do c <- getConn + b <- testCreateBucket c + let rr = "reduced-redundancy" + let testObj = testObjectTemplate {obj_bucket = b, obj_name = rr} + let rrTestObj = setStorageClass REDUCED_REDUNDANCY testObj + testSendObject c rrTestObj + r <- getObjectStorageClass c testObj + failOnError r () + (\sc -> assertEqual "storage class is reduced-redundancy" + REDUCED_REDUNDANCY sc) + ) + +reducedRedundancyExistingTest = + TestCase ( + do c <- getConn + b <- testCreateBucket c + let rr = "reduced-redundancy" + let testObj = testObjectTemplate {obj_bucket = b, obj_name = rr} + testSendObject c testObj + rewriteStorageClass c REDUCED_REDUNDANCY testObj + r <- getObjectStorageClass c testObj + failOnError r () + (\sc -> assertEqual "storage class is reduced-redundancy" + REDUCED_REDUNDANCY sc) + -- Set storage class back to STANDARD + rewriteStorageClass c STANDARD testObj + s <- getObjectStorageClass c testObj + failOnError s () + (\sc -> assertEqual "storage class switched back to standard" + STANDARD sc) + ) + getConn = do mConn <- amazonS3ConnectionFromEnv return (fromJust mConn) @@ -255,4 +346,3 @@ realMetadata :: [(String, b)] -> [(String, b)] realMetadata = filter (\x -> fst x `notElem` headersToIgnore) - diff --git a/hS3.cabal b/hS3.cabal --- a/hS3.cabal +++ b/hS3.cabal @@ -1,5 +1,5 @@ Name: hS3 -Version: 0.5.2 +Version: 0.5.3 License: BSD3 License-file: LICENSE Cabal-Version: >= 1.6 @@ -16,7 +16,8 @@ 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, CONTRIBUTORS, Tests.hs, +extra-source-files: README, CONTRIBUTORS, FEATURES, + Tests.hs, examples/createBucket.hs examples/deleteObject.hs examples/listBuckets.hs @@ -33,7 +34,8 @@ Library Build-depends: base >= 3 && < 5, HTTP >= 4000.0.0, Crypto >= 4.1.0, hxt, network, - regex-compat, old-time, random, old-locale, dataenc, utf8-string, bytestring + regex-compat, old-time, random, old-locale, dataenc, utf8-string, bytestring, + MissingH >= 0.18.6 Exposed-modules: Network.AWS.S3Object, diff --git a/hS3.hs b/hS3.hs --- a/hS3.hs +++ b/hS3.hs @@ -29,9 +29,10 @@ main = do args <- getArgs case args of - -- create / delete bucket + -- create / empty / delete bucket ["cb", name, location] -> withConn $ \g -> createBucketIn g name location ["db", name ] -> withConn $ \g -> deleteBucket g name + ["eb", name ] -> withConn $ \g -> emptyBucket g name -- objects ["go", bucket, gkey ] -> do c <- withConn $ \g -> getObject g $ S3Object bucket gkey "" [] L.empty @@ -53,6 +54,7 @@ , "" , "cb [EU, US] : create bucket" , "db : delete bucket" + , "eb : empty bucket" , "do : delete object" , "" , "lbs : list buckets"