hS3 0.5.4 → 0.5.5

raw patch · 7 files changed

+120/−24 lines, 7 filesdep ~hxtPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: hxt

API changes (from Hackage documentation)

Files

• FEATURES +2/−2
• Network/AWS/ArrowUtils.hs +2/−1
• Network/AWS/Authentication.hs +17/−8
• Network/AWS/S3Bucket.hs +75/−9
• Tests.hs +19/−1
• hS3.cabal +2/−2
• hS3.hs +3/−1

@@ -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)

@@ -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) 

@@ -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"

@@ -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 =+  "<VersioningConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Status>" ++ status ++  "</Status></VersioningConfiguration>"++-- | 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

@@ -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

@@ -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 

@@ -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 <name> [EU, US] : create bucket"         , "db <name> : delete bucket"+        , "eb <name> : empty bucket"         , "do <bucket> <key> : delete object"         , ""         , "lbs : list buckets"