diff --git a/FEATURES b/FEATURES --- a/FEATURES +++ b/FEATURES @@ -28,8 +28,8 @@ * ACLs (Access Control Lists) * Object versioning - * Any bittorrent functionality + * Bittorrent * Delete markers * Enabling/disabling bucket logging - * Distributions * Payment configurations + * Cloudfront Distributions (requires HTTPS) diff --git a/Network/AWS/ArrowUtils.hs b/Network/AWS/ArrowUtils.hs --- a/Network/AWS/ArrowUtils.hs +++ b/Network/AWS/ArrowUtils.hs @@ -15,7 +15,8 @@ where import Control.Arrow -import Text.XML.HXT.Arrow +import Control.Arrow.ArrowTree +import Text.XML.HXT.Arrow.XmlArrow -- misc. functions for working with arrows (and HXT) diff --git a/Network/AWS/Authentication.hs b/Network/AWS/Authentication.hs --- a/Network/AWS/Authentication.hs +++ b/Network/AWS/Authentication.hs @@ -38,7 +38,7 @@ import Data.Bits ((.&.)) import qualified Codec.Binary.UTF8.String as US -import Data.List (sortBy, groupBy, intersperse) +import Data.List (sortBy, groupBy, intersperse, isInfixOf) import Data.Maybe import System.Time @@ -46,8 +46,13 @@ import Text.Regex ---import Control.Arrow() -import Text.XML.HXT.Arrow +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 = @@ -106,7 +111,7 @@ -> 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) + signature = (makeSignature conn (stringToSign act req)) conn = s3conn act -- | Sign a string using the given authentication data @@ -206,12 +211,16 @@ -- | Extract resource name, as required for signing. canonicalizeResource :: S3Action -> String -canonicalizeResource a = bucket ++ uri +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 @@ -270,7 +279,7 @@ --print aReq -- Show request header result <- simpleHTTP_ c aReq -- Show result header and body - -- print result + --print result --case result of -- Left a -> print "" -- Right a -> print (rspBody a) @@ -330,7 +339,7 @@ -- | Find the errors embedded in an XML message body from Amazon. parseRestErrorXML :: String -> IO ReqError parseRestErrorXML x = - do e <- runX (readString [(a_validate,v_0)] x + do e <- runX (readString [withValidate no] x >>> processRestError) case e of [] -> return (AWSError "NoErrorInMsg" diff --git a/Network/AWS/S3Bucket.hs b/Network/AWS/S3Bucket.hs --- a/Network/AWS/S3Bucket.hs +++ b/Network/AWS/S3Bucket.hs @@ -15,11 +15,14 @@ createBucketWithPrefix, deleteBucket, getBucketLocation, emptyBucket, listBuckets, listObjects, listAllObjects, isBucketNameValid, getObjectStorageClass, + getVersioningConfiguration, setVersioningConfiguration, -- * Data Types S3Bucket(S3Bucket, bucket_name, bucket_creation_date), ListRequest(..), ListResult(..), - IsTruncated + IsTruncated, + VersioningConfiguration(..), + VersioningStatus(..) ) where import Network.AWS.Authentication as Auth @@ -36,9 +39,7 @@ import Data.Char (toLower, isAlphaNum) import Data.List (isInfixOf) -import Text.XML.HXT.Arrow import qualified Data.Tree.NTree.TypeDefs -import Control.Arrow import Control.Monad import System.Random (randomIO) @@ -46,10 +47,28 @@ 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. @@ -113,10 +132,9 @@ Right y -> do bs <- parseBucketLocationXML (L.unpack (rspBody y)) return (Right bs) - parseBucketLocationXML :: String -> IO String parseBucketLocationXML s = - do results <- runX (readString [(a_validate,v_0)] s >>> processLocation) + 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 @@ -171,7 +189,7 @@ return (Right bs) parseBucketListXML :: String -> IO [S3Bucket] -parseBucketListXML x = runX (readString [(a_validate,v_0)] x >>> processBuckets) +parseBucketListXML x = runX (readString [withValidate no] x >>> processBuckets) processBuckets :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) S3Bucket processBuckets = deep (isElem >>> hasName "Bucket") >>> @@ -257,7 +275,7 @@ -- have to parse the XML twice. isListTruncated :: String -> IO Bool isListTruncated s = - do results <- runX (readString [(a_validate,v_0)] s >>> processTruncation) + do results <- runX (readString [withValidate no] s >>> processTruncation) return $ case results of [] -> False x:_ -> x @@ -269,9 +287,8 @@ "false" -> False otherwise -> False) - getListResults :: String -> IO [ListResult] -getListResults s = runX (readString [(a_validate,v_0)] s >>> processListResults) +getListResults s = runX (readString [withValidate no] s >>> processListResults) processListResults :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) ListResult processListResults = deep (isElem >>> hasName "Contents") >>> @@ -292,6 +309,55 @@ (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 diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -36,7 +36,8 @@ TestLabel "S3 Location Test" s3LocationTest, TestLabel "Bucket Naming Test" bucketNamingTest, TestLabel "Reduced Redundancy Creation Test" reducedRedundancyCreateTest, - TestLabel "Reduced Redundancy Existing Test" reducedRedundancyExistingTest + TestLabel "Reduced Redundancy Existing Test" reducedRedundancyExistingTest, + TestLabel "Versioning Test" versioningTest ] testBucket = "hs3-test" @@ -335,6 +336,23 @@ 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 diff --git a/hS3.cabal b/hS3.cabal --- a/hS3.cabal +++ b/hS3.cabal @@ -1,5 +1,5 @@ Name: hS3 -Version: 0.5.4 +Version: 0.5.5 License: BSD3 License-file: LICENSE Cabal-Version: >= 1.6 @@ -33,7 +33,7 @@ Library - Build-depends: base >= 3 && < 5, HTTP >= 4000.0.0, Crypto >= 4.1.0, hxt < 9.0.0, network, + 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 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"