diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,3 @@ +- +- Marc Weber +- Anton van Straaten diff --git a/Network/AWS/Authentication.hs b/Network/AWS/Authentication.hs --- a/Network/AWS/Authentication.hs +++ b/Network/AWS/Authentication.hs @@ -54,9 +54,9 @@ S3Action { -- | Connection and authentication information s3conn :: AWSConnection, - -- | Name of bucket to act on + -- | Name of bucket to act on (URL encoded) s3bucket :: String, - -- | Name of object to act on + -- | Name of object to act on (URL encoded) s3object :: String, -- | Query parameters (requires a prefix of @?@) s3query :: String, @@ -267,7 +267,13 @@ let aReq = addAuthenticationHeader a $ addContentLengthHeader $ addDateToReq (requestFromAction a) cd + --print aReq -- Show request header result <- simpleHTTP_ c aReq + -- Show result header and body + -- print result + --case result of + -- Left a -> print "" + -- Right a -> print (rspBody a) close c createAWSResult a result diff --git a/Network/AWS/S3Bucket.hs b/Network/AWS/S3Bucket.hs --- a/Network/AWS/S3Bucket.hs +++ b/Network/AWS/S3Bucket.hs @@ -14,6 +14,7 @@ createBucketIn, createBucket, createBucketWithPrefixIn, createBucketWithPrefix, deleteBucket, getBucketLocation, emptyBucket, listBuckets, listObjects, listAllObjects, + isBucketNameValid, -- * Data Types S3Bucket(S3Bucket, bucket_name, bucket_creation_date), ListRequest(..), @@ -32,7 +33,8 @@ import qualified Data.ByteString.Lazy.Char8 as L -import Data.Char (toLower) +import Data.Char (toLower, isAlphaNum) +import Data.List (isInfixOf) import Text.XML.HXT.Arrow import qualified Data.Tree.NTree.TypeDefs @@ -267,6 +269,17 @@ (text <<< atTag "ETag") &&& (text <<< atTag "Size")) >>> arr (\(a,(b,(c,d))) -> ListResult a b ((unquote . HTTP.urlDecode) c) (read d)) + +-- | Check Amazon guidelines on bucket naming. (missing test for IP-like names) +isBucketNameValid :: String -> Bool +isBucketNameValid n = and checks where + checks = [(length n >= 3), + (length n <= 63), + (isAlphaNum $ head n), + (not (elem '_' n)), + (not (isInfixOf ".-" n)), + (not (isInfixOf "-." n)), + ((last n) /= '-')] -- | Remove quote characters from a 'String'. unquote :: String -> String diff --git a/Network/AWS/S3Object.hs b/Network/AWS/S3Object.hs --- a/Network/AWS/S3Object.hs +++ b/Network/AWS/S3Object.hs @@ -11,7 +11,7 @@ module Network.AWS.S3Object ( -- * Function Types - sendObject, getObject, getObjectInfo, deleteObject, + sendObject, copyObject, getObject, getObjectInfo, deleteObject, publicUriForSeconds, publicUriUntilTime, -- * Data Types S3Object(..) @@ -51,8 +51,8 @@ -> 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) + do res <- Auth.runAction (S3Action aws (urlEncode (obj_bucket obj)) + (urlEncode (obj_name obj)) "" (("Content-Type", (content_type obj)) : obj_headers obj) @@ -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 (urlEncode (obj_bucket obj)) (urlEncode (obj_name obj)) "" [] L.empty GET in preSignedURI act time -- | Create a pre-signed request URI. Anyone can use this to request @@ -99,8 +99,8 @@ -> S3Object -- ^ Object to request -> IO (AWSResult S3Object) getObjectWithMethod m aws obj = - do res <- Auth.runAction (S3Action aws (obj_bucket obj) - (obj_name obj) + do res <- Auth.runAction (S3Action aws (urlEncode (obj_bucket obj)) + (urlEncode (obj_name obj)) "" (obj_headers obj) L.empty m) @@ -123,11 +123,30 @@ 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) +deleteObject aws obj = do res <- Auth.runAction (S3Action aws (urlEncode (obj_bucket obj)) + (urlEncode (obj_name obj)) "" (obj_headers obj) L.empty DELETE) return (either Left (\_ -> Right ()) res) +-- | Copy object from one bucket to another (or the same bucket). +copyObject :: AWSConnection -- ^ AWS connection information + -> S3Object -- ^ Source object + -> S3Object -- ^ Destination object + -> IO (AWSResult S3Object) -- ^ Server response +copyObject aws srcobj destobj = + do res <- Auth.runAction (S3Action aws (urlEncode (obj_bucket destobj)) + (urlEncode (obj_name destobj)) + "" + (copy_headers) + L.empty PUT) + return (either Left (\x -> Right (populate_obj_from x)) res) + where + populate_obj_from x = + destobj { obj_data = (rspBody x), + obj_headers = (headersFromResponse x) } + copy_headers = [("x-amz-copy-source", + ("/"++ (urlEncode (obj_bucket srcobj)) + ++ "/" ++ (urlEncode (obj_name srcobj))))] diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -18,6 +18,8 @@ import Network.AWS.S3Bucket import Data.Maybe (fromJust) import qualified Data.ByteString.Lazy.Char8 as L +import Control.Exception(finally) +import IO(bracket) import Test.HUnit @@ -25,9 +27,15 @@ main = runTestTT tests tests = - TestList [s3operationsTest] + TestList + [ + TestLabel "S3 Operations Test" s3OperationsTest, + TestLabel "S3 Copy Test" s3CopyTest, + TestLabel "S3 Location Test" s3LocationTest, + TestLabel "Bucket Naming Test" bucketNamingTest + ] -testBucket = "hS3-test" +testBucket = "hs3-test" testObjectTemplate = S3Object testBucket "hS3-object-test" "text/plain" [("x-amz-meta-foo", "bar"), @@ -35,9 +43,12 @@ ("x-amz-meta-smiley", "☺") ] (L.pack "Hello S3!") +testSourceTemplate = S3Object testBucket "hS3-object-source" "text/plain" + [] (L.pack "testing") +testDestinationTemplate = testSourceTemplate {obj_name = "hS3-object-destination"} -- | A sequence of several operations. -s3operationsTest = +s3OperationsTest = TestCase ( do c <- getConn -- Bucket Creation @@ -63,17 +74,74 @@ 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 +s3LocationTest = + TestCase ( + do c <- getConn + -- European buckets + bracket (testCreateBucketIn c "EU") + (\b -> + do testEmptyBucket c b + testDeleteBucket c b + ) + (\b -> + do testGetBucketLocation c b "EU" + let euTestObj = testObjectTemplate {obj_bucket = b} + testSendObject c euTestObj + testGetObject c euTestObj + testDeleteObject c euTestObj + ) + -- US buckets + bracket (testCreateBucketIn c "US") + (\b -> testDeleteBucket c b) + (\b -> testGetBucketLocation c b "US") ) +bucketNamingTest = + TestList + [ + (nameNotValidTC "At least 3 chars" "ab"), + (nameValidTC "At least 3 chars" "abc"), + (nameNotValidTC "63 chars or fewer" (replicate 64 'a')), + (nameNotValidTC "Starts with alphanum char" "."), + (nameNotValidTC "Starts with alphanum char" "_"), + (nameNotValidTC "Starts with alphanum char" "-"), + (nameNotValidTC "No underscores" "ab_cd"), + (nameNotValidTC "Do not end with a dash" "foo-"), + (nameNotValidTC "Dashes should not be next to periods" "ab.-cd") + ] + +nameValidTC :: String -> String -> Test +nameValidTC msg name = TestCase (assertBool msg (isBucketNameValid name)) +nameNotValidTC :: String -> String -> Test +nameNotValidTC msg name = TestCase (assertBool msg (not (isBucketNameValid name))) + +s3CopyTest = + TestCase ( + do c <- getConn + -- Bucket Creation + b <- testCreateBucket c + d <- testCreateBucket c + finally ( + do let srcObj = testSourceTemplate {obj_bucket = d} + let destObj = testDestinationTemplate {obj_bucket = b} + -- Object send + testSendObject c srcObj + -- Object copy + testCopyObject c srcObj destObj + -- Object get info from copied object + testGetObjectInfo c destObj + ) ( + -- Empty buckets + do testEmptyBucket c b + testEmptyBucket c d + -- Destroy buckets + testDeleteBucket c b + testDeleteBucket c d + ) + ) + failOnError :: (Show a) => Either a b -- ^ AWS Result to inspect -> t -- ^ Value to return on failure @@ -85,6 +153,12 @@ return f) (\x -> d x) r +testCreateNamedBucket :: AWSConnection -> String -> IO () +testCreateNamedBucket c bucket = + do r <- createBucket c bucket + failOnError r () + (const $ assertBool "bucket creation" True) + testCreateBucket :: AWSConnection -> IO String testCreateBucket c = do r <- createBucketWithPrefix c testBucket @@ -112,6 +186,12 @@ failOnError r () (const $ assertBool "object send" True) +testCopyObject :: AWSConnection -> S3Object -> S3Object -> IO () +testCopyObject c srco desto = + do r <- copyObject c srco desto + failOnError r () + (const $ assertBool "object copied" True) + testGetObject :: AWSConnection -> S3Object -> IO () testGetObject c o = do r <- getObject c o @@ -157,11 +237,13 @@ (const $ assertBool "bucket deletion" True) -- test if a bucket is not present +-- It sometimes takes a second or two for a bucket to disappear after a delete, +-- so failing this is not fatal. testBucketGone :: AWSConnection -> String -> IO () testBucketGone c bucket = getBucketLocation c bucket >>= either (\(AWSError code msg) -> assertEqual "Bucket is gone" "NotFound" code) - (\x -> do assertFailure "Bucket still there, should be gone" + (\x -> do assertFailure "Bucket still there, should be gone (sometimes slow, not fatal)" return ()) getConn = do mConn <- amazonS3ConnectionFromEnv diff --git a/hS3.cabal b/hS3.cabal --- a/hS3.cabal +++ b/hS3.cabal @@ -1,5 +1,5 @@ Name: hS3 -Version: 0.5.1 +Version: 0.5.2 License: BSD3 License-file: LICENSE Cabal-Version: >= 1.6 @@ -16,7 +16,7 @@ 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, +extra-source-files: README, CONTRIBUTORS, Tests.hs, examples/createBucket.hs examples/deleteObject.hs examples/listBuckets.hs @@ -32,7 +32,7 @@ Library - Build-depends: base >= 3 && < 4, HTTP >= 4000.0.0, Crypto >= 4.1.0, hxt, network, + 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 Exposed-modules: