diff --git a/Aws.hs b/Aws.hs --- a/Aws.hs +++ b/Aws.hs @@ -49,6 +49,7 @@ , IteratedTransaction -- * Credentials , Credentials(..) +, makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -212,12 +212,10 @@ liftIO $ logger cfg Debug $ T.pack $ "String to sign: " ++ show (sqStringToSign q) httpRequest <- liftIO $ queryToHttpRequest q liftIO $ logger cfg Debug $ T.pack $ "Host: " ++ show (HTTP.host httpRequest) - resp <- do - hresp <- HTTP.http httpRequest manager - forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $ do - logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'" - responseConsumer request metadataRef hresp - return resp + hresp <- HTTP.http httpRequest manager + forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $ + logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'" + responseConsumer request metadataRef hresp -- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests. -- diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -70,6 +70,7 @@ , IteratedTransaction(..) -- * Credentials , Credentials(..) +, makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile @@ -121,6 +122,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time +import qualified Data.Traversable as Traversable import Data.Typeable import Data.Word import qualified Network.HTTP.Conduit as HTTP @@ -245,6 +247,15 @@ instance Show Credentials where show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" +makeCredentials :: MonadIO io + => B.ByteString -- ^ AWS Access Key ID + -> B.ByteString -- ^ AWS Secret Access Key + -> io Credentials +makeCredentials accessKeyID secretAccessKey = liftIO $ do + v4SigningKeys <- newIORef [] + let iamToken = Nothing + return Credentials { .. } + -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. -- -- Value: //@/.aws-keys@ @@ -264,32 +275,29 @@ -- @keyName awsKeyID awsKeySecret@ loadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromFile file key = liftIO $ do - contents <- map T.words . T.lines <$> T.readFile file - ref <- newIORef [] - return $ do - [_key, keyID, secret] <- find (hasKey key) contents - return Credentials { accessKeyID = T.encodeUtf8 keyID - , secretAccessKey = T.encodeUtf8 secret - , v4SigningKeys = ref - , iamToken = Nothing - } - where - hasKey _ [] = False - hasKey k (k2 : _) = k == k2 + exists <- doesFileExist file + if exists + then do + contents <- map T.words . T.lines <$> T.readFile file + Traversable.sequence $ do + [_key, keyID, secret] <- find (hasKey key) contents + return (makeCredentials (T.encodeUtf8 keyID) (T.encodeUtf8 secret)) + else return Nothing + where + hasKey _ [] = False + hasKey k (k2 : _) = k == k2 -- | Load credentials from the environment variables @AWS_ACCESS_KEY_ID@ and @AWS_ACCESS_KEY_SECRET@ -- (or @AWS_SECRET_ACCESS_KEY@), if possible. loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment - ref <- newIORef [] let lk = flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY" - return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) - <*> (T.encodeUtf8 . T.pack <$> secret) - <*> return ref - <*> return Nothing) + Traversable.sequence + (makeCredentials <$> (T.encodeUtf8 . T.pack <$> keyID) + <*> (T.encodeUtf8 . T.pack <$> secret)) loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) loadCredentialsFromInstanceMetadata = liftIO $ HTTP.withManager $ \mgr -> @@ -341,10 +349,10 @@ Just cr -> return (Just cr) Nothing -> do - instcr <- loadCredentialsFromInstanceMetadata - case instcr of + filecr <- loadCredentialsFromFile file key + case filecr of Just cr -> return (Just cr) - Nothing -> loadCredentialsFromFile file key + Nothing -> loadCredentialsFromInstanceMetadata -- | Load credentials from environment variables if possible, or alternative from the default file with the default -- key name. diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -1,6 +1,7 @@ module Aws.S3.Commands ( module Aws.S3.Commands.CopyObject +, module Aws.S3.Commands.DeleteBucket , module Aws.S3.Commands.DeleteObject , module Aws.S3.Commands.DeleteObjects , module Aws.S3.Commands.GetBucket @@ -13,6 +14,7 @@ where import Aws.S3.Commands.CopyObject +import Aws.S3.Commands.DeleteBucket import Aws.S3.Commands.DeleteObject import Aws.S3.Commands.DeleteObjects import Aws.S3.Commands.GetBucket diff --git a/Aws/S3/Commands/DeleteBucket.hs b/Aws/S3/Commands/DeleteBucket.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/DeleteBucket.hs @@ -0,0 +1,40 @@ +module Aws.S3.Commands.DeleteBucket +where + +import Aws.Core +import Aws.S3.Core +import Data.ByteString.Char8 ({- IsString -}) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data DeleteBucket = DeleteBucket { dbBucket :: Bucket } + deriving (Show) + +data DeleteBucketResponse = DeleteBucketResponse {} + deriving (Show) + +-- | ServiceConfiguration: 'S3Configuration' +instance SignQuery DeleteBucket where + type ServiceConfiguration DeleteBucket = S3Configuration + signQuery DeleteBucket {..} = s3SignQuery S3Query { + s3QMethod = Delete + , s3QBucket = Just $ T.encodeUtf8 dbBucket + , s3QSubresources = [] + , s3QQuery = [] + , s3QContentType = Nothing + , s3QContentMd5 = Nothing + , s3QAmzHeaders = [] + , s3QOtherHeaders = [] + , s3QRequestBody = Nothing + , s3QObject = Nothing + } + +instance ResponseConsumer DeleteBucket DeleteBucketResponse where + type ResponseMetadata DeleteBucketResponse = S3Metadata + responseConsumer _ = s3ResponseConsumer $ \_ -> return DeleteBucketResponse + +instance Transaction DeleteBucket DeleteBucketResponse + +instance AsMemoryResponse DeleteBucketResponse where + type MemoryResponse DeleteBucketResponse = DeleteBucketResponse + loadToMemory = return diff --git a/Aws/S3/Commands/GetBucket.hs b/Aws/S3/Commands/GetBucket.hs --- a/Aws/S3/Commands/GetBucket.hs +++ b/Aws/S3/Commands/GetBucket.hs @@ -104,6 +104,9 @@ (True, Nothing, contents@(_:_)) -> Just $ request { gbMarker = Just $ objectKey $ last contents } (_, _, _ ) -> Nothing +instance ListResponse GetBucketResponse ObjectInfo where + listResponse = gbrContents + instance AsMemoryResponse GetBucketResponse where type MemoryResponse GetBucketResponse = GetBucketResponse loadToMemory = return diff --git a/Aws/Ses/Core.hs b/Aws/Ses/Core.hs --- a/Aws/Ses/Core.hs +++ b/Aws/Ses/Core.hs @@ -97,7 +97,7 @@ , sqAuthorization = Nothing , sqContentType = Nothing , sqContentMd5 = Nothing - , sqAmzHeaders = [("X-Amzn-Authorization", authorization)] + , sqAmzHeaders = amzHeaders , sqOtherHeaders = [] , sqBody = Nothing , sqStringToSign = stringToSign @@ -106,11 +106,16 @@ stringToSign = fmtRfc822Time (signatureTime sd) credentials = signatureCredentials sd accessKeyId = accessKeyID credentials - authorization = B.concat [ "AWS3-HTTPS AWSAccessKeyId=" - , accessKeyId - , ", Algorithm=HmacSHA256, Signature=" - , signature credentials HmacSHA256 stringToSign - ] + amzHeaders = catMaybes + [ Just ("X-Amzn-Authorization", authorization) + , ("x-amz-security-token",) `fmap` iamToken credentials + ] + authorization = B.concat + [ "AWS3-HTTPS AWSAccessKeyId=" + , accessKeyId + , ", Algorithm=HmacSHA256, Signature=" + , signature credentials HmacSHA256 stringToSign + ] query' = ("AWSAccessKeyId", accessKeyId) : query sesResponseConsumer :: (Cu.Cursor -> Response SesMetadata a) diff --git a/Examples/NukeBucket.hs b/Examples/NukeBucket.hs new file mode 100644 --- /dev/null +++ b/Examples/NukeBucket.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Aws +import qualified Aws.S3 as S3 +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import Data.Text (pack) +import Control.Monad ((<=<)) +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Conduit (withManager, responseBody) +import System.Environment (getArgs) + +main :: IO () +main = do + [bucket] <- fmap (map pack) getArgs + + {- Set up AWS credentials and the default configuration. -} + cfg <- Aws.baseConfiguration + let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery + + {- Set up a ResourceT region with an available HTTP manager. -} + withManager $ \mgr -> do + let src = Aws.awsIteratedSource cfg s3cfg mgr (S3.getBucket bucket) + let deleteObjects [] = return () + deleteObjects os = + do + let keys = map S3.objectKey os + liftIO $ putStrLn ("Deleting objects: " ++ show keys) + _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os)) + return () + src C.$$ CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO) + liftIO $ putStrLn ("Deleting bucket: " ++ show bucket) + _ <- Aws.pureAws cfg s3cfg mgr (S3.DeleteBucket bucket) + return () diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -90,6 +90,13 @@ ** 0.9 series +- 0.9.3 + - fix performance regression for loadCredentialsDefault + - add generic makeCredentials function + - add S3 DeleteBucket operation + - add S3 NukeBucket example + - SES: use security token if enabled (should allow using it with IAM roles on EC2 instances) + - 0.9.2 - Support for credentials from EC2 instance metadata (only S3 for now) - aeson 0.8 compatibility diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -1,5 +1,5 @@ Name: aws -Version: 0.9.2 +Version: 0.9.3 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 . Homepage: http://github.com/aristidb/aws @@ -20,7 +20,7 @@ Source-repository this type: git location: https://github.com/aristidb/aws.git - tag: 0.9.2 + tag: 0.9.3 Source-repository head type: git @@ -56,6 +56,7 @@ Aws.S3, Aws.S3.Commands, Aws.S3.Commands.CopyObject, + Aws.S3.Commands.DeleteBucket, Aws.S3.Commands.DeleteObject, Aws.S3.Commands.DeleteObjects, Aws.S3.Commands.GetBucket, @@ -166,6 +167,25 @@ http-conduit, conduit, conduit-extra + + Default-Language: Haskell2010 + +Executable NukeBucket + Main-is: NukeBucket.hs + Hs-source-dirs: Examples + + if !flag(Examples) + Buildable: False + else + Buildable: True + Build-depends: + base == 4.*, + aws, + http-conduit, + conduit, + conduit-extra, + text >=0.1, + transformers Default-Language: Haskell2010