diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -267,11 +267,18 @@ return Credentials { .. } -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. +-- May return 'Nothing' if @HOME@ is unset. -- -- Value: //@/.aws-keys@ -credentialsDefaultFile :: MonadIO io => io FilePath -credentialsDefaultFile = liftIO $ ( ".aws-keys") <$> getHomeDirectory +credentialsDefaultFile :: MonadIO io => io (Maybe FilePath) +credentialsDefaultFile = liftIO $ tryMaybe (( ".aws-keys") <$> getHomeDirectory) +tryMaybe :: IO a -> IO (Maybe a) +tryMaybe action = E.catch (Just <$> action) f + where + f :: E.SomeException -> IO (Maybe a) + f _ = return Nothing + -- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'. -- -- Value: @default@ @@ -302,12 +309,12 @@ loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment - let lk = flip lookup env + let lk = fmap (T.encodeUtf8 . T.pack) . flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY" - Traversable.sequence - (makeCredentials <$> (T.encodeUtf8 . T.pack <$> keyID) - <*> (T.encodeUtf8 . T.pack <$> secret)) + setSession creds = creds { iamToken = lk "AWS_SESSION_TOKEN" } + makeCredentials' k s = setSession <$> makeCredentials k s + Traversable.sequence $ makeCredentials' <$> keyID <*> secret loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) loadCredentialsFromInstanceMetadata = liftIO $ HTTP.withManager $ \mgr -> @@ -373,8 +380,10 @@ -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do - file <- credentialsDefaultFile - loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey + mfile <- credentialsDefaultFile + case mfile of + Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey + Nothing -> loadCredentialsFromEnv -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -49,7 +49,7 @@ -- * Defining new 'DynVal' instances , DynData(..) - , DynBinary(..), DynNumber(..), DynString(..) + , DynBinary(..), DynNumber(..), DynString(..), DynBool(..) -- * Working with key/value pairs , Attribute (..) @@ -75,6 +75,7 @@ , Parser (..) , getAttr , getAttr' + , parseAttr -- * Common types used by operations , Conditions (..) @@ -1348,6 +1349,19 @@ Nothing -> return Nothing Just dv -> return $ fromValue dv +-- | Combinator for parsing an attribute into a 'FromDynItem'. +parseAttr + :: FromDynItem a + => T.Text + -- ^ Attribute name + -> Item + -- ^ Item from DynamoDb + -> Parser a +parseAttr k m = + case M.lookup k m of + Nothing -> fail ("Key " <> T.unpack k <> " not found") + Just (DMap dv) -> either (fail "...") return $ fromItem dv + _ -> fail ("Key " <> T.unpack k <> " is not a map!") ------------------------------------------------------------------------------- -- | Parse an 'Item' into target type using the 'FromDynItem' diff --git a/Aws/S3/Commands/GetObject.hs b/Aws/S3/Commands/GetObject.hs --- a/Aws/S3/Commands/GetObject.hs +++ b/Aws/S3/Commands/GetObject.hs @@ -4,7 +4,7 @@ import Aws.Core import Aws.S3.Core import Control.Applicative -import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.Trans.Resource (ResourceT, throwM) import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L @@ -28,11 +28,15 @@ , goResponseContentDisposition :: Maybe T.Text , goResponseContentEncoding :: Maybe T.Text , goResponseContentRange :: Maybe (Int,Int) + , goIfMatch :: Maybe T.Text + -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed. + , goIfNoneMatch :: Maybe T.Text + -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified. } deriving (Show) getObject :: Bucket -> T.Text -> GetObject -getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data GetObjectResponse = GetObjectResponse { @@ -66,6 +70,8 @@ , s3QAmzHeaders = [] , s3QOtherHeaders = catMaybes [ decodeRange <$> goResponseContentRange + , ("if-match",) . T.encodeUtf8 <$> goIfMatch + , ("if-none-match",) . T.encodeUtf8 <$> goIfNoneMatch ] , s3QRequestBody = Nothing } @@ -74,9 +80,15 @@ instance ResponseConsumer GetObject GetObjectResponse where type ResponseMetadata GetObjectResponse = S3Metadata responseConsumer GetObject{..} metadata resp - = do rsp <- s3BinaryResponseConsumer return metadata resp - om <- parseObjectMetadata (HTTP.responseHeaders resp) - return $ GetObjectResponse om rsp + | status == HTTP.status200 = do + rsp <- s3BinaryResponseConsumer return metadata resp + om <- parseObjectMetadata (HTTP.responseHeaders resp) + return $ GetObjectResponse om rsp + | otherwise = throwM $ HTTP.StatusCodeException status headers cookies + where + status = HTTP.responseStatus resp + headers = HTTP.responseHeaders resp + cookies = HTTP.responseCookieJar resp instance Transaction GetObject GetObjectResponse diff --git a/Aws/S3/Commands/HeadObject.hs b/Aws/S3/Commands/HeadObject.hs --- a/Aws/S3/Commands/HeadObject.hs +++ b/Aws/S3/Commands/HeadObject.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans.Resource (throwM) import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Char8 as B8 +import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Conduit as HTTP @@ -17,11 +18,15 @@ hoBucket :: Bucket , hoObjectName :: Object , hoVersionId :: Maybe T.Text + , hoIfMatch :: Maybe T.Text + -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed. + , hoIfNoneMatch :: Maybe T.Text + -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified. } deriving (Show) headObject :: Bucket -> T.Text -> HeadObject -headObject b o = HeadObject b o Nothing +headObject b o = HeadObject b o Nothing Nothing Nothing data HeadObjectResponse = HeadObjectResponse { @@ -46,7 +51,10 @@ , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = [] - , s3QOtherHeaders = [] + , s3QOtherHeaders = catMaybes [ + ("if-match",) . T.encodeUtf8 <$> hoIfMatch + , ("if-none-match",) . T.encodeUtf8 <$> hoIfNoneMatch + ] , s3QRequestBody = Nothing } diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,13 +1,22 @@ +0.14 series + +NOTES: 0.14 brings potentially breaking changes + +- 0.14 + - transformers 0.5 support + - data-default 0.6 support (also in 0.13.1) + - time < 2.0 support + - General: Use AWS_SESSION_TOKEN if in environment for loading credentials + - General: loadCredentialsDefault fails gracefully if HOME is not set + - DDB: Add parseAttr combinator for parsing an attribute into a FromDynItem + - DDB: Expose the new DynBool type + - S3: Add ETag fields to get/head object + 0.13 series ----------- NOTE: 0.13 brings breaking changes compared to 0.12.1! -- 0.13.2 - - ghc 8 support, via: - - time 1.6 support - - transformers 0.5 support - - cereal 0.6 support - 0.13.1 - data-default 0.6 support - 0.13 diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -1,7 +1,7 @@ Name: aws -Version: 0.13.2 +Version: 0.14.0 Synopsis: Amazon Web Services (AWS) for Haskell -Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at . +Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at . Homepage: http://github.com/aristidb/aws License: BSD3 License-file: LICENSE @@ -19,7 +19,7 @@ Source-repository this type: git location: https://github.com/aristidb/aws.git - tag: 0.13.2 + tag: 0.14.0 Source-repository head type: git @@ -124,7 +124,7 @@ conduit-extra >= 1.1 && < 1.2, containers >= 0.4, cryptohash >= 0.11 && < 0.12, - data-default >= 0.5.3 && < 0.7, + data-default >= 0.5.3 && < 0.8, directory >= 1.0 && < 1.3, filepath >= 1.1 && < 1.5, http-conduit >= 2.1 && < 2.2, @@ -373,3 +373,26 @@ time, transformers >= 0.3, transformers-base >= 0.4 + + +test-suite s3-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: S3/Main.hs + + other-modules: + Utils + + build-depends: + aws, + base == 4.*, + bytestring, + http-client, + http-client-tls, + http-types, + resourcet, + tasty >= 0.8, + tasty-hunit >= 0.8, + text, + tagged >= 0.7 diff --git a/tests/S3/Main.hs b/tests/S3/Main.hs new file mode 100644 --- /dev/null +++ b/tests/S3/Main.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Main +-- Copyright: Copyright © 2016 Soostone, Inc. +-- License: BSD3 +-- Maintainer: Michael Xavier +-- Stability: experimental +-- +-- Tests for Haskell AWS S3 bindings +-- +module Main + ( main + ) where + +import Control.Applicative +import Data.ByteString (ByteString) +import Control.Arrow (second) +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Resource +import qualified Data.List as L +import Data.Monoid +import qualified Data.Text as T +import Data.Typeable +import Data.Proxy +import Network.HTTP.Client (HttpException (..), + RequestBody (..), newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types.Status +import System.Environment +import System.Exit +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options + +import Aws +import Aws.S3 + + +newtype BucketOption = BucketOption Bucket + deriving (Show, Eq, Ord, Typeable) + +instance IsOption BucketOption where + defaultValue = error "The --bucket flag is required" + parseValue = Just . BucketOption . T.pack + optionName = return "bucket" + optionHelp = return "Bucket to use for performing S3 operations. Tests will write to the 's3-test-object' key." + + +main :: IO () +main = do + args <- getArgs + runMain args $ map (second tail . span (/= '=')) args + where + runMain :: [String] -> [(String,String)] -> IO () + runMain args _argsMap + | any (`elem` helpArgs) args = defaultMainWithIngredients ings tests + | "--run-with-aws-credentials" `elem` args = + withArgs (tastyArgs args) . defaultMainWithIngredients ings $ tests + | otherwise = putStrLn help >> exitFailure + helpArgs = ["--help", "-h"] + mainArgs = + [ "--run-with-aws-credentials" + ] + tastyArgs args = flip filter args $ \x -> not + $ any (`L.isPrefixOf` x) mainArgs + ings = includingOptions [Option (Proxy :: Proxy BucketOption)]:defaultIngredients + + +help :: String +help = L.intercalate "\n" + [ "" + , "NOTE" + , "" + , "This test suite accesses the AWS account that is associated with" + , "the default credentials from the credential file ~/.aws-keys." + , "" + , "By running the tests in this test-suite costs for usage of AWS" + , "services may incur." + , "" + , "In order to actually excute the tests in this test-suite you must" + , "provide the command line options:" + , "" + , " --run-with-aws-credentials" + , "" + , "When running this test-suite through cabal you may use the following" + , "command:" + , "" + , " cabal test --test-option=--run-with-aws-credentials s3-tests" + , "" + ] + + +tests :: TestTree +tests = testGroup "S3 Tests" + [ test_head + , test_get + ] + + +------------------------------------------------------------------------------- +-- HeadObject Tests +------------------------------------------------------------------------------- + + +test_head :: TestTree +test_head = askOption $ \(BucketOption bucket) -> testGroup "HeadObject" + [ test_head_caching bucket + ] + + +test_head_caching :: Bucket -> TestTree +test_head_caching bucket = withResource mkSetup teardown $ \setup -> testGroup "Caches" + [ testCase "If-Matches match succeeds" $ do + (cfg, s3cfg, mgr) <- setup + void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just payloadMD5 })) + , testCase "If-Matches mismatch fails with 412" $ do + (cfg, s3cfg, mgr) <- setup + assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just (T.reverse payloadMD5) })) + , testCase "If-None-Match mismatch succeeds" $ do + (cfg, s3cfg, mgr) <- setup + void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just (T.reverse payloadMD5) })) + , testCase "If-None-Match match fails with 304" $ do + (cfg, s3cfg, mgr) <- setup + assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just payloadMD5 })) + ] + where + k = "s3-test-object" + content = "example" + payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533" + mkSetup = do + cfg <- baseConfiguration + let s3cfg = defServiceConfig + mgr <- newManager tlsManagerSettings + void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content)))) + return (cfg, s3cfg, mgr) + teardown (cfg, s3cfg, mgr) = + void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket))) + + +------------------------------------------------------------------------------- +-- GetObject Tests +------------------------------------------------------------------------------- + + +test_get :: TestTree +test_get = askOption $ \(BucketOption bucket) -> testGroup "GetObject" + [ test_get_caching bucket + ] + + +test_get_caching :: Bucket -> TestTree +test_get_caching bucket = withResource mkSetup teardown $ \setup -> testGroup "Caches" + [ testCase "If-Matches match succeeds" $ do + (cfg, s3cfg, mgr) <- setup + void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just payloadMD5 })) + , testCase "If-Matches mismatch fails with 412" $ do + (cfg, s3cfg, mgr) <- setup + assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just (T.reverse payloadMD5) })) + , testCase "If-None-Match mismatch succeeds" $ do + (cfg, s3cfg, mgr) <- setup + void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just (T.reverse payloadMD5) })) + , testCase "If-None-Match match fails with 304" $ do + (cfg, s3cfg, mgr) <- setup + assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just payloadMD5 })) + ] + where + k = "s3-test-object" + content = "example" + payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533" + mkSetup = do + cfg <- baseConfiguration + let s3cfg = defServiceConfig + mgr <- newManager tlsManagerSettings + void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content)))) + return (cfg, s3cfg, mgr) + teardown (cfg, s3cfg, mgr) = + void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket))) + + +assertStatus :: Int -> IO a -> Assertion +assertStatus expectedStatus f = do + res <- catchJust selector + (Right <$> f) + (return . Left) + case res of + Right _ -> assertFailure ("Expected error with status " <> show expectedStatus <> ", but got success.") + Left _ -> return () + where + selector (StatusCodeException s _ _) + | statusCode s == expectedStatus = Just () + | otherwise = Nothing + selector _ = Nothing