hS3-0.5.7/0000755000000000000000000000000012120336274010346 5ustar0000000000000000hS3-0.5.7/FEATURES0000644000000000000000000000246012120336274011511 0ustar0000000000000000The 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 * Bittorrent * Delete markers * Enabling/disabling bucket logging * Payment configurations * Cloudfront Distributions (requires HTTPS) hS3-0.5.7/Setup.hs0000644000000000000000000000015312120336274012001 0ustar0000000000000000#!/usr/bin/env runhaskell module Main where import Distribution.Simple main :: IO () main = defaultMain hS3-0.5.7/hS3.cabal0000644000000000000000000000333112120336274011767 0ustar0000000000000000Name: hS3 Version: 0.5.7 License: BSD3 License-file: LICENSE Cabal-Version: >= 1.6 Copyright: Copyright (c) 2008, Greg Heartsfield Author: Greg Heartsfield Maintainer: Greg Heartsfield Homepage: http://gregheartsfield.com/hS3/ Category: Network, Web Stability: Alpha build-type: Simple 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, CONTRIBUTORS, FEATURES, Tests.hs, examples/createBucket.hs examples/deleteObject.hs examples/listBuckets.hs examples/sendObject.hs examples/deleteBucket.hs examples/getObject.hs examples/listObjects.hs examples/uploadFile.hs source-repository head type: darcs location: http://gregheartsfield.com/repos/hS3/ Library Build-depends: base >= 3 && < 5, HTTP >= 4000.0.0, Crypto >= 4.1.0, hxt >= 9.0.0 && < 10, network, regex-compat, old-time, random, old-locale, dataenc, utf8-string, bytestring, MissingH >= 0.18.6 Exposed-modules: Network.AWS.S3Object, Network.AWS.S3Bucket, Network.AWS.AWSResult, Network.AWS.AWSConnection, Network.AWS.Authentication, Network.AWS.ArrowUtils Executable hs3 main-is: hS3.hs hS3-0.5.7/README0000644000000000000000000000046612120336274011234 0ustar0000000000000000This 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]. hS3-0.5.7/LICENSE0000644000000000000000000000272012120336274011354 0ustar0000000000000000Copyright (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. hS3-0.5.7/CONTRIBUTORS0000644000000000000000000000015612120336274012230 0ustar0000000000000000- - Marc Weber - Anton van Straaten hS3-0.5.7/Tests.hs0000644000000000000000000003565012120336274012015 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 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 main = runTestTT tests tests = TestList [ 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 "Reduced Redundancy Creation Test" reducedRedundancyCreateTest, TestLabel "Reduced Redundancy Existing Test" reducedRedundancyExistingTest, TestLabel "Versioning Test" versioningTest ] testBucket = "hs3-test" testObjectTemplate = S3Object testBucket "hS3-object-test" "text/plain" [("x-amz-meta-foo", "bar"), ("x-amz-meta-french", "Bonjour, ça va?"), ("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 = TestCase ( do c <- getConn -- Bucket Creation bucket <- testCreateBucket c testGetBucketLocation c bucket "US" let testObj = testObjectTemplate {obj_bucket = bucket} -- Object send testSendObject c testObj -- Object get testGetObject c testObj -- Object get info testGetObjectInfo c testObj -- Object list (should have 1 object in bucket) testListAllObjects c bucket 1 -- Object delete testDeleteObject c testObj -- Object send, and then bucket empty testSendObject c testObj testEmptyBucket c bucket -- Bucket should now be empty testListAllObjects c bucket 0 -- Delete bucket testDeleteBucket c bucket -- Bucket should be gone threadDelay 3000000 -- sleep 3 sec, since bucket isn't always unavailable immediately testBucketGone c bucket ) 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 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 -- 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 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 -> (b -> IO t) -- ^ Assertions to run on success -> IO t failOnError r f d = either (\x -> do assertFailure (show x) 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 failOnError r "" (\x -> do assertBool "bucket creation" True return x ) testCreateBucketIn :: AWSConnection -> String -> IO String testCreateBucketIn c location = do r <- createBucketWithPrefixIn c testBucket location failOnError r "" (\x -> do assertBool ("bucket creation in " ++ location) True return x ) testGetBucketLocation :: AWSConnection -> String -> String -> IO () testGetBucketLocation c bucket expectedLocation = do r <- getBucketLocation c bucket failOnError r () (\x -> assertEqual ("Bucket in the " ++ expectedLocation) expectedLocation x) testSendObject :: AWSConnection -> S3Object -> IO () testSendObject c o = do r <- sendObject c o 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) 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 failOnError r () (\x -> do assertEqual "object get body" (obj_data o) (obj_data x) assertEqual "object get metadata" (obj_headers o) (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 failOnError r () (\x -> assertEqual "object info get metadata" (obj_headers o) (realMetadata (obj_headers x)) ) -- test that a bucket has a given number of objects testListAllObjects :: AWSConnection -> String -> Int -> IO () testListAllObjects c bucket count = do r <- listAllObjects c bucket (ListRequest "" "" "" 100) failOnError r () (\x -> assertEqual "object list" count (length x)) testEmptyBucket :: AWSConnection -> String -> IO () testEmptyBucket c b = do r <- emptyBucket c b failOnError r () (const $ assertBool "bucket empty" True) testDeleteObject :: AWSConnection -> S3Object -> IO () testDeleteObject c o = do r <- deleteObject c o failOnError r () (const $ assertBool "object delete" True) testDeleteBucket :: AWSConnection -> String -> IO () testDeleteBucket c bucket = do r <- deleteBucket c bucket failOnError r () (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 (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) ) versioningTest = TestCase ( do c <- getConn b <- testCreateBucket c r <- getVersioningConfiguration c b failOnError r () (\vc -> assertEqual "versioning is disabled by default" (VersioningConfiguration VersioningDisabled False) vc) sr <- setVersioningConfiguration c b (VersioningConfiguration VersioningEnabled False) failOnError sr () (\const -> assertBool "versioning set without error" True) ur <- getVersioningConfiguration c b failOnError ur () (\vc -> assertEqual "versioning is now enabled" (VersioningConfiguration VersioningEnabled False) vc) ) getConn = do mConn <- amazonS3ConnectionFromEnv return (fromJust mConn) -- These headers get added by amazon, but ignore them for -- testing metadata storage. headersToIgnore = ["x-amz-id-2", "x-amz-request-id"] realMetadata :: [(String, b)] -> [(String, b)] realMetadata = filter (\x -> fst x `notElem` headersToIgnore)hS3-0.5.7/hS3.hs0000644000000000000000000000415112120336274011340 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : hS3 -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Command-line program for interacting with S3. ----------------------------------------------------------------------------- module Main where import Network.AWS.S3Bucket import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import System.IO import Data.Maybe import Network.AWS.S3Object import qualified Data.ByteString.Lazy.Char8 as L withConn :: ( AWSConnection -> IO (AWSResult a)) -> IO a withConn f = do mConn <- amazonS3ConnectionFromEnv case mConn of Just c -> fmap (either (error . prettyReqError) -- failure id ) $ f c Nothing -> error "couldn't connect" main :: IO () main = do args <- getArgs case args of -- 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 L.putStr $ obj_data c ["do", bucket, key] -> 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) mapM_ (putStrLn . key) (snd l) ["lbs"] -> withConn listBuckets >>= mapM_ (putStrLn . bucket_name) _ -> usage usage :: IO () usage = putStr $ unlines [ "export AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET" , "" , "cb [EU, US] : create bucket" , "db : delete bucket" , "eb : empty bucket" , "do : delete object" , "" , "lbs : list buckets" , "so : send object" , "go : get object" , "los : list objects" ] hS3-0.5.7/examples/0000755000000000000000000000000012120336274012164 5ustar0000000000000000hS3-0.5.7/examples/listBuckets.hs0000644000000000000000000000151112120336274015012 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : List Buckets -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- List all buckets for an S3 account -- Usage: -- listBuckets.hs -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe main = do mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- listBuckets conn either print (mapM_ (putStrLn . bucket_name)) res hS3-0.5.7/examples/getObject.hs0000644000000000000000000000225512120336274014432 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : Get Object -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Retrieve the contents of an object in a bucket. -- Usage: -- getObject.hs bucket-name object-name -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs let bucket : key : xs = argv let obj = S3Object bucket key "" [] L.empty mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- getObject conn obj either (putStrLn . prettyReqError) (\x -> do putStrLn ("Key " ++ key ++ " has been retrieved. Content follows:") L.putStrLn (obj_data x)) reshS3-0.5.7/examples/listObjects.hs0000644000000000000000000000252612120336274015012 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : List Objects -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- List all objects in a bucket -- Usage: -- listObjects.hs bucket-name -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe main = do argv <- getArgs let bucket : xs = argv mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn res <- listAllObjects conn bucket (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 ++ " " ++ etag x)) x ) res hS3-0.5.7/examples/uploadFile.hs0000644000000000000000000000252112120336274014604 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : Upload File -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Upload a file to S3 with a given bucket and object name. -- Usage: -- uploadFile.hs bucket-name object-name filename -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe import System.IO import qualified Data.ByteString.Lazy.Char8 as L import System.Posix.Files main = do argv <- getArgs let bucket : key : filename : xs = argv f <- L.readFile filename contentFS <- getFileStatus filename let offset = fileSize contentFS mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn let obj = S3Object bucket key "text/plain" [("Content-Length",(show offset))] f res <- sendObject conn obj either (putStrLn . prettyReqError) (const $ putStrLn ("Creation of " ++ key ++ " successful.")) reshS3-0.5.7/examples/deleteObject.hs0000644000000000000000000000220412120336274015107 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : Delete Object -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Delete an object in a bucket with a given name. -- Usage: -- deleteObject.hs bucket-name object-name -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn let bucket : key : xs = argv let obj = S3Object bucket key "" [] L.empty res <- deleteObject conn obj either (putStrLn . prettyReqError) (const $ putStrLn ("Key " ++ key ++ " has been removed, if it existed before.")) reshS3-0.5.7/examples/sendObject.hs0000644000000000000000000000246612120336274014610 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : Send Object -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Create a new public object with some content. This can be viewed through -- a web browser afterwards by visiting http://bucket.s3.amazonaws.com/object -- Usage: -- sendObject.hs bucket-name object-name "Some Object Content." -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe import qualified Data.ByteString.Lazy.Char8 as L main = do argv <- getArgs let bucket : key : content : xs = argv mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn let obj = S3Object bucket key "text/html" [("x-amz-acl", "public-read")] (L.pack content) res <- sendObject conn obj either (putStrLn . prettyReqError) (const $ putStrLn ("Creation of " ++ key ++ " successful.")) res hS3-0.5.7/examples/createBucket.hs0000644000000000000000000000203512120336274015121 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : Create Bucket -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Create a new bucket, with a unique suffix. -- Usage: -- createBucket.hs bucket-name -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe main = do argv <- getArgs let bucket = head argv mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn putStrLn ("Creating bucket with name: " ++ bucket) res <- createBucketWithPrefix conn bucket either (putStrLn . prettyReqError) (\x -> putStrLn ("Creation of " ++ x ++ " successful.")) res hS3-0.5.7/examples/deleteBucket.hs0000644000000000000000000000202212120336274015114 0ustar0000000000000000#!/usr/local/bin/runhaskell ----------------------------------------------------------------------------- -- | -- Program : Delete Bucket -- Copyright : (c) Greg Heartsfield 2007 -- License : BSD3 -- -- Delete a bucket with a given name. -- Usage: -- deleteBucket.hs bucket-name -- -- This requires the following environment variables to be set with -- your Amazon keys: -- AWS_ACCESS_KEY_ID -- AWS_ACCESS_KEY_SECRET ----------------------------------------------------------------------------- import Network.AWS.S3Bucket import Network.AWS.AWSConnection import Network.AWS.AWSResult import System.Environment import Data.Maybe main = do argv <- getArgs let bucket = head argv mConn <- amazonS3ConnectionFromEnv let conn = fromJust mConn putStrLn ("Deleting bucket with name: " ++ bucket) res <- deleteBucket conn bucket either (putStrLn . prettyReqError) (const $ putStrLn ("Deletion of " ++ bucket ++ " successful.")) res hS3-0.5.7/Network/0000755000000000000000000000000012120336274011777 5ustar0000000000000000hS3-0.5.7/Network/AWS/0000755000000000000000000000000012120336274012431 5ustar0000000000000000hS3-0.5.7/Network/AWS/AWSConnection.hs0000644000000000000000000000454312120336274015445 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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_SECRET_ACCESS_KEY, respectively. -- Either variable being undefined or empty will result in -- 'Nothing'. amazonS3ConnectionFromEnv :: IO (Maybe AWSConnection) amazonS3ConnectionFromEnv = do ak <- getEnvKey "AWS_ACCESS_KEY_ID" sk0 <- getEnvKey "AWS_ACCESS_KEY_SECRET" sk1 <- getEnvKey "AWS_SECRET_ACCESS_KEY" return $ case (ak, sk0, sk1) of ("", _, _) -> Nothing ( _, "", "") -> Nothing ( _, "", _) -> Just (amazonS3Connection ak sk1) ( _, _, _) -> Just (amazonS3Connection ak sk0) where getEnvKey s = fmap (maybe "" id . lookup s) getEnvironment hS3-0.5.7/Network/AWS/Authentication.hs0000644000000000000000000004022212120336274015744 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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, isAmzHeader, preSignedURI, -- * Data Types S3Action(..), -- * Misc functions mimeEncodeQP, mimeDecode ) where import Network.AWS.AWSResult import Network.AWS.AWSConnection import Network.AWS.ArrowUtils import Network.HTTP as HTTP hiding (simpleHTTP_) import Network.HTTP.HandleStream (simpleHTTP_) import Network.Stream (Result) import Network.URI as URI import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Char8 (pack, unpack) import Data.HMAC import Codec.Binary.Base64 (encode, decode) import Codec.Utils (Octet) import Data.Char (intToDigit, digitToInt, ord, chr, toLower) import Data.Bits ((.&.)) import qualified Codec.Binary.UTF8.String as US import Data.List (sortBy, groupBy, intersperse, isInfixOf) import Data.Maybe import System.Time import System.Locale import Text.Regex import Control.Arrow import Control.Arrow.ArrowTree import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlOptions import Text.XML.HXT.DOM.XmlKeywords import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.Arrow.ReadDocument -- | An action to be performed using S3. data S3Action = S3Action { -- | Connection and authentication information s3conn :: AWSConnection, -- | Name of bucket to act on (URL encoded) s3bucket :: String, -- | Name of object to act on (URL encoded) s3object :: String, -- | Query parameters (requires a prefix of @?@) s3query :: String, -- | Additional header fields to send s3metadata :: [(String, String)], -- | Body of action, if sending data s3body :: L.ByteString, -- | Type of action, 'PUT', 'GET', etc. s3operation :: RequestMethod } 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.HTTPRequest L.ByteString -- ^ Action represented as an HTTP Request. requestFromAction a = Request { rqURI = URI { uriScheme = "", uriAuthority = Nothing, uriPath = qpath, uriQuery = s3query a, uriFragment = "" }, rqMethod = s3operation a, rqHeaders = Header HdrHost (s3Hostname a) : headersFromAction a, rqBody = (s3body a) } where qpath = '/' : s3object a -- | Create 'Header' objects from an action. headersFromAction :: S3Action -> [Header] headersFromAction = map (\(k,v) -> case k of "Content-Type" -> Header HdrContentType v "Content-Length" -> Header HdrContentLength v otherwise -> Header (HdrCustom k) (mimeEncodeQP v)) . s3metadata -- | Inspect HTTP body, and add a @Content-Length@ header with the -- correct length, if it does not already exist. addContentLengthHeader :: HTTP.HTTPRequest L.ByteString -> HTTP.HTTPRequest L.ByteString addContentLengthHeader req = insertHeaderIfMissing HdrContentLength conlength req where conlength = show (L.length (rqBody req)) -- | Add AWS authentication header to an HTTP request. addAuthenticationHeader :: S3Action -- ^ Action with authentication data -> 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 signature = (makeSignature conn (stringToSign act req)) conn = s3conn act -- | Sign a string using the given authentication data makeSignature :: AWSConnection -- ^ Action with authentication data -> String -- ^ String to sign -> String -- ^ Base-64 encoded signature makeSignature c s = encode (hmac_sha1 keyOctets msgOctets) where keyOctets = string2words (awsSecretKey c) msgOctets = string2words s -- | Generate text that will be signed and subsequently added to the -- request. stringToSign :: S3Action -> HTTP.HTTPRequest L.ByteString -> String stringToSign a r = canonicalizeHeaders r ++ canonicalizeAmzHeaders r ++ canonicalizeResource a -- | Extract header data needed for signing. canonicalizeHeaders :: HTTP.HTTPRequest L.ByteString -> String canonicalizeHeaders r = http_verb ++ "\n" ++ hdr_content_md5 ++ "\n" ++ hdr_content_type ++ "\n" ++ dateOrExpiration ++ "\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 = 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 -- lowercase key names -- sort lexigraphically by key name -- combine headers with same name -- unfold multi-line headers -- trim whitespace around the header canonicalizeAmzHeaders :: HTTP.HTTPRequest L.ByteString -> String canonicalizeAmzHeaders r = let amzHeaders = filter isAmzHeader (rqHeaders r) amzHeaderKV = map headerToLCKeyValue amzHeaders sortedGroupedHeaders = groupHeaders (sortHeaders amzHeaderKV) uniqueHeaders = combineHeaders sortedGroupedHeaders in concatMap (\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 ++ ":" ++ removeLeadingTrailingWhitespace(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/trailing whitespace removeLeadingTrailingWhitespace :: String -> String removeLeadingTrailingWhitespace s = subRegex (mkRegex "^\\s+") (subRegex (mkRegex "\\s+$") s "") "" -- | Combine same-named headers. combineHeaders :: [[(String, String)]] -> [(String, String)] combineHeaders = map mergeSameHeaders -- | Headers with same name should have values merged. mergeSameHeaders :: [(String, String)] -> (String, String) mergeSameHeaders h@(x:_) = 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) _ -> 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 :: String amzHeader = "x-amz-" -- | Extract resource name, as required for signing. canonicalizeResource :: S3Action -> String canonicalizeResource a = bucket ++ uri ++ subresource where uri = '/' : s3object a bucket = case (s3bucket a) of b@(_:_) -> '/' : map toLower b otherwise -> "" subresource = case (subresource_match) of [] -> "" x:_ -> x subresource_match = filter (\sr -> isInfixOf sr (s3query a)) ["?versioning", "?torrent", "?logging", "?acl", "?location"] -- | Add a date string to a request. addDateToReq :: HTTP.HTTPRequest L.ByteString -- ^ Request to modify -> 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} -- | Add an expiration date to a request. addExpirationToReq :: HTTP.HTTPRequest L.ByteString -> String -> HTTP.HTTPRequest L.ByteString 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} -- | Get hostname to connect to. Needed for european buckets s3Hostname :: S3Action -> String s3Hostname a = let s3host = awsHost (s3conn a) in case (s3bucket a) of b@(_:_) -> b ++ "." ++ s3host otherwise -> s3host -- | 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 = US.encode -- | Construct the request specified by an S3Action, send to Amazon, -- and return the response. Todo: add MD5 signature. runAction :: S3Action -> IO (AWSResult (HTTPResponse L.ByteString)) runAction a = runAction' a (s3Hostname a) runAction' :: S3Action -> String -> IO (AWSResult (HTTPResponse L.ByteString)) runAction' a hostname = do c <- (openTCPConnection hostname (awsPort (s3conn a))) --bufferOps = lazyBufferOp cd <- httpCurrentDate 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 -- | Construct a pre-signed URI, but don't act on it. This is useful -- for when an expiration date has been set, and the URI needs to be -- passed on to a client. preSignedURI :: S3Action -- ^ Action with resource -> Integer -- ^ Expiration time, in seconds since -- 00:00:00 UTC on January 1, 1970 -> URI -- ^ URI of resource preSignedURI a e = let c = (s3conn a) srv = (awsHost c) pt = (show (awsPort 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) q = beginQuery ++ accessKeyQuery ++ "&" ++ expireQuery ++ "&" ++ sigQuery in URI { uriScheme = "http:", uriAuthority = Just (URIAuth "" srv (':' : pt)), uriPath = "/" ++ s3bucket a ++ "/" ++ s3object a, uriQuery = q, uriFragment = "" } -- | Inspect a response for network errors, HTTP error codes, and -- 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 = return . Left . NetworkError handleSuccess s = case (rspCode s) of (2,_,_) -> return (Right s) -- temporary redirect (3,0,7) -> case (findHeader HdrLocation s) of Just l -> runAction' a (getHostname l) Nothing -> return (Left $ AWSError "Temporary Redirect" "Redirect without location header") -- not good (4,0,4) -> return (Left $ AWSError "NotFound" "404 Not Found") -- no body, so no XML to parse otherwise -> do e <- parseRestErrorXML (L.unpack (rspBody s)) return (Left e) -- Get hostname part from http url. getHostname :: String -> String getHostname h = case parseURI h of Just u -> case (uriAuthority u) of Just auth -> (uriRegName auth) Nothing -> "" Nothing -> "" -- | Find the errors embedded in an XML message body from Amazon. parseRestErrorXML :: String -> IO ReqError parseRestErrorXML x = do e <- runX (readString [withValidate no] 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) --- 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 | isPrefix utf8qp a = mimeDecodeQP $ encoded_payload utf8qp a | isPrefix utf8b64 a = mimeDecodeB64 $ encoded_payload utf8b64 a | otherwise = a where utf8qp = "=?UTF-8?Q?" utf8b64 = "=?UTF-8?B?" -- '=?UTF-8?Q?foobar?=' -> 'foobar' encoded_payload prefix = reverse . drop 2 . reverse . drop (length prefix) mimeDecodeQP :: String -> String mimeDecodeQP = US.decodeString . mimeDecodeQP' mimeDecodeQP' :: String -> String mimeDecodeQP' ('=':a:b:rest) = chr (16 * digitToInt a + digitToInt b) : mimeDecodeQP' rest mimeDecodeQP' (h:t) =h : mimeDecodeQP' t mimeDecodeQP' [] = [] mimeDecodeB64 :: String -> String mimeDecodeB64 s = case decode s of Nothing -> "" Just a -> US.decode a -- Encode a String into quoted printable, if needed. -- eq: =?UTF-8?Q?=aa?= mimeEncodeQP s = if any reservedChar s then "=?UTF-8?Q?" ++ (mimeEncodeQP' $ US.encodeString s) ++ "?=" else s mimeEncodeQP' :: String -> String mimeEncodeQP' [] = [] mimeEncodeQP' (h:t) = let str = if reservedChar h then escape h else [h] in str ++ mimeEncodeQP' t where escape x = let y = ord x in [ '=', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ] -- Char needs escaping? reservedChar :: Char -> Bool reservedChar x -- from space (0x20) till '~' everything is fine. The rest are control chars, or high bit. | xi >= 0x20 && xi <= 0x7e = False | otherwise = True where xi = ord x hS3-0.5.7/Network/AWS/AWSResult.hs0000644000000000000000000000261012120336274014615 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 -- | A result from processing a request to S3. Either some success -- value, or a 'ReqError'. type AWSResult a = Either ReqError a -- | An error from an S3 request, either at the network layer, or from -- S3 itself. data ReqError = -- | Connection error at the network layer. NetworkError Stream.ConnError | -- | @AWSError code message@ constructs an error message from S3 -- itself. See -- -- for a detailed list of possible codes. AWSError String String deriving (Show, Eq) -- | Pretty print an error message. prettyReqError :: ReqError -> String prettyReqError r = case r of AWSError a b -> b NetworkError c -> show chS3-0.5.7/Network/AWS/S3Object.hs0000644000000000000000000002577612120336274014422 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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, copyObject, copyObjectWithReplace, getObject, getObjectInfo, deleteObject, publicUriForSeconds, publicUriUntilTime, setStorageClass, getStorageClass, rewriteStorageClass, -- * Data Types S3Object(..), StorageClass(..) ) where import Network.AWS.Authentication as Auth import Network.AWS.AWSResult import Network.AWS.AWSConnection import Network.HTTP import Network.URI import System.Time import Data.List.Utils import Data.List(lookup) import qualified Data.ByteString.Lazy.Char8 as L -- | 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 :: 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. -- If the header "Content-Length" is not set, all content must be read into -- memory prior to sending. 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 (urlEncode (obj_bucket obj)) (urlEncode (obj_name obj)) "" (("Content-Type", (content_type obj)) : obj_headers obj) (obj_data obj) PUT) return (either Left (\_ -> Right ()) res) -- | Create a pre-signed request URI. Anyone can use this to request -- an object until the specified date. publicUriUntilTime :: AWSConnection -- ^ AWS connection information -> S3Object -- ^ Object to be made available -> Integer -- ^ Expiration time, in seconds since -- 00:00:00 UTC on January 1, 1970 -> URI -- ^ URI for the object publicUriUntilTime c obj time = 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 -- an object for the number of seconds specified. publicUriForSeconds :: AWSConnection -- ^ AWS connection information -> S3Object -- ^ Object to be made available -> Integer -- ^ How many seconds until this -- request expires -> IO URI -- ^ URI for the object publicUriForSeconds c obj time = do TOD ctS _ <- getClockTime -- GHC specific, todo: get epoch within h98. return (publicUriUntilTime c obj (ctS + time)) -- | Retrieve an object. getObject :: AWSConnection -- ^ AWS connection information -> S3Object -- ^ Object to retrieve -> IO (AWSResult S3Object) -- ^ Server response getObject = getObjectWithMethod GET -- | Get object info without retrieving content body from server. getObjectInfo :: AWSConnection -- ^ AWS connection information -> S3Object -- ^ Object to retrieve information on -> IO (AWSResult S3Object) -- ^ Server response getObjectInfo = getObjectWithMethod HEAD -- | Get an object with specified method. getObjectWithMethod :: RequestMethod -- ^ Method to use for retrieval (GET/HEAD) -> AWSConnection -- ^ AWS connection -> S3Object -- ^ Object to request -> IO (AWSResult S3Object) getObjectWithMethod m aws obj = do res <- Auth.runAction (S3Action aws (urlEncode (obj_bucket obj)) (urlEncode (obj_name obj)) "" (obj_headers obj) L.empty m) return (either Left (\x -> Right (populate_obj_from x)) res) where populate_obj_from x = obj { obj_data = (rspBody x), obj_headers = (headersFromResponse x) } headersFromResponse :: HTTPResponse L.ByteString -> [(String,String)] headersFromResponse r = let respheaders = rspHeaders r in map (\x -> case x of Header (HdrCustom name) val -> (name, (mimeDecode val)) ) (filter isAmzHeader respheaders) -- | 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 (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), 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 (bucket+name only) -> S3Object -- ^ Destination object -> 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)) "" (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))))] ++ (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") }) hS3-0.5.7/Network/AWS/ArrowUtils.hs0000644000000000000000000000141212120336274015076 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction#-} ----------------------------------------------------------------------------- -- | -- 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 Control.Arrow.ArrowTree import Text.XML.HXT.Arrow.XmlArrow -- 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 hS3-0.5.7/Network/AWS/S3Bucket.hs0000644000000000000000000003673512120336274014426 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 createBucketIn, createBucket, createBucketWithPrefixIn, createBucketWithPrefix, deleteBucket, getBucketLocation, emptyBucket, listBuckets, listObjects, listAllObjects, isBucketNameValid, getObjectStorageClass, getVersioningConfiguration, setVersioningConfiguration, -- * Data Types S3Bucket(S3Bucket, bucket_name, bucket_creation_date), ListRequest(..), ListResult(..), IsTruncated, VersioningConfiguration(..), VersioningStatus(..) ) where import Network.AWS.Authentication as Auth import Network.AWS.AWSResult import Network.AWS.S3Object import Network.AWS.AWSConnection import Network.AWS.ArrowUtils import Network.HTTP as HTTP import Network.Stream() import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toLower, isAlphaNum) import Data.List (isInfixOf) import qualified Data.Tree.NTree.TypeDefs import Control.Monad import System.Random (randomIO) import Codec.Utils import Data.Digest.MD5 import Codec.Text.Raw import Control.Arrow import Control.Arrow.ArrowTree import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlOptions import Text.XML.HXT.DOM.XmlKeywords import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.Arrow.ReadDocument import Text.XML.HXT.DOM.TypeDefs data S3Bucket = S3Bucket { bucket_name :: String, bucket_creation_date :: String } deriving (Show, Eq) data VersioningConfiguration = VersioningConfiguration { versioningStatus :: VersioningStatus, mfaDeleteEnabled :: Bool } deriving (Read, Show, Eq) data VersioningStatus = VersioningDisabled | VersioningEnabled | VersioningSuspended deriving (Read, 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. createBucketWithPrefixIn :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name prefix -> String -- ^ Location ("US", "EU", "us-west-1", "ap-southeast-1") -> IO (AWSResult String) -- ^ Server response, if -- successful, the bucket -- name is returned. createBucketWithPrefixIn aws pre location = do suffix <- randomName let name = pre ++ "-" ++ suffix res <- createBucketIn aws name location either (\x -> case x of AWSError _ _ -> createBucketWithPrefixIn aws pre location otherwise -> return (Left x)) (\_ -> return (Right name)) res -- | see createBucketWithPrefixIn, but hardcoded for the US createBucketWithPrefix :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name prefix -> IO (AWSResult String) -- ^ Server response, with bucket name createBucketWithPrefix aws pre = createBucketWithPrefixIn aws pre "US" randomName :: IO String randomName = do rdata <- randomIO :: IO Integer return $ take 10 $ show $ hexdumpBy "" 999 (hash (toOctets (10::Integer) (abs rdata))) -- | Create a new bucket on S3 with the given name. createBucketIn :: AWSConnection -- ^ AWS connection information -> String -- ^ Proposed bucket name -> String -- ^ Location ("US", "EU", "us-west-1", "ap-southeast-1") -> IO (AWSResult ()) -- ^ Server response createBucketIn aws bucket location = let constraint = if location == "US" then "" -- US == no body else "" ++ location ++ "" 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) -- | 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 = createBucketIn aws bucket "US" -- | Physical location of the bucket. "US" or "EU" getBucketLocation :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name -> 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 Left x -> return (Left x) Right y -> do bs <- parseBucketLocationXML (L.unpack (rspBody y)) return (Right bs) parseBucketLocationXML :: String -> IO String parseBucketLocationXML s = do results <- runX (readString [withValidate no] s >>> processLocation) return $ case results of [] -> "US" -- not specified by S3, but they are in the US x:_ -> x processLocation :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) String processLocation = (text <<< atTag "LocationConstraint") >>> arr id -- | 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 "" "" [] L.empty DELETE) 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 -- objects in the bucket. At this time, delete requests are free -- from Amazon. emptyBucket :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name to empty -> IO (AWSResult ()) -- ^ Server response emptyBucket aws bucket = do res <- listAllObjects aws bucket (ListRequest "" "" "" 0) let objFromRes x = S3Object bucket (key x) "" [] L.empty case res of Left x -> return (Left x) Right y -> deleteObjects aws (map objFromRes y) -- | Delete a list of objects, stop as soon as an error is encountered. deleteObjects :: AWSConnection -> [S3Object] -> IO (AWSResult ()) deleteObjects _ [] = return (Right ()) deleteObjects aws (x:xs) = do dr <- deleteObject aws x case dr of Left o -> return (Left o) Right _ -> deleteObjects aws xs -- | 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 [S3Bucket]) -- ^ Server response listBuckets aws = do res <- Auth.runAction (S3Action aws "" "" "" [] L.empty GET) case res of Left x -> return (Left x) Right y -> do bs <- parseBucketListXML (L.unpack (rspBody y)) return (Right bs) parseBucketListXML :: String -> IO [S3Bucket] parseBucketListXML x = runX (readString [withValidate no] x >>> processBuckets) processBuckets :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) S3Bucket processBuckets = deep (isElem >>> hasName "Bucket") >>> split >>> first (text <<< atTag "Name") >>> second (text <<< atTag "CreationDate") >>> unsplit (\x y -> S3Bucket 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 storageClass :: StorageClass -- ^ Storage class of the object } deriving (Show) -- | Is a result set response truncated? type IsTruncated = Bool -- | 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 (IsTruncated, [ListResult])) -- ^ Server response listObjects aws bucket lreq = do res <- Auth.runAction (S3Action aws bucket "" ('?' : show lreq) [] L.empty GET) case res of Left x -> return (Left x) Right y -> do let objs = L.unpack (rspBody y) tr <- isListTruncated objs lr <- getListResults objs return (Right (tr, lr)) -- | Repeatedly query the server for all objects in a bucket, ignoring the @max_keys@ field. listAllObjects :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name to search -> ListRequest -- ^ List parameters -> IO (AWSResult [ListResult]) -- ^ Server response listAllObjects aws bucket lp = do let lp_max = lp {max_keys = 1000} res <- listObjects aws bucket lp_max case res of Left x -> return (Left x) Right y -> case y of (True,lr) -> do let last_result = (key . last) lr next_set <- listAllObjects aws bucket (lp_max {marker = last_result}) either (\x -> return (Left x)) (\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. isListTruncated :: String -> IO Bool isListTruncated s = do results <- runX (readString [withValidate no] s >>> processTruncation) return $ case results of [] -> False x:_ -> x processTruncation :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) Bool 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 [withValidate no] s >>> processListResults) processListResults :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) ListResult processListResults = deep (isElem >>> hasName "Contents") >>> ((text <<< atTag "Key") &&& (text <<< atTag "LastModified") &&& (text <<< atTag "ETag") &&& (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 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) /= '-')] -- | Set the versioning configuration of a bucket (MFA not yet supported). setVersioningConfiguration :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket to modify -> VersioningConfiguration -- ^ Desired versioning configuration -> IO (AWSResult ()) -- ^ Server response setVersioningConfiguration aws bucket vc = do res <- Auth.runAction (S3Action aws bucket "" "?versioning" [] (L.pack (versioningConfigurationToXML vc)) PUT) case res of Left x -> return (Left x) Right y -> return (Right ()) versioningConfigurationToXML :: VersioningConfiguration -> String versioningConfigurationToXML vc = case vc of VersioningConfiguration VersioningEnabled _ -> versioningConfigXml "Enabled" VersioningConfiguration _ _ -> versioningConfigXml "Suspended" versioningConfigXml :: String -> String versioningConfigXml status = "" ++ status ++ "" -- | Check versioning and MFA configuration of a bucket. getVersioningConfiguration :: AWSConnection -- ^ AWS connection information -> String -- ^ Bucket name to inquire on -> IO (AWSResult VersioningConfiguration) -- ^ Server response getVersioningConfiguration aws bucket = do res <- Auth.runAction (S3Action aws bucket "" "?versioning" [] L.empty GET) case res of Left x -> return (Left x) Right y -> do vc <- parseVersionConfigXML (L.unpack (rspBody y)) return (Right vc) parseVersionConfigXML :: String -> IO (VersioningConfiguration) parseVersionConfigXML s = do results <- runX (readString [withValidate no] s >>> processVersionConfig) return $ case results of [] -> (VersioningConfiguration VersioningSuspended True) x:_ -> x processVersionConfig = deep (isElem >>> hasName "VersioningConfiguration") >>> ((text <<< atTag "Status") >>> arr (\v -> case (map toLower v) of "suspended" -> (VersioningConfiguration VersioningSuspended False) "enabled" -> (VersioningConfiguration VersioningEnabled False) )) <+> arr (\x -> (VersioningConfiguration VersioningDisabled False)) -- | Remove quote characters from a 'String'. unquote :: String -> String unquote = filter (/= '"')