[ { "path": ".ghci", "content": ":set -XRecordWildCards\n:set -XTypeFamilies\n:set -XMultiParamTypeClasses\n:set -XFlexibleContexts\n:set -XFlexibleInstances\n:set -XFunctionalDependencies\n:set -XDataKinds\n:set -XKindSignatures\n:set -XDeriveFunctor\n:set -XDeriveDataTypeable\n:set -XOverloadedStrings\n:set -XTupleSections\n:set -XScopedTypeVariables\n:set -XRank2Types" }, { "path": ".gitignore", "content": "*~\ndist/*\n*.swp\n/.cabal-sandbox\n/cabal.sandbox.config\ncloud-remote.pdf\n/.stack-work/\n" }, { "path": ".travis.yml", "content": "sudo: false\naddons:\n apt:\n sources:\n - hvr-ghc\n packages:\n - libgmp-dev\n - ghc-8.0.1\n - cabal-install-1.24\ninstall:\n - export PATH=/opt/cabal/1.24/bin:/opt/ghc/8.0.1/bin:$PATH\n - travis_retry cabal update\n - cabal install --only-dependencies -fexamples --enable-tests\nscript:\n - cabal configure -fexamples --enable-tests && cabal build\n" }, { "path": "Aws/Aws.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE BangPatterns #-}\n\nmodule Aws.Aws\n( -- * Logging\n LogLevel(..)\n, Logger\n, defaultLog\n -- * Configuration\n, Configuration(..)\n, baseConfiguration\n, dbgConfiguration\n -- * Transaction runners\n -- ** Safe runners\n, aws\n, awsRef\n, pureAws\n, memoryAws\n, simpleAws\n -- ** Unsafe runners\n, unsafeAws\n, unsafeAwsRef\n -- ** URI runners\n, awsUri\n -- * Iterated runners\n--, awsIteratedAll\n, awsIteratedSource\n, awsIteratedSource'\n, awsIteratedList\n, awsIteratedList'\n)\nwhere\n\nimport Aws.Core\nimport Control.Applicative\nimport Control.Monad\nimport qualified Control.Monad.Catch as E\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans\nimport Control.Monad.Trans.Resource\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Lazy as L\nimport qualified Data.CaseInsensitive as CI\nimport qualified Data.Conduit as C\nimport qualified Data.Conduit.List as CL\nimport Data.IORef\nimport Data.Monoid\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Data.Text.IO as T\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Client.TLS as HTTP\nimport System.IO (stderr)\nimport Prelude\n\n-- | The severity of a log message, in rising order.\ndata LogLevel\n = Debug\n | Info\n | Warning\n | Error\n deriving (Show, Eq, Ord)\n\n-- | The interface for any logging function. Takes log level and a log message, and can perform an arbitrary\n-- IO action.\ntype Logger = LogLevel -> T.Text -> IO ()\n\n-- | The default logger @defaultLog minLevel@, which prints log messages above level @minLevel@ to @stderr@.\ndefaultLog :: LogLevel -> Logger\ndefaultLog minLevel lev t | lev >= minLevel = T.hPutStrLn stderr $ T.concat [T.pack $ show lev, \": \", t]\n | otherwise = return ()\n\n-- | The configuration for an AWS request. You can use multiple configurations in parallel, even over the same HTTP\n-- connection manager.\ndata Configuration\n = Configuration {\n -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration\n -- (absolute or relative).\n timeInfo :: TimeInfo\n -- | AWS access credentials.\n , credentials :: Credentials\n -- | The error / message logger.\n , logger :: Logger\n , proxy :: Maybe HTTP.Proxy\n }\n\n-- | The default configuration, with credentials loaded from environment variable or configuration file\n-- (see 'loadCredentialsDefault').\nbaseConfiguration :: MonadIO io => io Configuration\nbaseConfiguration = liftIO $ do\n cr <- loadCredentialsDefault\n case cr of\n Nothing -> E.throwM $ NoCredentialsException \"could not locate aws credentials\"\n Just cr' -> return Configuration {\n timeInfo = Timestamp\n , credentials = cr'\n , logger = defaultLog Warning\n , proxy = Nothing\n }\n\n-- | Debug configuration, which logs much more verbosely.\ndbgConfiguration :: MonadIO io => io Configuration\ndbgConfiguration = do\n c <- baseConfiguration\n return c { logger = defaultLog Debug }\n\n-- | Run an AWS transaction, with HTTP manager and metadata wrapped in a 'Response'.\n--\n-- All errors are caught and wrapped in the 'Response' value.\n--\n-- Metadata is logged at level 'Info'.\n--\n-- Usage (with existing 'HTTP.Manager'):\n-- @\n-- resp <- aws cfg serviceCfg manager request\n-- @\naws :: (Transaction r a)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> r\n -> ResourceT IO (Response (ResponseMetadata a) a)\naws = unsafeAws\n\n-- | Run an AWS transaction, with HTTP manager and metadata returned in an 'IORef'.\n--\n-- Errors are not caught, and need to be handled with exception handlers.\n--\n-- Metadata is not logged.\n--\n-- Usage (with existing 'HTTP.Manager'):\n-- @\n-- ref <- newIORef mempty;\n-- resp <- awsRef cfg serviceCfg manager request\n-- @\n\n-- Unfortunately, the \";\" above seems necessary, as haddock does not want to split lines for me.\nawsRef :: (Transaction r a)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> IORef (ResponseMetadata a)\n -> r\n -> ResourceT IO a\nawsRef = unsafeAwsRef\n\n-- | Run an AWS transaction, with HTTP manager and without metadata.\n--\n-- Metadata is logged at level 'Info'.\n--\n-- Usage (with existing 'HTTP.Manager'):\n-- @\n-- resp <- aws cfg serviceCfg manager request\n-- @\npureAws :: (Transaction r a)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> r\n -> ResourceT IO a\npureAws cfg scfg mgr req = readResponseIO =<< aws cfg scfg mgr req\n\n-- | Run an AWS transaction, with HTTP manager and without metadata.\n--\n-- Metadata is logged at level 'Info'.\n--\n-- Usage (with existing 'HTTP.Manager'):\n-- @\n-- resp <- aws cfg serviceCfg manager request\n-- @\nmemoryAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> r\n -> io (MemoryResponse a)\nmemoryAws cfg scfg mgr req = liftIO $ runResourceT $ loadToMemory =<< readResponseIO =<< aws cfg scfg mgr req\n\n-- | Run an AWS transaction, /without/ HTTP manager and without metadata.\n--\n-- Metadata is logged at level 'Info'.\n--\n-- Note that this is potentially less efficient than using 'aws', because HTTP connections cannot be re-used.\n--\n-- Usage:\n-- @\n-- resp <- simpleAws cfg serviceCfg request\n-- @\nsimpleAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> r\n -> io (MemoryResponse a)\nsimpleAws cfg scfg request = liftIO $ runResourceT $ do\n manager <- liftIO HTTP.getGlobalManager\n loadToMemory =<< readResponseIO =<< aws cfg scfg manager request\n\n-- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.\n--\n-- This is especially useful for debugging and development, you should not have to use it in production.\n--\n-- All errors are caught and wrapped in the 'Response' value.\n--\n-- Metadata is wrapped in the Response, and also logged at level 'Info'.\nunsafeAws\n :: (ResponseConsumer r a,\n Loggable (ResponseMetadata a),\n SignQuery r) =>\n Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response (ResponseMetadata a) a)\nunsafeAws cfg scfg manager request = do\n metadataRef <- liftIO $ newIORef mempty\n\n let catchAll :: ResourceT IO a -> ResourceT IO (Either E.SomeException a)\n catchAll = E.handle (return . Left) . fmap Right\n\n resp <- catchAll $\n unsafeAwsRef cfg scfg manager metadataRef request\n metadata <- liftIO $ readIORef metadataRef\n liftIO $ logger cfg Info $ \"Response metadata: \" `mappend` toLogText metadata\n return $ Response metadata resp\n\n-- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.\n--\n-- This is especially useful for debugging and development, you should not have to use it in production.\n--\n-- Errors are not caught, and need to be handled with exception handlers.\n--\n-- Metadata is put in the 'IORef', but not logged.\nunsafeAwsRef\n :: (ResponseConsumer r a,\n SignQuery r) =>\n Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a\nunsafeAwsRef cfg info manager metadataRef request = do\n sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg\n let !q = {-# SCC \"unsafeAwsRef:signQuery\" #-} signQuery request info sd\n let logDebug = liftIO . logger cfg Debug . T.pack\n logDebug $ \"String to sign: \" ++ show (sqStringToSign q)\n !httpRequest <- {-# SCC \"unsafeAwsRef:httpRequest\" #-} liftIO $ do\n req <- queryToHttpRequest q\n return $ req { HTTP.proxy = proxy cfg }\n logDebug $ \"Host: \" ++ show (HTTP.host httpRequest)\n logDebug $ \"Path: \" ++ show (HTTP.path httpRequest)\n logDebug $ \"Query string: \" ++ show (HTTP.queryString httpRequest)\n logDebug $ \"Header: \" ++ show (HTTP.requestHeaders httpRequest)\n case HTTP.requestBody httpRequest of\n HTTP.RequestBodyLBS lbs -> logDebug $ \"Body: \" ++ show (L.take 1000 lbs)\n HTTP.RequestBodyBS bs -> logDebug $ \"Body: \" ++ show (B.take 1000 bs)\n _ -> return ()\n hresp <- {-# SCC \"unsafeAwsRef:http\" #-} HTTP.http httpRequest manager\n logDebug $ \"Response status: \" ++ show (HTTP.responseStatus hresp)\n forM_ (HTTP.responseHeaders hresp) $ \\(hname,hvalue) -> liftIO $\n logger cfg Debug $ T.decodeUtf8 $ \"Response header '\" `mappend` CI.original hname `mappend` \"': '\" `mappend` hvalue `mappend` \"'\"\n {-# SCC \"unsafeAwsRef:responseConsumer\" #-} responseConsumer httpRequest request metadataRef hresp\n\n-- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests.\n--\n-- Usage:\n-- @\n-- uri <- awsUri cfg request\n-- @\nawsUri :: (SignQuery request, MonadIO io)\n => Configuration -> ServiceConfiguration request UriOnlyQuery -> request -> io B.ByteString\nawsUri cfg info request = liftIO $ do\n let ti = timeInfo cfg\n cr = credentials cfg\n sd <- signatureData ti cr\n let q = signQuery request info sd\n logger cfg Debug $ T.pack $ \"String to sign: \" ++ show (sqStringToSign q)\n return $ queryToUri q\n\n{-\n-- | Run an iterated AWS transaction. May make multiple HTTP requests.\nawsIteratedAll :: (IteratedTransaction r a)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> r\n -> ResourceT IO (Response [ResponseMetadata a] a)\nawsIteratedAll cfg scfg manager req_ = go req_ Nothing\n where go request prevResp = do Response meta respAttempt <- aws cfg scfg manager request\n case maybeCombineIteratedResponse prevResp <$> respAttempt of\n f@(Failure _) -> return (Response [meta] f)\n s@(Success resp) ->\n case nextIteratedRequest request resp of\n Nothing ->\n return (Response [meta] s)\n Just nextRequest ->\n mapMetadata (meta:) `liftM` go nextRequest (Just resp)\n-}\n\nawsIteratedSource\n :: (IteratedTransaction r a)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> r\n -> forall i. C.ConduitT i (Response (ResponseMetadata a) a) (ResourceT IO) ()\nawsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_\n where\n run r = do\n res <- aws cfg scfg manager r\n a <- readResponseIO res\n return (a, res)\n\n\nawsIteratedList\n :: (IteratedTransaction r a, ListResponse a i)\n => Configuration\n -> ServiceConfiguration r NormalQuery\n -> HTTP.Manager\n -> r\n -> forall j. C.ConduitT j i (ResourceT IO) ()\nawsIteratedList cfg scfg manager req = awsIteratedList' run req\n where\n run r = readResponseIO =<< aws cfg scfg manager r\n\n\n-------------------------------------------------------------------------------\n-- | A more flexible version of 'awsIteratedSource' that uses a\n-- user-supplied run function. Useful for embedding AWS functionality\n-- within application specific monadic contexts.\nawsIteratedSource'\n :: (Monad m, IteratedTransaction r a)\n => (r -> m (a, b))\n -- ^ A runner function for executing transactions.\n -> r\n -- ^ An initial request\n -> forall i. C.ConduitT i b m ()\nawsIteratedSource' run r0 = go r0\n where\n go q = do\n (a, b) <- lift $ run q\n C.yield b\n case nextIteratedRequest q a of\n Nothing -> return ()\n Just q' -> go q'\n\n\n-------------------------------------------------------------------------------\n-- | A more flexible version of 'awsIteratedList' that uses a\n-- user-supplied run function. Useful for embedding AWS functionality\n-- within application specific monadic contexts.\nawsIteratedList'\n :: (Monad m, IteratedTransaction r b, ListResponse b c)\n => (r -> m b)\n -- ^ A runner function for executing transactions.\n -> r\n -- ^ An initial request\n -> forall i. C.ConduitT i c m ()\nawsIteratedList' run r0 =\n awsIteratedSource' run' r0 `C.fuse`\n CL.concatMap listResponse\n where\n dupl a = (a,a)\n run' r = dupl `liftM` run r\n" }, { "path": "Aws/Core.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Aws.Core\n( -- * Logging\n Loggable(..)\n -- * Response\n -- ** Metadata in responses\n, Response(..)\n, readResponse\n, readResponseIO\n, tellMetadata\n, tellMetadataRef\n, mapMetadata\n -- ** Response data consumers\n, HTTPResponseConsumer\n, ResponseConsumer(..)\n -- ** Memory response\n, AsMemoryResponse(..)\n -- ** List response\n, ListResponse(..)\n -- ** Exception types\n, XmlException(..)\n, HeaderException(..)\n, FormException(..)\n, NoCredentialsException(..)\n, throwStatusCodeException\n -- ** Response deconstruction helpers\n, readHex2\n -- *** XML\n, elContent\n, elCont\n, force\n, forceM\n, textReadBool\n, textReadInt\n, readInt\n, xmlCursorConsumer\n -- * Query\n, SignedQuery(..)\n, NormalQuery\n, UriOnlyQuery\n, queryToHttpRequest\n, queryToUri\n -- ** Expiration\n, TimeInfo(..)\n, AbsoluteTimeInfo(..)\n, fromAbsoluteTimeInfo\n, makeAbsoluteTimeInfo\n -- ** Signature\n, SignatureData(..)\n, signatureData\n, SignQuery(..)\n, AuthorizationHash(..)\n, amzHash\n, signature\n, credentialV4\n, authorizationV4\n, authorizationV4'\n, signatureV4\n -- ** Query construction helpers\n, queryList\n, awsBool\n, awsTrue\n, awsFalse\n, fmtTime\n, fmtRfc822Time\n, rfc822Time\n, fmtAmzTime\n, fmtTimeEpochSeconds\n, parseHttpDate\n, httpDate1\n, textHttpDate\n, iso8601UtcDate\n -- * Transactions\n, Transaction\n, IteratedTransaction(..)\n -- * Credentials\n, Credentials(..)\n, makeCredentials\n, credentialsDefaultFile\n, credentialsDefaultKey\n, loadCredentialsFromFile\n, loadCredentialsFromEnv\n, loadCredentialsFromInstanceMetadata\n, loadCredentialsFromEnvOrFile\n, loadCredentialsFromEnvOrFileOrInstanceMetadata\n, loadCredentialsDefault\n, anonymousCredentials\n -- * Service configuration\n, DefaultServiceConfiguration(..)\n -- * HTTP types\n, Protocol(..)\n, defaultPort\n, Method(..)\n, httpMethod\n)\nwhere\n\nimport Aws.Ec2.InstanceMetadata\nimport Aws.Network\nimport qualified Blaze.ByteString.Builder as Blaze\nimport Control.Applicative\nimport Control.Arrow\nimport qualified Control.Exception as E\nimport Control.Monad\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM))\nimport qualified Crypto.Hash as CH\nimport qualified Crypto.MAC.HMAC as CMH\nimport qualified Data.Aeson as A\nimport qualified Data.ByteArray as ByteArray\nimport Data.ByteString (ByteString)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Base16 as Base16\nimport qualified Data.ByteString.Base64 as Base64\nimport Data.ByteString.Char8 ({- IsString -})\nimport qualified Data.ByteString.Lazy as L\nimport qualified Data.ByteString.UTF8 as BU\nimport Data.Char\nimport Data.Conduit ((.|))\nimport qualified Data.Conduit as C\n#if MIN_VERSION_http_conduit(2,2,0)\nimport qualified Data.Conduit.Binary as CB\n#endif\nimport qualified Data.Conduit.List as CL\nimport Data.Kind\nimport Data.IORef\nimport Data.List\nimport qualified Data.Map as M\nimport Data.Maybe\nimport Data.Monoid\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Data.Text.IO as T\nimport Data.Time\nimport qualified Data.Traversable as Traversable\nimport Data.Typeable\nimport Data.Word\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Client.TLS as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport System.Directory\nimport System.Environment\nimport System.FilePath (())\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport qualified Text.XML as XML\nimport qualified Text.XML.Cursor as Cu\nimport Text.XML.Cursor hiding (force, forceM)\nimport Prelude\n-------------------------------------------------------------------------------\n\n-- | Types that can be logged (textually).\nclass Loggable a where\n toLogText :: a -> T.Text\n\n-- | A response with metadata. Can also contain an error response, or\n-- an internal error, via 'Attempt'.\n--\n-- Response forms a Writer-like monad.\ndata Response m a = Response { responseMetadata :: m\n , responseResult :: Either E.SomeException a }\n deriving (Show, Functor)\n\n-- | Read a response result (if it's a success response, fail otherwise).\nreadResponse :: MonadThrow n => Response m a -> n a\nreadResponse = either throwM return . responseResult\n\n-- | Read a response result (if it's a success response, fail otherwise). In MonadIO.\nreadResponseIO :: MonadIO io => Response m a -> io a\nreadResponseIO = liftIO . readResponse\n\n-- | An empty response with some metadata.\ntellMetadata :: m -> Response m ()\ntellMetadata m = Response m (return ())\n\n-- | Apply a function to the metadata.\nmapMetadata :: (m -> n) -> Response m a -> Response n a\nmapMetadata f (Response m a) = Response (f m) a\n\n--multiResponse :: Monoid m => Response m a -> Response [m] a ->\n\ninstance Monoid m => Applicative (Response m) where\n pure x = Response mempty (Right x)\n (<*>) = ap\n\ninstance Monoid m => Monad (Response m) where\n return = pure\n Response m1 (Left e) >>= _ = Response m1 (Left e)\n Response m1 (Right x) >>= f = let Response m2 y = f x\n in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too\n\ninstance Monoid m => MonadThrow (Response m) where\n throwM e = Response mempty (throwM e)\n\n-- | Add metadata to an 'IORef' (using 'mappend').\ntellMetadataRef :: Monoid m => IORef m -> m -> IO ()\ntellMetadataRef r m = modifyIORef r (`mappend` m)\n\n-- | A full HTTP response parser. Takes HTTP status, response headers, and response body.\ntype HTTPResponseConsumer a = HTTP.Response (C.ConduitM () ByteString (ResourceT IO) ())\n -> ResourceT IO a\n\n-- | Class for types that AWS HTTP responses can be parsed into.\n--\n-- The request is also passed for possibly required additional metadata.\n--\n-- Note that for debugging, there is an instance for 'L.ByteString'.\nclass Monoid (ResponseMetadata resp) => ResponseConsumer req resp where\n -- | Metadata associated with a response. Typically there is one\n -- metadata type for each AWS service.\n type ResponseMetadata resp\n\n -- | Response parser. Takes the corresponding AWS request, the derived\n -- @http-client@ request (for error reporting), an 'IORef' for metadata, and\n -- HTTP response data.\n responseConsumer :: HTTP.Request -> req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp\n\n-- | Does not parse response. For debugging.\ninstance ResponseConsumer r (HTTP.Response L.ByteString) where\n type ResponseMetadata (HTTP.Response L.ByteString) = ()\n responseConsumer _ _ _ resp = do\n bss <- C.runConduit $ HTTP.responseBody resp .| CL.consume\n return resp\n { HTTP.responseBody = L.fromChunks bss\n }\n\n-- | Class for responses that are fully loaded into memory\nclass AsMemoryResponse resp where\n type MemoryResponse resp :: Type\n loadToMemory :: resp -> ResourceT IO (MemoryResponse resp)\n\n-- | Responses that have one main list in them, and perhaps some decoration.\nclass ListResponse resp item | resp -> item where\n listResponse :: resp -> [item]\n\n\n-- | Associates a request type and a response type in a bi-directional way.\n--\n-- This allows the type-checker to infer the response type when given\n-- the request type and vice versa.\n--\n-- Note that the actual request generation and response parsing\n-- resides in 'SignQuery' and 'ResponseConsumer' respectively.\nclass (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a))\n => Transaction r a\n | r -> a\n\n-- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits.\nclass Transaction r a => IteratedTransaction r a | r -> a where\n nextIteratedRequest :: r -> a -> Maybe r\n\n-- | Signature version 4: ((region, service),(date,key))\ntype V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString))\n\n-- | AWS access credentials.\ndata Credentials\n = Credentials {\n -- | AWS Access Key ID.\n accessKeyID :: B.ByteString\n -- | AWS Secret Access Key.\n , secretAccessKey :: B.ByteString\n -- | Signing keys for signature version 4\n , v4SigningKeys :: IORef [V4Key]\n -- | Signed IAM token\n , iamToken :: Maybe B.ByteString\n -- | Set when the credentials are intended for anonymous access.\n , isAnonymousCredentials :: Bool\n }\ninstance Show Credentials where\n show c@(Credentials {}) = \"Credentials{accessKeyID=\" ++ show (accessKeyID c) ++ \",secretAccessKey=\" ++ show (secretAccessKey c) ++ \",iamToken=\" ++ show (iamToken c) ++ \"}\"\n\nmakeCredentials :: MonadIO io\n => B.ByteString -- ^ AWS Access Key ID\n -> B.ByteString -- ^ AWS Secret Access Key\n -> io Credentials\nmakeCredentials accessKeyID secretAccessKey = liftIO $ do\n v4SigningKeys <- newIORef []\n let iamToken = Nothing\n let isAnonymousCredentials = False\n return Credentials { .. }\n\n-- | The file where access credentials are loaded, when using 'loadCredentialsDefault'.\n-- May return 'Nothing' if @HOME@ is unset.\n--\n-- Value: //@/.aws-keys@\ncredentialsDefaultFile :: MonadIO io => io (Maybe FilePath)\ncredentialsDefaultFile = liftIO $ tryMaybe (( \".aws-keys\") <$> getHomeDirectory)\n\ntryMaybe :: IO a -> IO (Maybe a)\ntryMaybe action = E.catch (Just <$> action) f\n where\n f :: E.SomeException -> IO (Maybe a)\n f _ = return Nothing\n\n-- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'.\n--\n-- Value: @default@\ncredentialsDefaultKey :: T.Text\ncredentialsDefaultKey = \"default\"\n\n-- | Load credentials from a (text) file given a key name.\n--\n-- The file consists of a sequence of lines, each in the following format:\n--\n-- @keyName awsKeyID awsKeySecret@\nloadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials)\nloadCredentialsFromFile file key = liftIO $ do\n exists <- doesFileExist file\n if exists\n then do\n contents <- map T.words . T.lines <$> T.readFile file\n Traversable.sequence $ do\n [_key, keyID, secret] <- find (hasKey key) contents\n return (makeCredentials (T.encodeUtf8 keyID) (T.encodeUtf8 secret))\n else return Nothing\n where\n hasKey _ [] = False\n hasKey k (k2 : _) = k == k2\n\n-- | Load credentials from the environment variables @AWS_ACCESS_KEY_ID@ and @AWS_ACCESS_KEY_SECRET@\n-- (or @AWS_SECRET_ACCESS_KEY@), if possible.\nloadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials)\nloadCredentialsFromEnv = liftIO $ do\n env <- getEnvironment\n let lk = fmap (T.encodeUtf8 . T.pack) . flip lookup env\n keyID = lk \"AWS_ACCESS_KEY_ID\"\n secret = lk \"AWS_ACCESS_KEY_SECRET\" `mplus` lk \"AWS_SECRET_ACCESS_KEY\"\n setSession creds = creds { iamToken = lk \"AWS_SESSION_TOKEN\" }\n makeCredentials' k s = setSession <$> makeCredentials k s\n Traversable.sequence $ makeCredentials' <$> keyID <*> secret\n\nloadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials)\nloadCredentialsFromInstanceMetadata = do\n mgr <- liftIO HTTP.getGlobalManager\n -- check if the path is routable\n avail <- liftIO $ hostAvailable \"169.254.169.254\"\n if not avail\n then return Nothing\n else do\n info <- liftIO $ E.catch (getInstanceMetadata mgr \"latest/meta-data/iam\" \"info\" >>= return . Just) (\\(_ :: HTTP.HttpException) -> return Nothing)\n let infodict = info >>= A.decode :: Maybe (M.Map String String)\n info' = infodict >>= M.lookup \"InstanceProfileArn\"\n case info' of\n Just name ->\n do\n let name' = drop 1 $ dropWhile (/= '/') $ name\n creds <- liftIO $ E.catch (getInstanceMetadata mgr \"latest/meta-data/iam/security-credentials\" name' >>= return . Just) (\\(_ :: HTTP.HttpException) -> return Nothing)\n -- this token lasts ~6 hours\n let dict = creds >>= A.decode :: Maybe (M.Map String String)\n keyID = dict >>= M.lookup \"AccessKeyId\"\n secret = dict >>= M.lookup \"SecretAccessKey\"\n token = dict >>= M.lookup \"Token\"\n ref <- liftIO $ newIORef []\n return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID)\n <*> (T.encodeUtf8 . T.pack <$> secret)\n <*> return ref\n <*> (Just . T.encodeUtf8 . T.pack <$> token)\n <*> return False)\n Nothing -> return Nothing\n\n-- | Load credentials from environment variables if possible, or alternatively from a file with a given key name.\n--\n-- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details.\nloadCredentialsFromEnvOrFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials)\nloadCredentialsFromEnvOrFile file key =\n do\n envcr <- loadCredentialsFromEnv\n case envcr of\n Just cr -> return (Just cr)\n Nothing -> loadCredentialsFromFile file key\n\n-- | Load credentials from environment variables if possible, or alternatively from the instance metadata store, or alternatively from a file with a given key name.\n--\n-- See 'loadCredentialsFromEnv', 'loadCredentialsFromFile' and 'loadCredentialsFromInstanceMetadata' for details.\nloadCredentialsFromEnvOrFileOrInstanceMetadata :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials)\nloadCredentialsFromEnvOrFileOrInstanceMetadata file key =\n do\n envcr <- loadCredentialsFromEnv\n case envcr of\n Just cr -> return (Just cr)\n Nothing ->\n do\n filecr <- loadCredentialsFromFile file key\n case filecr of\n Just cr -> return (Just cr)\n Nothing -> loadCredentialsFromInstanceMetadata\n\n-- | Load credentials from environment variables if possible, or alternative from the default file with the default\n-- key name.\n--\n-- Default file: //@/.aws-keys@\n-- Default key name: @default@\n--\n-- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details.\nloadCredentialsDefault :: MonadIO io => io (Maybe Credentials)\nloadCredentialsDefault = do\n mfile <- credentialsDefaultFile\n case mfile of\n Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey\n Nothing -> loadCredentialsFromEnv\n\n-- | Make a dummy Credentials that can be used to access some AWS services\n-- anonymously.\nanonymousCredentials :: MonadIO io => io Credentials\nanonymousCredentials = do\n cr <- makeCredentials mempty mempty\n return (cr { isAnonymousCredentials = True })\n\n-- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols.\ndata Protocol\n = HTTP\n | HTTPS\n deriving (Eq,Read,Show,Ord,Typeable)\n\n-- | The default port to be used for a protocol if no specific port is specified.\ndefaultPort :: Protocol -> Int\ndefaultPort HTTP = 80\ndefaultPort HTTPS = 443\n\n-- | Request method. Not all request methods are supported by all services.\ndata Method\n = Head -- ^ HEAD method. Put all request parameters in a query string and HTTP headers.\n | Get -- ^ GET method. Put all request parameters in a query string and HTTP headers.\n | PostQuery -- ^ POST method. Put all request parameters in a query string and HTTP headers, but send the query string\n -- as a POST payload\n | Post -- ^ POST method. Sends a service- and request-specific request body.\n | Put -- ^ PUT method.\n | Delete -- ^ DELETE method.\n deriving (Show, Eq, Ord)\n\n-- | HTTP method associated with a request method.\nhttpMethod :: Method -> HTTP.Method\nhttpMethod Head = \"HEAD\"\nhttpMethod Get = \"GET\"\nhttpMethod PostQuery = \"POST\"\nhttpMethod Post = \"POST\"\nhttpMethod Put = \"PUT\"\nhttpMethod Delete = \"DELETE\"\n\n-- | A pre-signed medium-level request object.\ndata SignedQuery\n = SignedQuery {\n -- | Request method.\n sqMethod :: !Method\n -- | Protocol to be used.\n , sqProtocol :: !Protocol\n -- | HTTP host.\n , sqHost :: !B.ByteString\n -- | IP port.\n , sqPort :: !Int\n -- | HTTP path.\n , sqPath :: !B.ByteString\n -- | Query string list (used with 'Get' and 'PostQuery').\n , sqQuery :: !HTTP.Query\n -- | Request date/time.\n , sqDate :: !(Maybe UTCTime)\n -- | Authorization string (if applicable), for @Authorization@ header. See 'authorizationV4'\n , sqAuthorization :: !(Maybe (IO B.ByteString))\n -- | Request body content type.\n , sqContentType :: !(Maybe B.ByteString)\n -- | Request body content MD5.\n , sqContentMd5 :: !(Maybe (CH.Digest CH.MD5))\n -- | Additional Amazon \"amz\" headers.\n , sqAmzHeaders :: !HTTP.RequestHeaders\n -- | Additional non-\"amz\" headers.\n , sqOtherHeaders :: !HTTP.RequestHeaders\n -- | Request body (used with 'Post' and 'Put').\n , sqBody :: !(Maybe HTTP.RequestBody)\n -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes.\n , sqStringToSign :: !B.ByteString\n }\n --deriving (Show)\n\n-- | Create a HTTP request from a 'SignedQuery' object.\nqueryToHttpRequest :: SignedQuery -> IO HTTP.Request\nqueryToHttpRequest SignedQuery{..} = do\n mauth <- maybe (return Nothing) (Just<$>) sqAuthorization\n return $ HTTP.defaultRequest {\n HTTP.method = httpMethod sqMethod\n , HTTP.secure = case sqProtocol of\n HTTP -> False\n HTTPS -> True\n , HTTP.host = sqHost\n , HTTP.port = sqPort\n , HTTP.path = sqPath\n , HTTP.queryString =\n if sqMethod == PostQuery\n then \"\"\n else HTTP.renderQuery False sqQuery\n\n , HTTP.requestHeaders = catMaybes [ checkDate (\\d -> (\"Date\", fmtRfc822Time d)) sqDate\n , fmap (\\c -> (\"Content-Type\", c)) contentType\n , fmap (\\md5 -> (\"Content-MD5\", Base64.encode $ ByteArray.convert md5)) sqContentMd5\n , fmap (\\auth -> (\"Authorization\", auth)) mauth]\n ++ sqAmzHeaders\n ++ sqOtherHeaders\n , HTTP.requestBody =\n\n -- An explicitly defined body parameter should overwrite everything else.\n case sqBody of\n Just x -> x\n Nothing ->\n -- a POST query should convert its query string into the body\n case sqMethod of\n PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $\n HTTP.renderQueryBuilder False sqQuery\n _ -> HTTP.RequestBodyBuilder 0 mempty\n\n , HTTP.decompress = HTTP.alwaysDecompress\n#if MIN_VERSION_http_conduit(2,2,0)\n , HTTP.checkResponse = \\_ _ -> return ()\n#else\n , HTTP.checkStatus = \\_ _ _-> Nothing\n#endif\n\n , HTTP.redirectCount = 10\n }\n where\n checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup \"date\" sqOtherHeaders\n -- An explicitly defined content-type should override everything else.\n contentType = sqContentType `mplus` defContentType\n defContentType = case sqMethod of\n PostQuery -> Just \"application/x-www-form-urlencoded; charset=utf-8\"\n _ -> Nothing\n\n-- | Create a URI from a 'SignedQuery' object.\n--\n-- Unused / incompatible fields will be silently ignored.\nqueryToUri :: SignedQuery -> B.ByteString\nqueryToUri SignedQuery{..}\n = B.concat [\n case sqProtocol of\n HTTP -> \"http://\"\n HTTPS -> \"https://\"\n , sqHost\n , if sqPort == defaultPort sqProtocol then \"\" else T.encodeUtf8 . T.pack $ ':' : show sqPort\n , sqPath\n , HTTP.renderQuery True sqQuery\n ]\n\n-- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration\n-- (absolute or relative).\ndata TimeInfo\n = Timestamp -- ^ Use a simple timestamp to let AWS check the request validity.\n | ExpiresAt { fromExpiresAt :: UTCTime } -- ^ Let requests expire at a specific fixed time.\n | ExpiresIn { fromExpiresIn :: NominalDiffTime } -- ^ Let requests expire a specific number of seconds after they\n -- were generated.\n deriving (Show)\n\n-- | Like 'TimeInfo', but with all relative times replaced by absolute UTC.\ndata AbsoluteTimeInfo\n = AbsoluteTimestamp { fromAbsoluteTimestamp :: UTCTime }\n | AbsoluteExpires { fromAbsoluteExpires :: UTCTime }\n deriving (Show)\n\n-- | Just the UTC time value.\nfromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime\nfromAbsoluteTimeInfo (AbsoluteTimestamp time) = time\nfromAbsoluteTimeInfo (AbsoluteExpires time) = time\n\n-- | Convert 'TimeInfo' to 'AbsoluteTimeInfo' given the current UTC time.\nmakeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo\nmakeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now\nmakeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t\nmakeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now\n\n-- | Data that is always required for signing requests.\ndata SignatureData\n = SignatureData {\n -- | Expiration or timestamp.\n signatureTimeInfo :: AbsoluteTimeInfo\n -- | Current time.\n , signatureTime :: UTCTime\n -- | Access credentials.\n , signatureCredentials :: Credentials\n }\n\n-- | Create signature data using the current system time.\nsignatureData :: TimeInfo -> Credentials -> IO SignatureData\nsignatureData rti cr = do\n now <- getCurrentTime\n let ti = makeAbsoluteTimeInfo rti now\n return SignatureData { signatureTimeInfo = ti, signatureTime = now, signatureCredentials = cr }\n\n-- | Tag type for normal queries.\ndata NormalQuery\n-- | Tag type for URI-only queries.\ndata UriOnlyQuery\n\n-- | A \"signable\" request object. Assembles together the Query, and signs it in one go.\nclass SignQuery request where\n -- | Additional information, like API endpoints and service-specific preferences.\n type ServiceConfiguration request :: Type {- Query Type -} -> Type\n\n -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'.\n signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery\n\n-- | Supported crypto hashes for the signature.\ndata AuthorizationHash\n = HmacSHA1\n | HmacSHA256\n deriving (Show)\n\n-- | Authorization hash identifier as expected by Amazon.\namzHash :: AuthorizationHash -> B.ByteString\namzHash HmacSHA1 = \"HmacSHA1\"\namzHash HmacSHA256 = \"HmacSHA256\"\n\n-- | Create a signature. Usually, AWS wants a specifically constructed string to be signed.\n--\n-- The signature is a HMAC-based hash of the string and the secret access key.\nsignature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString\nsignature cr ah input = Base64.encode sig\n where\n sig = case ah of\n HmacSHA1 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA1)\n HmacSHA256 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA256)\n\n\n-- | Generates the Credential string, required for V4 signatures.\ncredentialV4\n :: SignatureData\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString\ncredentialV4 sd region service = B.concat\n [ accessKeyID (signatureCredentials sd)\n , \"/\"\n , date\n , \"/\"\n , region\n , \"/\"\n , service\n , \"/aws4_request\"\n ]\n where\n date = fmtTime \"%Y%m%d\" $ signatureTime sd\n\n-- | Use this to create the Authorization header to set into 'sqAuthorization'.\n-- See : you must create the\n-- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3.\nauthorizationV4 :: SignatureData\n -> AuthorizationHash\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target\n -> B.ByteString -- ^ canonicalRequest (before hashing)\n -> IO B.ByteString\nauthorizationV4 sd ah region service headers canonicalRequest = do\n let ref = v4SigningKeys $ signatureCredentials sd\n date = fmtTime \"%Y%m%d\" $ signatureTime sd\n\n -- Lookup existing signing key\n allkeys <- readIORef ref\n let mkey = case lookup (region,service) allkeys of\n Just (d,k) | d /= date -> Nothing\n | otherwise -> Just k\n Nothing -> Nothing\n\n -- possibly create a new signing key\n let createNewKey = atomicModifyIORef ref $ \\keylist ->\n let kSigning = signingKeyV4 sd ah region service\n lstK = (region,service)\n keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist\n in (keylist', kSigning)\n\n -- finally, return the header\n constructAuthorizationV4Header sd ah region service headers\n . signatureV4WithKey sd ah region service canonicalRequest\n <$> maybe createNewKey return mkey\n\n-- | IO free version of @authorizationV4@, use this if you need\n-- to compute the signature outside of IO.\nauthorizationV4'\n :: SignatureData\n -> AuthorizationHash\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target\n -> B.ByteString -- ^ canonicalRequest (before hashing)\n -> B.ByteString\nauthorizationV4' sd ah region service headers canonicalRequest\n = constructAuthorizationV4Header sd ah region service headers\n $ signatureV4 sd ah region service canonicalRequest\n\nconstructAuthorizationV4Header\n :: SignatureData\n -> AuthorizationHash\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target\n -> B.ByteString -- ^ signature\n -> B.ByteString\nconstructAuthorizationV4Header sd ah region service headers sig = B.concat\n [ alg\n , \" Credential=\"\n , credentialV4 sd region service\n , \",SignedHeaders=\"\n , headers\n , \",Signature=\"\n , sig\n ]\n where\n alg = case ah of\n HmacSHA1 -> \"AWS4-HMAC-SHA1\"\n HmacSHA256 -> \"AWS4-HMAC-SHA256\"\n\n-- | Compute the signature for V4\nsignatureV4WithKey\n :: SignatureData\n -> AuthorizationHash\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString -- ^ canonicalRequest (before hashing)\n -> B.ByteString -- ^ signing key\n -> B.ByteString\nsignatureV4WithKey sd ah region service canonicalRequest key = Base16.encode $ mkHmac key stringToSign\n where\n date = fmtTime \"%Y%m%d\" $ signatureTime sd\n mkHmac k i = case ah of\n HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1)\n HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256)\n mkHash i = case ah of\n HmacSHA1 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA1)\n HmacSHA256 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA256)\n alg = case ah of\n HmacSHA1 -> \"AWS4-HMAC-SHA1\"\n HmacSHA256 -> \"AWS4-HMAC-SHA256\"\n\n -- now do the signature\n canonicalRequestHash = Base16.encode $ mkHash canonicalRequest\n stringToSign = B.concat\n [ alg\n , \"\\n\"\n , fmtTime \"%Y%m%dT%H%M%SZ\" $ signatureTime sd\n , \"\\n\"\n , date\n , \"/\"\n , region\n , \"/\"\n , service\n , \"/aws4_request\\n\"\n , canonicalRequestHash\n ]\n\nsigningKeyV4\n :: SignatureData\n -> AuthorizationHash\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString\nsigningKeyV4 sd ah region service = kSigning\n where\n mkHmac k i = case ah of\n HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1)\n HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256)\n date = fmtTime \"%Y%m%d\" $ signatureTime sd\n secretKey = secretAccessKey $ signatureCredentials sd\n kDate = mkHmac (\"AWS4\" <> secretKey) date\n kRegion = mkHmac kDate region\n kService = mkHmac kRegion service\n kSigning = mkHmac kService \"aws4_request\"\n\nsignatureV4\n :: SignatureData\n -> AuthorizationHash\n -> B.ByteString -- ^ region, e.g. us-east-1\n -> B.ByteString -- ^ service, e.g. dynamodb\n -> B.ByteString -- ^ canonicalRequest (before hashing)\n -> B.ByteString\nsignatureV4 sd ah region service canonicalRequest\n = signatureV4WithKey sd ah region service canonicalRequest\n $ signingKeyV4 sd ah region service\n\n-- | Default configuration for a specific service.\nclass DefaultServiceConfiguration config where\n -- | Default service configuration.\n defServiceConfig :: config\n\n -- | Default debugging-only configuration. (Normally using HTTP instead of HTTPS for easier debugging.)\n debugServiceConfig :: config\n debugServiceConfig = defServiceConfig\n\n-- | @queryList f prefix xs@ constructs a query list from a list of\n-- elements @xs@, using a common prefix @prefix@, and a transformer\n-- function @f@.\n--\n-- A dot (@.@) is interspersed between prefix and generated key.\n--\n-- Example:\n--\n-- @queryList swap \\\"pfx\\\" [(\\\"a\\\", \\\"b\\\"), (\\\"c\\\", \\\"d\\\")]@ evaluates to @[(\\\"pfx.b\\\", \\\"a\\\"), (\\\"pfx.d\\\", \\\"c\\\")]@\n-- (except with ByteString instead of String, of course).\nqueryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)]\nqueryList f prefix xs = concat $ zipWith combine prefixList (map f xs)\n where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..]\n combine pf = map $ first (pf `dot`)\n dot x y = B.concat [x, BU.fromString \".\", y]\n\n-- | A \\\"true\\\"/\\\"false\\\" boolean as requested by some services.\nawsBool :: Bool -> B.ByteString\nawsBool True = \"true\"\nawsBool False = \"false\"\n\n-- | \\\"true\\\"\nawsTrue :: B.ByteString\nawsTrue = awsBool True\n\n-- | \\\"false\\\"\nawsFalse :: B.ByteString\nawsFalse = awsBool False\n\n-- | Format time according to a format string, as a ByteString.\nfmtTime :: String -> UTCTime -> B.ByteString\nfmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t\n\nrfc822Time :: String\nrfc822Time = \"%a, %0d %b %Y %H:%M:%S GMT\"\n\n-- | Format time in RFC 822 format.\nfmtRfc822Time :: UTCTime -> B.ByteString\nfmtRfc822Time = fmtTime rfc822Time\n\n-- | Format time in yyyy-mm-ddThh-mm-ss format.\nfmtAmzTime :: UTCTime -> B.ByteString\nfmtAmzTime = fmtTime \"%Y-%m-%dT%H:%M:%S\"\n\n-- | Format time as seconds since the Unix epoch.\nfmtTimeEpochSeconds :: UTCTime -> B.ByteString\nfmtTimeEpochSeconds = fmtTime \"%s\"\n\n-- | Parse HTTP-date (section 3.3.1 of RFC 2616)\nparseHttpDate :: String -> Maybe UTCTime\nparseHttpDate s = p \"%a, %d %b %Y %H:%M:%S GMT\" s -- rfc1123-date\n <|> p \"%A, %d-%b-%y %H:%M:%S GMT\" s -- rfc850-date\n <|> p \"%a %b %_d %H:%M:%S %Y\" s -- asctime-date\n <|> p \"%Y-%m-%dT%H:%M:%S%QZ\" s -- iso 8601\n <|> p \"%Y-%m-%dT%H:%M:%S%Q%Z\" s -- iso 8601\n where p = parseTimeM True defaultTimeLocale\n\n-- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style)\nhttpDate1 :: String\nhttpDate1 = \"%a, %d %b %Y %H:%M:%S GMT\" -- rfc1123-date\n\n-- | Format (as Text) HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style)\ntextHttpDate :: UTCTime -> T.Text\ntextHttpDate = T.pack . formatTime defaultTimeLocale httpDate1\n\niso8601UtcDate :: String\niso8601UtcDate = \"%Y-%m-%dT%H:%M:%S%QZ\"\n\n-- | Parse a two-digit hex number.\nreadHex2 :: [Char] -> Maybe Word8\nreadHex2 [c1,c2] = do n1 <- readHex1 c1\n n2 <- readHex1 c2\n return . fromIntegral $ n1 * 16 + n2\n where\n readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0'\n | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10\n | c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10\n readHex1 _ = Nothing\nreadHex2 _ = Nothing\n\n-- XML\n\n-- | An error that occurred during XML parsing / validation.\nnewtype XmlException = XmlException { xmlErrorMessage :: String }\n deriving (Show, Typeable)\n\ninstance E.Exception XmlException\n\n-- | An error that occurred during header parsing / validation.\nnewtype HeaderException = HeaderException { headerErrorMessage :: String }\n deriving (Show, Typeable)\n\ninstance E.Exception HeaderException\n\n-- | An error that occurred during form parsing / validation.\nnewtype FormException = FormException { formErrorMesage :: String }\n deriving (Show, Typeable)\n\ninstance E.Exception FormException\n\n-- | No credentials were found and an invariant was violated.\nnewtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMessage :: String }\n deriving (Show, Typeable)\n\ninstance E.Exception NoCredentialsException\n\n-- | A helper to throw an 'HTTP.StatusCodeException'.\nthrowStatusCodeException :: MonadThrow m => HTTP.Request -> HTTP.Response (C.ConduitM () ByteString m ()) -> m a\nthrowStatusCodeException req resp = do\n let resp' = fmap (const ()) resp\n -- only take first 10kB of error response\n body <- C.runConduit $ HTTP.responseBody resp .| CB.take (10*1024)\n let sce = HTTP.StatusCodeException resp' (L.toStrict body)\n throwM $ HTTP.HttpExceptionRequest req sce\n\n-- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents.\nelContent :: T.Text -> Cursor -> [T.Text]\nelContent name = laxElement name &/ content\n\n-- | Like 'elContent', but extracts 'String's instead of 'T.Text'.\nelCont :: T.Text -> Cursor -> [String]\nelCont name = laxElement name &/ content &| T.unpack\n\n-- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty.\nforce :: MonadThrow m => String -> [a] -> m a\nforce = Cu.force . XmlException\n\n-- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty.\nforceM :: MonadThrow m => String -> [m a] -> m a\nforceM = Cu.forceM . XmlException\n\n-- | Read a boolean from a 'T.Text', throwing an 'XmlException' on failure.\ntextReadBool :: MonadThrow m => T.Text -> m Bool\ntextReadBool s = case T.unpack s of\n \"true\" -> return True\n \"false\" -> return False\n _ -> throwM $ XmlException \"Invalid Bool\"\n\n-- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure.\ntextReadInt :: (MonadThrow m, Num a) => T.Text -> m a\ntextReadInt s = case reads $ T.unpack s of\n [(n,\"\")] -> return $ fromInteger n\n _ -> throwM $ XmlException \"Invalid Integer\"\n\n-- | Read an integer from a 'String', throwing an 'XmlException' on failure.\nreadInt :: (MonadThrow m, Num a) => String -> m a\nreadInt s = case reads s of\n [(n,\"\")] -> return $ fromInteger n\n _ -> throwM $ XmlException \"Invalid Integer\"\n\n-- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response\n-- body.\n--\n-- This function is highly recommended for any services that parse relatively short XML responses. (If status and response\n-- headers are required, simply take them as function parameters, and pass them through to this function.)\nxmlCursorConsumer ::\n (Monoid m)\n => (Cu.Cursor -> Response m a)\n -> IORef m\n -> HTTPResponseConsumer a\nxmlCursorConsumer parse metadataRef res\n = do doc <- C.runConduit $ HTTP.responseBody res .| XML.sinkDoc XML.def\n let cursor = Cu.fromDocument doc\n let Response metadata x = parse cursor\n liftIO $ tellMetadataRef metadataRef metadata\n case x of\n Left err -> liftIO $ throwM err\n Right v -> return v\n" }, { "path": "Aws/DynamoDb/Commands/BatchGetItem.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.BatchGetItem\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Justin Dawson \n-- Stability : experimental\n--\n-- @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_BatchGetItem.html@\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.BatchGetItem where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport qualified Data.HashMap.Strict as HM\nimport qualified Data.Text as T\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\nimport Aws.DynamoDb.Commands.GetItem\n-------------------------------------------------------------------------------\n\n\ndata GetRequestItem = GetRequestItem{\n griProjExpr :: Maybe T.Text\n , griConsistent ::Bool\n , griKeys :: [PrimaryKey] \n } deriving (Eq,Show,Read,Ord)\n\ndata BatchGetItem = BatchGetItem {\n bgRequests :: [(T.Text,GetRequestItem)]\n -- ^ Get Requests for a specified table\n , bgRetCons :: ReturnConsumption\n } deriving (Eq,Show,Read,Ord)\n\n-------------------------------------------------------------------------------\n\n-- | Construct a RequestItem .\nbatchGetRequestItem :: Maybe T.Text\n -- ^ Projection Expression\n -> Bool\n -- ^ Consistent Read\n -> [PrimaryKey]\n -- ^ Items to be deleted\n -> GetRequestItem\nbatchGetRequestItem expr consistent keys = GetRequestItem expr consistent keys\n\ntoBatchGet :: [GetItem] -> BatchGetItem\ntoBatchGet gs = BatchGetItem (convert gs) def\n\n where\n groupItems :: [GetItem]-> HM.HashMap T.Text [GetItem] -> HM.HashMap T.Text [GetItem]\n groupItems [] hm = hm\n groupItems (x:xs) hm = let key = giTableName x\n in groupItems xs (HM.insert key (x : (HM.lookupDefault [] key hm)) hm)\n \n convert :: [GetItem] -> [(T.Text,GetRequestItem)] \n convert gs' = let l = HM.toList $ groupItems gs' HM.empty\n -- Uses one GetItem to specify ProjectionExpression\n -- and ConsistentRead for the entire batch\n in map (\\(table,items@(i:_)) ->(table,GetRequestItem \n (T.intercalate \",\" <$> giAttrs i)\n (giConsistent i)\n (map giKey items)) ) l\n\n-- | Construct a BatchGetItem\nbatchGetItem :: [(T.Text, GetRequestItem)]\n -> BatchGetItem\nbatchGetItem reqs = BatchGetItem reqs def\n\n\ninstance ToJSON GetRequestItem where\n toJSON GetRequestItem{..} =\n (object $ maybe [] (return . (\"ProjectionExpression\" .=)) griProjExpr ++\n [\"ConsistentRead\" .= griConsistent\n , \"Keys\" .= griKeys])\n \n\ninstance ToJSON BatchGetItem where\n toJSON BatchGetItem{..} =\n object $\n [ \"RequestItems\" .= HM.fromList bgRequests\n , \"ReturnConsumedCapacity\" .= bgRetCons\n ]\n\ninstance FromJSON GetRequestItem where\n parseJSON (Object p) = do\n GetRequestItem <$> p .:? \"ProjectionExpression\"\n <*> p .: \"ConsistentRead\"\n <*> p .: \"Keys\"\n parseJSON _ = fail \"unable to parse GetRequestItem\"\n \n \ndata BatchGetItemResponse = BatchGetItemResponse {\n bgResponses :: [(T.Text, [Item])]\n , bgUnprocessed :: Maybe [(T.Text,GetRequestItem)]\n -- ^ Unprocessed Requests on failure\n , bgConsumed :: Maybe ConsumedCapacity\n -- ^ Amount of capacity consumed\n } deriving (Eq,Show,Read,Ord)\n\n\n\ninstance Transaction BatchGetItem BatchGetItemResponse\n\n\ninstance SignQuery BatchGetItem where\n type ServiceConfiguration BatchGetItem = DdbConfiguration\n signQuery gi = ddbSignQuery \"BatchGetItem\" gi\n\n\ninstance FromJSON BatchGetItemResponse where\n parseJSON (Object v) = BatchGetItemResponse\n <$> (HM.toList <$> (v .: \"Responses\"))\n <*> v .:? \"UnprocessedItems\"\n <*> v .:? \"ConsumedCapacity\"\n\n parseJSON _ = fail \"BatchGetItemResponse must be an object.\"\n\ninstance ResponseConsumer r BatchGetItemResponse where\n type ResponseMetadata BatchGetItemResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\ninstance AsMemoryResponse BatchGetItemResponse where\n type MemoryResponse BatchGetItemResponse = BatchGetItemResponse\n loadToMemory = return\n\n\n" }, { "path": "Aws/DynamoDb/Commands/BatchWriteItem.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.BatchWriteItem\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Justin Dawson \n-- Stability : experimental\n--\n-- @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_BatchWriteItem.html@\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.BatchWriteItem where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport qualified Data.Foldable as F (asum)\nimport qualified Data.HashMap.Strict as HM\nimport qualified Data.Text as T\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\nimport Aws.DynamoDb.Commands.PutItem\nimport Aws.DynamoDb.Commands.DeleteItem\n-------------------------------------------------------------------------------\n\n\ndata Request = PutRequest { prItem :: Item }\n | DeleteRequest {drKey :: PrimaryKey}\n deriving (Eq,Show,Read,Ord)\n\ndata BatchWriteItem = BatchWriteItem {\n bwRequests :: [(T.Text,[Request])]\n -- ^ Put or Delete Requests for a specified table\n , bwRetCons :: ReturnConsumption\n , bwRetMet :: ReturnItemCollectionMetrics\n } deriving (Eq,Show,Read,Ord)\n\n\n-------------------------------------------------------------------------------\n\ntoBatchWrite :: [PutItem]\n -> [DeleteItem]\n -> BatchWriteItem\ntoBatchWrite ps ds =BatchWriteItem maps def def \n where\n maps :: [(T.Text,[Request])]\n maps = let pMap = foldl (\\acc p -> let key = piTable p\n in HM.insert key (PutRequest (piItem p) : (HM.lookupDefault [] key acc)) acc) HM.empty ps \n totalMap = foldl (\\acc d -> let key = diTable d\n in HM.insert key (DeleteRequest (diKey d) : (HM.lookupDefault [] key acc)) acc) pMap ds\n in HM.toList totalMap\n-- | Construct a BatchWriteItem\nbatchWriteItem :: [(T.Text,[Request])]\n -> BatchWriteItem\nbatchWriteItem reqs = BatchWriteItem reqs def def\n\n\ninstance ToJSON Request where\n toJSON PutRequest{..} =\n object $\n [ \"PutRequest\" .= (object $ [\"Item\" .= prItem])\n ]\n toJSON DeleteRequest{..} =\n object $\n [ \"DeleteRequest\" .= (object $ [\"Key\" .= drKey])\n ]\n\ninstance ToJSON BatchWriteItem where\n toJSON BatchWriteItem{..} =\n object $\n [ \"RequestItems\" .= HM.fromList bwRequests\n , \"ReturnConsumedCapacity\" .= bwRetCons\n , \"ReturnItemCollectionMetrics\" .= bwRetMet\n ]\n\ninstance FromJSON Request where\n parseJSON = withObject \"PutRequest or DeleteRequest\" $ \\o ->\n \n F.asum [\n do\n pr <- o .: \"PutRequest\"\n i <- pr .: \"Item\"\n return $ PutRequest i ,\n do\n dr <- o .: \"DeleteRequest\"\n pk <- dr .: \"Key\"\n return $ DeleteRequest pk\n ]\n \ndata BatchWriteItemResponse = BatchWriteItemResponse {\n bwUnprocessed :: [(T.Text,[Request])]\n -- ^ Unprocessed Requests on failure\n , bwConsumed :: Maybe ConsumedCapacity\n -- ^ Amount of capacity consumed\n , bwColMet :: Maybe ItemCollectionMetrics\n -- ^ Collection metrics for tables affected by BatchWriteItem.\n } deriving (Eq,Show,Read,Ord)\n\n\n\ninstance Transaction BatchWriteItem BatchWriteItemResponse\n\n\ninstance SignQuery BatchWriteItem where\n type ServiceConfiguration BatchWriteItem = DdbConfiguration\n signQuery gi = ddbSignQuery \"BatchWriteItem\" gi\n\n\ninstance FromJSON BatchWriteItemResponse where\n parseJSON (Object v) = BatchWriteItemResponse\n <$> HM.toList <$> (v .: \"UnprocessedItems\")\n <*> v .:? \"ConsumedCapacity\"\n <*> v .:? \"ItemCollectionMetrics\"\n parseJSON _ = fail \"BatchWriteItemResponse must be an object.\"\n\n\ninstance ResponseConsumer r BatchWriteItemResponse where\n type ResponseMetadata BatchWriteItemResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse BatchWriteItemResponse where\n type MemoryResponse BatchWriteItemResponse = BatchWriteItemResponse\n loadToMemory = return\n" }, { "path": "Aws/DynamoDb/Commands/DeleteItem.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.DeleteItem\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n-- @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_DeleteItem.html@\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.DeleteItem where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport qualified Data.Text as T\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\ndata DeleteItem = DeleteItem {\n diTable :: T.Text\n -- ^ Target table\n , diKey :: PrimaryKey\n -- ^ The item to delete.\n , diExpect :: Conditions\n -- ^ (Possible) set of exceptions for a conditional Put\n , diReturn :: UpdateReturn\n -- ^ What to return from this query.\n , diRetCons :: ReturnConsumption\n , diRetMet :: ReturnItemCollectionMetrics\n } deriving (Eq,Show,Read,Ord)\n\n\n-------------------------------------------------------------------------------\n-- | Construct a minimal 'DeleteItem' request.\ndeleteItem :: T.Text\n -- ^ A Dynamo table name\n -> PrimaryKey\n -- ^ Item to be saved\n -> DeleteItem\ndeleteItem tn key = DeleteItem tn key def def def def\n\n\ninstance ToJSON DeleteItem where\n toJSON DeleteItem{..} =\n object $ expectsJson diExpect ++\n [ \"TableName\" .= diTable\n , \"Key\" .= diKey\n , \"ReturnValues\" .= diReturn\n , \"ReturnConsumedCapacity\" .= diRetCons\n , \"ReturnItemCollectionMetrics\" .= diRetMet\n ]\n\n\n\ndata DeleteItemResponse = DeleteItemResponse {\n dirAttrs :: Maybe Item\n -- ^ Old attributes, if requested\n , dirConsumed :: Maybe ConsumedCapacity\n -- ^ Amount of capacity consumed\n , dirColMet :: Maybe ItemCollectionMetrics\n -- ^ Collection metrics if they have been requested.\n } deriving (Eq,Show,Read,Ord)\n\n\n\ninstance Transaction DeleteItem DeleteItemResponse\n\n\ninstance SignQuery DeleteItem where\n type ServiceConfiguration DeleteItem = DdbConfiguration\n signQuery gi = ddbSignQuery \"DeleteItem\" gi\n\n\ninstance FromJSON DeleteItemResponse where\n parseJSON (Object v) = DeleteItemResponse\n <$> v .:? \"Attributes\"\n <*> v .:? \"ConsumedCapacity\"\n <*> v .:? \"ItemCollectionMetrics\"\n parseJSON _ = fail \"DeleteItemResponse must be an object.\"\n\n\ninstance ResponseConsumer r DeleteItemResponse where\n type ResponseMetadata DeleteItemResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse DeleteItemResponse where\n type MemoryResponse DeleteItemResponse = DeleteItemResponse\n loadToMemory = return\n\n\n\n\n\n\n\n\n" }, { "path": "Aws/DynamoDb/Commands/GetItem.hs", "content": "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.GetItem\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n--\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.GetItem where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport qualified Data.Text as T\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\n-- | A GetItem query that fetches a specific object from DDB.\n--\n-- See: @http://docs.aws.amazon.com/amazondynamodb/latest/developerguide/API_GetItem.html@\ndata GetItem = GetItem {\n giTableName :: T.Text\n , giKey :: PrimaryKey\n , giAttrs :: Maybe [T.Text]\n -- ^ Attributes to get. 'Nothing' grabs everything.\n , giConsistent :: Bool\n -- ^ Whether to issue a consistent read.\n , giRetCons :: ReturnConsumption\n -- ^ Whether to return consumption stats.\n } deriving (Eq,Show,Read,Ord)\n\n\n-------------------------------------------------------------------------------\n-- | Construct a minimal 'GetItem' request.\ngetItem\n :: T.Text -- ^ Table name\n -> PrimaryKey -- ^ Primary key\n -> GetItem\ngetItem tn k = GetItem tn k Nothing False def\n\n\n-- | Response to a 'GetItem' query.\ndata GetItemResponse = GetItemResponse {\n girItem :: Maybe Item\n , girConsumed :: Maybe ConsumedCapacity\n } deriving (Eq,Show,Read,Ord)\n\n\ninstance Transaction GetItem GetItemResponse\n\n\ninstance ToJSON GetItem where\n toJSON GetItem{..} = object $\n maybe [] (return . (\"AttributesToGet\" .=)) giAttrs ++\n [ \"TableName\" .= giTableName\n , \"Key\" .= giKey\n , \"ConsistentRead\" .= giConsistent\n , \"ReturnConsumedCapacity\" .= giRetCons\n ]\n\n\ninstance SignQuery GetItem where\n type ServiceConfiguration GetItem = DdbConfiguration\n signQuery gi = ddbSignQuery \"GetItem\" gi\n\n\n\ninstance FromJSON GetItemResponse where\n parseJSON (Object v) = GetItemResponse\n <$> v .:? \"Item\"\n <*> v .:? \"ConsumedCapacity\"\n parseJSON _ = fail \"GetItemResponse must be an object.\"\n\n\ninstance ResponseConsumer r GetItemResponse where\n type ResponseMetadata GetItemResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse GetItemResponse where\n type MemoryResponse GetItemResponse = GetItemResponse\n loadToMemory = return\n" }, { "path": "Aws/DynamoDb/Commands/PutItem.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.GetItem\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n-- @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_PutItem.html@\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.PutItem where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport qualified Data.Text as T\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\ndata PutItem = PutItem {\n piTable :: T.Text\n -- ^ Target table\n , piItem :: Item\n -- ^ An item to Put. Attributes here will replace what maybe under\n -- the key on DDB.\n , piExpect :: Conditions\n -- ^ (Possible) set of exceptions for a conditional Put\n , piReturn :: UpdateReturn\n -- ^ What to return from this query.\n , piRetCons :: ReturnConsumption\n , piRetMet :: ReturnItemCollectionMetrics\n } deriving (Eq,Show,Read,Ord)\n\n\n-------------------------------------------------------------------------------\n-- | Construct a minimal 'PutItem' request.\nputItem :: T.Text\n -- ^ A Dynamo table name\n -> Item\n -- ^ Item to be saved\n -> PutItem\nputItem tn it = PutItem tn it def def def def\n\n\ninstance ToJSON PutItem where\n toJSON PutItem{..} =\n object $ expectsJson piExpect ++\n [ \"TableName\" .= piTable\n , \"Item\" .= piItem\n , \"ReturnValues\" .= piReturn\n , \"ReturnConsumedCapacity\" .= piRetCons\n , \"ReturnItemCollectionMetrics\" .= piRetMet\n ]\n\n\n\ndata PutItemResponse = PutItemResponse {\n pirAttrs :: Maybe Item\n -- ^ Old attributes, if requested\n , pirConsumed :: Maybe ConsumedCapacity\n -- ^ Amount of capacity consumed\n , pirColMet :: Maybe ItemCollectionMetrics\n -- ^ Collection metrics if they have been requested.\n } deriving (Eq,Show,Read,Ord)\n\n\n\ninstance Transaction PutItem PutItemResponse\n\n\ninstance SignQuery PutItem where\n type ServiceConfiguration PutItem = DdbConfiguration\n signQuery gi = ddbSignQuery \"PutItem\" gi\n\n\ninstance FromJSON PutItemResponse where\n parseJSON (Object v) = PutItemResponse\n <$> v .:? \"Attributes\"\n <*> v .:? \"ConsumedCapacity\"\n <*> v .:? \"ItemCollectionMetrics\"\n parseJSON _ = fail \"PutItemResponse must be an object.\"\n\n\ninstance ResponseConsumer r PutItemResponse where\n type ResponseMetadata PutItemResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse PutItemResponse where\n type MemoryResponse PutItemResponse = PutItemResponse\n loadToMemory = return\n\n\n\n\n\n\n\n\n" }, { "path": "Aws/DynamoDb/Commands/Query.hs", "content": "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.Query\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n-- Implementation of Amazon DynamoDb Query command.\n--\n-- See: @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_Query.html@\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.Query\n ( Query (..)\n , Slice (..)\n , query\n , QueryResponse (..)\n ) where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport Data.Maybe\nimport qualified Data.Text as T\nimport Data.Typeable\nimport qualified Data.Vector as V\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\n-------------------------------------------------------------------------------\n-- | 'Slice' is the primary constraint in a 'Query' command, per AWS\n-- requirements.\n--\n-- All 'Query' commands must specify a hash attribute via 'DEq' and\n-- optionally provide a secondary range attribute.\ndata Slice = Slice {\n sliceHash :: Attribute\n -- ^ Hash value of the primary key or index being used\n , sliceCond :: Maybe Condition\n -- ^ An optional condition specified on the range component, if\n -- present, of the primary key or index being used.\n } deriving (Eq,Show,Read,Ord,Typeable)\n\n\n\n-- | A Query command that uses primary keys for an expedient scan.\ndata Query = Query {\n qTableName :: T.Text\n -- ^ Required.\n , qKeyConditions :: Slice\n -- ^ Required. Hash or hash-range main condition.\n , qFilter :: Conditions\n -- ^ Whether to filter results before returning to client\n , qStartKey :: Maybe [Attribute]\n -- ^ Exclusive start key to resume a previous query.\n , qLimit :: Maybe Int\n -- ^ Whether to limit result set size\n , qForwardScan :: Bool\n -- ^ Set to False for descending results\n , qSelect :: QuerySelect\n -- ^ What to return from 'Query'\n , qRetCons :: ReturnConsumption\n , qIndex :: Maybe T.Text\n -- ^ Whether to use a secondary/global index\n , qConsistent :: Bool\n } deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\ninstance ToJSON Query where\n toJSON Query{..} = object $\n catMaybes\n [ ((\"ExclusiveStartKey\" .= ) . attributesJson) <$> qStartKey\n , (\"Limit\" .= ) <$> qLimit\n , (\"IndexName\" .= ) <$> qIndex\n ] ++\n conditionsJson \"QueryFilter\" qFilter ++\n querySelectJson qSelect ++\n [ \"ScanIndexForward\" .= qForwardScan\n , \"TableName\".= qTableName\n , \"KeyConditions\" .= sliceJson qKeyConditions\n , \"ReturnConsumedCapacity\" .= qRetCons\n , \"ConsistentRead\" .= qConsistent\n ]\n\n\n-------------------------------------------------------------------------------\n-- | Construct a minimal 'Query' request.\nquery\n :: T.Text\n -- ^ Table name\n -> Slice\n -- ^ Primary key slice for query\n -> Query\nquery tn sl = Query tn sl def Nothing Nothing True def def Nothing False\n\n\n-- | Response to a 'Query' query.\ndata QueryResponse = QueryResponse {\n qrItems :: V.Vector Item\n , qrLastKey :: Maybe [Attribute]\n , qrCount :: Int\n , qrScanned :: Int\n , qrConsumed :: Maybe ConsumedCapacity\n } deriving (Eq,Show,Read,Ord)\n\n\ninstance FromJSON QueryResponse where\n parseJSON (Object v) = QueryResponse\n <$> v .:? \"Items\" .!= V.empty\n <*> ((do o <- v .: \"LastEvaluatedKey\"\n Just <$> parseAttributeJson o)\n <|> pure Nothing)\n <*> v .: \"Count\"\n <*> v .: \"ScannedCount\"\n <*> v .:? \"ConsumedCapacity\"\n parseJSON _ = fail \"QueryResponse must be an object.\"\n\n\ninstance Transaction Query QueryResponse\n\n\ninstance SignQuery Query where\n type ServiceConfiguration Query = DdbConfiguration\n signQuery gi = ddbSignQuery \"Query\" gi\n\n\ninstance ResponseConsumer r QueryResponse where\n type ResponseMetadata QueryResponse = DdbResponse\n responseConsumer _ _ ref resp\n = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse QueryResponse where\n type MemoryResponse QueryResponse = QueryResponse\n loadToMemory = return\n\n\ninstance ListResponse QueryResponse Item where\n listResponse = V.toList . qrItems\n\n\ninstance IteratedTransaction Query QueryResponse where\n nextIteratedRequest request response = case qrLastKey response of\n Nothing -> Nothing\n key -> Just request { qStartKey = key }\n\n\nsliceJson :: Slice -> Value\nsliceJson Slice{..} = object (map conditionJson cs)\n where\n cs = maybe [] return sliceCond ++ [hashCond]\n hashCond = Condition (attrName sliceHash) (DEq (attrVal sliceHash))\n" }, { "path": "Aws/DynamoDb/Commands/Scan.hs", "content": "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.Scan\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n-- Implementation of Amazon DynamoDb Scan command.\n--\n-- See: @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_Scan.html@\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.Scan\n ( Scan (..)\n , scan\n , ScanResponse (..)\n ) where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport Data.Default\nimport Data.Maybe\nimport qualified Data.Text as T\nimport Data.Typeable\nimport qualified Data.Vector as V\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\n-- | A Scan command that uses primary keys for an expedient scan.\ndata Scan = Scan {\n sTableName :: T.Text\n -- ^ Required.\n , sConsistentRead :: Bool\n -- ^ Whether to require a consistent read\n , sFilter :: Conditions\n -- ^ Whether to filter results before returning to client\n , sStartKey :: Maybe [Attribute]\n -- ^ Exclusive start key to resume a previous query.\n , sLimit :: Maybe Int\n -- ^ Whether to limit result set size\n , sIndex :: Maybe T.Text\n -- ^ Optional. Index to 'Scan'\n , sSelect :: QuerySelect\n -- ^ What to return from 'Scan'\n , sRetCons :: ReturnConsumption\n , sSegment :: Int\n -- ^ Segment number, starting at 0, for parallel queries.\n , sTotalSegments :: Int\n -- ^ Total number of parallel segments. 1 means sequential scan.\n } deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-- | Construct a minimal 'Scan' request.\nscan :: T.Text -- ^ Table name\n -> Scan\nscan tn = Scan tn False def Nothing Nothing Nothing def def 0 1\n\n\n-- | Response to a 'Scan' query.\ndata ScanResponse = ScanResponse {\n srItems :: V.Vector Item\n , srLastKey :: Maybe [Attribute]\n , srCount :: Int\n , srScanned :: Int\n , srConsumed :: Maybe ConsumedCapacity\n } deriving (Eq,Show,Read,Ord)\n\n\n-------------------------------------------------------------------------------\ninstance ToJSON Scan where\n toJSON Scan{..} = object $\n catMaybes\n [ ((\"ExclusiveStartKey\" .= ) . attributesJson) <$> sStartKey\n , (\"Limit\" .= ) <$> sLimit\n , (\"IndexName\" .= ) <$> sIndex\n ] ++\n conditionsJson \"ScanFilter\" sFilter ++\n querySelectJson sSelect ++\n [ \"TableName\".= sTableName\n , \"ReturnConsumedCapacity\" .= sRetCons\n , \"Segment\" .= sSegment\n , \"TotalSegments\" .= sTotalSegments\n , \"ConsistentRead\" .= sConsistentRead\n ]\n\n\ninstance FromJSON ScanResponse where\n parseJSON (Object v) = ScanResponse\n <$> v .:? \"Items\" .!= V.empty\n <*> ((do o <- v .: \"LastEvaluatedKey\"\n Just <$> parseAttributeJson o)\n <|> pure Nothing)\n <*> v .: \"Count\"\n <*> v .: \"ScannedCount\"\n <*> v .:? \"ConsumedCapacity\"\n parseJSON _ = fail \"ScanResponse must be an object.\"\n\n\ninstance Transaction Scan ScanResponse\n\n\ninstance SignQuery Scan where\n type ServiceConfiguration Scan = DdbConfiguration\n signQuery gi = ddbSignQuery \"Scan\" gi\n\n\ninstance ResponseConsumer r ScanResponse where\n type ResponseMetadata ScanResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse ScanResponse where\n type MemoryResponse ScanResponse = ScanResponse\n loadToMemory = return\n\ninstance ListResponse ScanResponse Item where\n listResponse = V.toList . srItems\n\ninstance IteratedTransaction Scan ScanResponse where\n nextIteratedRequest request response =\n case srLastKey response of\n Nothing -> Nothing\n key -> Just request { sStartKey = key }\n" }, { "path": "Aws/DynamoDb/Commands/Table.hs", "content": "{-# LANGUAGE DeriveGeneric #-}\n{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n{-# LANGUAGE TypeFamilies #-}\n\nmodule Aws.DynamoDb.Commands.Table\n ( -- * Commands\n CreateTable(..)\n , createTable\n , CreateTableResult(..)\n , DescribeTable(..)\n , DescribeTableResult(..)\n , UpdateTable(..)\n , UpdateTableResult(..)\n , DeleteTable(..)\n , DeleteTableResult(..)\n , ListTables(..)\n , ListTablesResult(..)\n\n -- * Data passed in the commands\n , AttributeType(..)\n , AttributeDefinition(..)\n , KeySchema(..)\n , Projection(..)\n , LocalSecondaryIndex(..)\n , LocalSecondaryIndexStatus(..)\n , ProvisionedThroughput(..)\n , ProvisionedThroughputStatus(..)\n , GlobalSecondaryIndex(..)\n , GlobalSecondaryIndexStatus(..)\n , GlobalSecondaryIndexUpdate(..)\n , TableDescription(..)\n ) where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson ((.!=), (.:), (.:?), (.=))\nimport qualified Data.Aeson as A\nimport qualified Data.Aeson.KeyMap as KM\nimport qualified Data.Aeson.Types as A\nimport Data.Char (toUpper)\nimport Data.Scientific (Scientific)\nimport qualified Data.Text as T\nimport Data.Time\nimport Data.Time.Clock.POSIX\nimport Data.Typeable\nimport qualified Data.Vector as V\nimport GHC.Generics (Generic)\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\ncapitalizeOpt :: A.Options\ncapitalizeOpt = A.defaultOptions\n { A.fieldLabelModifier = \\x -> case x of\n (c:cs) -> toUpper c : cs\n [] -> []\n }\n\n\ndropOpt :: Int -> A.Options\ndropOpt d = A.defaultOptions { A.fieldLabelModifier = drop d }\n\n\nconvertToUTCTime :: Scientific -> UTCTime\nconvertToUTCTime = posixSecondsToUTCTime . fromInteger . round\n\n\n-- | The type of a key attribute that appears in the table key or as a\n-- key in one of the indices.\ndata AttributeType = AttrString | AttrNumber | AttrBinary\n deriving (Show, Read, Ord, Typeable, Eq, Enum, Bounded, Generic)\n\ninstance A.ToJSON AttributeType where\n toJSON AttrString = A.String \"S\"\n toJSON AttrNumber = A.String \"N\"\n toJSON AttrBinary = A.String \"B\"\n\ninstance A.FromJSON AttributeType where\n parseJSON (A.String str) =\n case str of\n \"S\" -> return AttrString\n \"N\" -> return AttrNumber\n \"B\" -> return AttrBinary\n _ -> fail $ \"Invalid attribute type \" ++ T.unpack str\n parseJSON _ = fail \"Attribute type must be a string\"\n\n-- | A key attribute that appears in the table key or as a key in one of the indices.\ndata AttributeDefinition = AttributeDefinition {\n attributeName :: T.Text\n , attributeType :: AttributeType\n } deriving (Eq,Read,Ord,Show,Typeable,Generic)\n\ninstance A.ToJSON AttributeDefinition where\n toJSON = A.genericToJSON capitalizeOpt\n\ninstance A.FromJSON AttributeDefinition where\n parseJSON = A.genericParseJSON capitalizeOpt\n\n-- | The key schema can either be a hash of a single attribute name or a hash attribute name\n-- and a range attribute name.\ndata KeySchema = HashOnly T.Text\n | HashAndRange T.Text T.Text\n deriving (Eq,Read,Show,Ord,Typeable,Generic)\n\n\ninstance A.ToJSON KeySchema where\n toJSON (HashOnly a)\n = A.Array $ V.fromList [ A.object [ \"AttributeName\" .= a\n , \"KeyType\" .= (A.String \"HASH\")\n ]\n ]\n\n toJSON (HashAndRange hash range)\n = A.Array $ V.fromList [ A.object [ \"AttributeName\" .= hash\n , \"KeyType\" .= (A.String \"HASH\")\n ]\n , A.object [ \"AttributeName\" .= range\n , \"KeyType\" .= (A.String \"RANGE\")\n ]\n ]\n\ninstance A.FromJSON KeySchema where\n parseJSON (A.Array v) =\n case V.length v of\n 1 -> do obj <- A.parseJSON (v V.! 0)\n kt <- obj .: \"KeyType\"\n if kt /= (\"HASH\" :: T.Text)\n then fail \"With only one key, the type must be HASH\"\n else HashOnly <$> obj .: \"AttributeName\"\n\n 2 -> do hash <- A.parseJSON (v V.! 0)\n range <- A.parseJSON (v V.! 1)\n hkt <- hash .: \"KeyType\"\n rkt <- range .: \"KeyType\"\n if hkt /= (\"HASH\" :: T.Text) || rkt /= (\"RANGE\" :: T.Text)\n then fail \"With two keys, one must be HASH and the other RANGE\"\n else HashAndRange <$> hash .: \"AttributeName\"\n <*> range .: \"AttributeName\"\n _ -> fail \"Key schema must have one or two entries\"\n parseJSON _ = fail \"Key schema must be an array\"\n\n-- | This determines which attributes are projected into a secondary index.\ndata Projection = ProjectKeysOnly\n | ProjectAll\n | ProjectInclude [T.Text]\n deriving Show\ninstance A.ToJSON Projection where\n toJSON ProjectKeysOnly = A.object [ \"ProjectionType\" .= (\"KEYS_ONLY\" :: T.Text) ]\n toJSON ProjectAll = A.object [ \"ProjectionType\" .= (\"ALL\" :: T.Text) ]\n toJSON (ProjectInclude a) = A.object [ \"ProjectionType\" .= (\"INCLUDE\" :: T.Text)\n , \"NonKeyAttributes\" .= a\n ]\ninstance A.FromJSON Projection where\n parseJSON (A.Object o) = do\n ty <- (o .: \"ProjectionType\") :: A.Parser T.Text\n case ty of\n \"KEYS_ONLY\" -> return ProjectKeysOnly\n \"ALL\" -> return ProjectAll\n \"INCLUDE\" -> ProjectInclude <$> o .: \"NonKeyAttributes\"\n _ -> fail \"Invalid projection type\"\n parseJSON _ = fail \"Projection must be an object\"\n\n-- | Describes a single local secondary index. The KeySchema MUST\n-- share the same hash key attribute as the parent table, only the\n-- range key can differ.\ndata LocalSecondaryIndex\n = LocalSecondaryIndex {\n localIndexName :: T.Text\n , localKeySchema :: KeySchema\n , localProjection :: Projection\n }\n deriving (Show, Generic)\ninstance A.ToJSON LocalSecondaryIndex where\n toJSON = A.genericToJSON $ dropOpt 5\ninstance A.FromJSON LocalSecondaryIndex where\n parseJSON = A.genericParseJSON $ dropOpt 5\n\n-- | This is returned by AWS to describe the local secondary index.\ndata LocalSecondaryIndexStatus\n = LocalSecondaryIndexStatus {\n locStatusIndexName :: T.Text\n , locStatusIndexSizeBytes :: Integer\n , locStatusItemCount :: Integer\n , locStatusKeySchema :: KeySchema\n , locStatusProjection :: Projection\n }\n deriving (Show, Generic)\ninstance A.FromJSON LocalSecondaryIndexStatus where\n parseJSON = A.genericParseJSON $ dropOpt 9\n\n-- | The target provisioned throughput you are requesting for the table or global secondary index.\ndata ProvisionedThroughput\n = ProvisionedThroughput {\n readCapacityUnits :: Int\n , writeCapacityUnits :: Int\n }\n deriving (Show, Generic)\ninstance A.ToJSON ProvisionedThroughput where\n toJSON = A.genericToJSON capitalizeOpt\ninstance A.FromJSON ProvisionedThroughput where\n parseJSON = A.genericParseJSON capitalizeOpt\n\n-- | This is returned by AWS as the status of the throughput for a table or global secondary index.\ndata ProvisionedThroughputStatus\n = ProvisionedThroughputStatus {\n statusLastDecreaseDateTime :: UTCTime\n , statusLastIncreaseDateTime :: UTCTime\n , statusNumberOfDecreasesToday :: Int\n , statusReadCapacityUnits :: Int\n , statusWriteCapacityUnits :: Int\n }\n deriving (Show, Generic)\ninstance A.FromJSON ProvisionedThroughputStatus where\n parseJSON = A.withObject \"Throughput status must be an object\" $ \\o ->\n ProvisionedThroughputStatus\n <$> (convertToUTCTime <$> o .:? \"LastDecreaseDateTime\" .!= 0)\n <*> (convertToUTCTime <$> o .:? \"LastIncreaseDateTime\" .!= 0)\n <*> o .:? \"NumberOfDecreasesToday\" .!= 0\n <*> o .: \"ReadCapacityUnits\"\n <*> o .: \"WriteCapacityUnits\"\n\n-- | Describes a global secondary index.\ndata GlobalSecondaryIndex\n = GlobalSecondaryIndex {\n globalIndexName :: T.Text\n , globalKeySchema :: KeySchema\n , globalProjection :: Projection\n , globalProvisionedThroughput :: ProvisionedThroughput\n }\n deriving (Show, Generic)\ninstance A.ToJSON GlobalSecondaryIndex where\n toJSON = A.genericToJSON $ dropOpt 6\ninstance A.FromJSON GlobalSecondaryIndex where\n parseJSON = A.genericParseJSON $ dropOpt 6\n\n-- | This is returned by AWS to describe the status of a global secondary index.\ndata GlobalSecondaryIndexStatus\n = GlobalSecondaryIndexStatus {\n gStatusIndexName :: T.Text\n , gStatusIndexSizeBytes :: Integer\n , gStatusIndexStatus :: T.Text\n , gStatusItemCount :: Integer\n , gStatusKeySchema :: KeySchema\n , gStatusProjection :: Projection\n , gStatusProvisionedThroughput :: ProvisionedThroughputStatus\n }\n deriving (Show, Generic)\ninstance A.FromJSON GlobalSecondaryIndexStatus where\n parseJSON = A.genericParseJSON $ dropOpt 7\n\n-- | This is used to request a change in the provisioned throughput of\n-- a global secondary index as part of an 'UpdateTable' operation.\ndata GlobalSecondaryIndexUpdate\n = GlobalSecondaryIndexUpdate {\n gUpdateIndexName :: T.Text\n , gUpdateProvisionedThroughput :: ProvisionedThroughput\n }\n deriving (Show, Generic)\ninstance A.ToJSON GlobalSecondaryIndexUpdate where\n toJSON gi = A.object [\"Update\" .= A.genericToJSON (dropOpt 7) gi]\n\n-- | This describes the table and is the return value from AWS for all\n-- the table-related commands.\ndata TableDescription\n = TableDescription {\n rTableName :: T.Text\n , rTableSizeBytes :: Integer\n , rTableStatus :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE\n , rCreationDateTime :: Maybe UTCTime\n , rItemCount :: Integer\n , rAttributeDefinitions :: [AttributeDefinition]\n , rKeySchema :: Maybe KeySchema\n , rProvisionedThroughput :: ProvisionedThroughputStatus\n , rLocalSecondaryIndexes :: [LocalSecondaryIndexStatus]\n , rGlobalSecondaryIndexes :: [GlobalSecondaryIndexStatus]\n }\n deriving (Show, Generic)\n\ninstance A.FromJSON TableDescription where\n parseJSON = A.withObject \"Table must be an object\" $ \\o -> do\n t <- case (KM.lookup \"Table\" o, KM.lookup \"TableDescription\" o) of\n (Just (A.Object t), _) -> return t\n (_, Just (A.Object t)) -> return t\n _ -> fail \"Table description must have key 'Table' or 'TableDescription'\"\n TableDescription <$> t .: \"TableName\"\n <*> t .: \"TableSizeBytes\"\n <*> t .: \"TableStatus\"\n <*> (fmap convertToUTCTime <$> t .:? \"CreationDateTime\")\n <*> t .: \"ItemCount\"\n <*> t .:? \"AttributeDefinitions\" .!= []\n <*> t .:? \"KeySchema\"\n <*> t .: \"ProvisionedThroughput\"\n <*> t .:? \"LocalSecondaryIndexes\" .!= []\n <*> t .:? \"GlobalSecondaryIndexes\" .!= []\n\n{- Can't derive these instances onto the return values\ninstance ResponseConsumer r TableDescription where\n type ResponseMetadata TableDescription = DyMetadata\n responseConsumer _ _ _ = ddbResponseConsumer\ninstance AsMemoryResponse TableDescription where\n type MemoryResponse TableDescription = TableDescription\n loadToMemory = return\n-}\n\n-------------------------------------------------------------------------------\n--- Commands\n-------------------------------------------------------------------------------\n\ndata CreateTable = CreateTable {\n createTableName :: T.Text\n , createAttributeDefinitions :: [AttributeDefinition]\n -- ^ only attributes appearing in a key must be listed here\n , createKeySchema :: KeySchema\n , createProvisionedThroughput :: ProvisionedThroughput\n , createLocalSecondaryIndexes :: [LocalSecondaryIndex]\n -- ^ at most 5 local secondary indices are allowed\n , createGlobalSecondaryIndexes :: [GlobalSecondaryIndex]\n } deriving (Show, Generic)\n\ncreateTable :: T.Text -- ^ Table name\n -> [AttributeDefinition]\n -> KeySchema\n -> ProvisionedThroughput\n -> CreateTable\ncreateTable tn ad ks p = CreateTable tn ad ks p [] []\n\ninstance A.ToJSON CreateTable where\n toJSON ct = A.object $ m ++ lindex ++ gindex\n where\n m = [ \"TableName\" .= createTableName ct\n , \"AttributeDefinitions\" .= createAttributeDefinitions ct\n , \"KeySchema\" .= createKeySchema ct\n , \"ProvisionedThroughput\" .= createProvisionedThroughput ct\n ]\n -- AWS will error with 500 if (LocalSecondaryIndexes : []) is present in the JSON\n lindex = if null (createLocalSecondaryIndexes ct)\n then []\n else [ \"LocalSecondaryIndexes\" .= createLocalSecondaryIndexes ct ]\n gindex = if null (createGlobalSecondaryIndexes ct)\n then []\n else [ \"GlobalSecondaryIndexes\" .= createGlobalSecondaryIndexes ct ]\n\n--instance A.ToJSON CreateTable where\n-- toJSON = A.genericToJSON $ dropOpt 6\n\n\n-- | ServiceConfiguration: 'DdbConfiguration'\ninstance SignQuery CreateTable where\n type ServiceConfiguration CreateTable = DdbConfiguration\n signQuery = ddbSignQuery \"CreateTable\"\n\nnewtype CreateTableResult = CreateTableResult { ctStatus :: TableDescription }\n deriving (Show, A.FromJSON)\n-- ResponseConsumer and AsMemoryResponse can't be derived\ninstance ResponseConsumer r CreateTableResult where\n type ResponseMetadata CreateTableResult = DdbResponse\n responseConsumer _ _ = ddbResponseConsumer\ninstance AsMemoryResponse CreateTableResult where\n type MemoryResponse CreateTableResult = TableDescription\n loadToMemory = return . ctStatus\n\ninstance Transaction CreateTable CreateTableResult\n\ndata DescribeTable\n = DescribeTable {\n dTableName :: T.Text\n }\n deriving (Show, Generic)\ninstance A.ToJSON DescribeTable where\n toJSON = A.genericToJSON $ dropOpt 1\n\n-- | ServiceConfiguration: 'DdbConfiguration'\ninstance SignQuery DescribeTable where\n type ServiceConfiguration DescribeTable = DdbConfiguration\n signQuery = ddbSignQuery \"DescribeTable\"\n\nnewtype DescribeTableResult = DescribeTableResult { dtStatus :: TableDescription }\n deriving (Show, A.FromJSON)\n-- ResponseConsumer can't be derived\ninstance ResponseConsumer r DescribeTableResult where\n type ResponseMetadata DescribeTableResult = DdbResponse\n responseConsumer _ _ = ddbResponseConsumer\ninstance AsMemoryResponse DescribeTableResult where\n type MemoryResponse DescribeTableResult = TableDescription\n loadToMemory = return . dtStatus\n\ninstance Transaction DescribeTable DescribeTableResult\n\ndata UpdateTable\n = UpdateTable {\n updateTableName :: T.Text\n , updateProvisionedThroughput :: ProvisionedThroughput\n , updateGlobalSecondaryIndexUpdates :: [GlobalSecondaryIndexUpdate]\n }\n deriving (Show, Generic)\ninstance A.ToJSON UpdateTable where\n toJSON a = A.object\n $ \"TableName\" .= updateTableName a\n : \"ProvisionedThroughput\" .= updateProvisionedThroughput a\n : case updateGlobalSecondaryIndexUpdates a of\n [] -> []\n l -> [ \"GlobalSecondaryIndexUpdates\" .= l ]\n\n-- | ServiceConfiguration: 'DdbConfiguration'\ninstance SignQuery UpdateTable where\n type ServiceConfiguration UpdateTable = DdbConfiguration\n signQuery = ddbSignQuery \"UpdateTable\"\n\nnewtype UpdateTableResult = UpdateTableResult { uStatus :: TableDescription }\n deriving (Show, A.FromJSON)\n-- ResponseConsumer can't be derived\ninstance ResponseConsumer r UpdateTableResult where\n type ResponseMetadata UpdateTableResult = DdbResponse\n responseConsumer _ _ = ddbResponseConsumer\ninstance AsMemoryResponse UpdateTableResult where\n type MemoryResponse UpdateTableResult = TableDescription\n loadToMemory = return . uStatus\n\ninstance Transaction UpdateTable UpdateTableResult\n\ndata DeleteTable\n = DeleteTable {\n deleteTableName :: T.Text\n }\n deriving (Show, Generic)\ninstance A.ToJSON DeleteTable where\n toJSON = A.genericToJSON $ dropOpt 6\n\n-- | ServiceConfiguration: 'DdbConfiguration'\ninstance SignQuery DeleteTable where\n type ServiceConfiguration DeleteTable = DdbConfiguration\n signQuery = ddbSignQuery \"DeleteTable\"\n\nnewtype DeleteTableResult = DeleteTableResult { dStatus :: TableDescription }\n deriving (Show, A.FromJSON)\n-- ResponseConsumer can't be derived\ninstance ResponseConsumer r DeleteTableResult where\n type ResponseMetadata DeleteTableResult = DdbResponse\n responseConsumer _ _ = ddbResponseConsumer\ninstance AsMemoryResponse DeleteTableResult where\n type MemoryResponse DeleteTableResult = TableDescription\n loadToMemory = return . dStatus\n\ninstance Transaction DeleteTable DeleteTableResult\n\n-- | TODO: currently this does not support restarting a cutoff query because of size.\ndata ListTables = ListTables\n deriving (Show)\ninstance A.ToJSON ListTables where\n toJSON _ = A.object []\n-- | ServiceConfiguration: 'DdbConfiguration'\ninstance SignQuery ListTables where\n type ServiceConfiguration ListTables = DdbConfiguration\n signQuery = ddbSignQuery \"ListTables\"\n\nnewtype ListTablesResult\n = ListTablesResult {\n tableNames :: [T.Text]\n }\n deriving (Show, Generic)\ninstance A.FromJSON ListTablesResult where\n parseJSON = A.genericParseJSON capitalizeOpt\ninstance ResponseConsumer r ListTablesResult where\n type ResponseMetadata ListTablesResult = DdbResponse\n responseConsumer _ _ = ddbResponseConsumer\ninstance AsMemoryResponse ListTablesResult where\n type MemoryResponse ListTablesResult = [T.Text]\n loadToMemory = return . tableNames\n\ninstance Transaction ListTables ListTablesResult\n" }, { "path": "Aws/DynamoDb/Commands/UpdateItem.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeFamilies #-}\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Commands.UpdateItem\n-- Copyright : Soostone Inc\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n--\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Commands.UpdateItem\n ( UpdateItem(..)\n , updateItem\n , AttributeUpdate(..)\n , au\n , UpdateAction(..)\n , UpdateItemResponse(..)\n ) where\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport Data.Aeson\nimport qualified Data.Aeson.Key as AK\nimport Data.Default\nimport qualified Data.Text as T\nimport Prelude\n-------------------------------------------------------------------------------\nimport Aws.Core\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n\n\n-- | An @UpdateItem@ request.\ndata UpdateItem = UpdateItem {\n uiTable :: T.Text\n , uiKey :: PrimaryKey\n , uiUpdates :: [AttributeUpdate]\n , uiExpect :: Conditions\n -- ^ Conditional update - see DynamoDb documentation\n , uiReturn :: UpdateReturn\n , uiRetCons :: ReturnConsumption\n , uiRetMet :: ReturnItemCollectionMetrics\n } deriving (Eq,Show,Read,Ord)\n\n\n-------------------------------------------------------------------------------\n-- | Construct a minimal 'UpdateItem' request.\nupdateItem\n :: T.Text -- ^ Table name\n -> PrimaryKey -- ^ Primary key for item\n -> [AttributeUpdate] -- ^ Updates for this item\n -> UpdateItem\nupdateItem tn key ups = UpdateItem tn key ups def def def def\n\n\n-- | A helper to avoid overlapping instances for 'ToJSON'.\nnewtype AttributeUpdates = AttributeUpdates {\n getAttributeUpdates :: [AttributeUpdate]\n }\n\n\ndata AttributeUpdate = AttributeUpdate {\n auAttr :: Attribute\n -- ^ Attribute key-value\n , auAction :: UpdateAction\n -- ^ Type of update operation.\n } deriving (Eq,Show,Read,Ord)\n\n\ninstance DynSize AttributeUpdate where\n dynSize (AttributeUpdate a _) = dynSize a\n\n-------------------------------------------------------------------------------\n-- | Shorthand for the 'AttributeUpdate' constructor. Defaults to PUT\n-- for the update action.\nau :: Attribute -> AttributeUpdate\nau a = AttributeUpdate a def\n\n\ninstance ToJSON AttributeUpdates where\n toJSON = object . map mk . getAttributeUpdates\n where\n mk AttributeUpdate { auAction = UDelete, auAttr = auAttr } =\n (AK.fromText (attrName auAttr)) .= object\n [\"Action\" .= UDelete]\n mk AttributeUpdate { .. } = AK.fromText (attrName auAttr) .= object\n [\"Value\" .= (attrVal auAttr), \"Action\" .= auAction]\n\n\n-------------------------------------------------------------------------------\n-- | Type of attribute update to perform.\n--\n-- See AWS docs at:\n--\n-- @http:\\/\\/docs.aws.amazon.com\\/amazondynamodb\\/latest\\/APIReference\\/API_UpdateItem.html@\ndata UpdateAction\n = UPut -- ^ Simply write, overwriting any previous value\n | UAdd -- ^ Numerical add or add to set.\n | UDelete -- ^ Empty value: remove; Set value: Subtract from set.\n deriving (Eq,Show,Read,Ord)\n\n\ninstance ToJSON UpdateAction where\n toJSON UPut = String \"PUT\"\n toJSON UAdd = String \"ADD\"\n toJSON UDelete = String \"DELETE\"\n\n\ninstance Default UpdateAction where\n def = UPut\n\n\ninstance ToJSON UpdateItem where\n toJSON UpdateItem{..} =\n object $ expectsJson uiExpect ++\n [ \"TableName\" .= uiTable\n , \"Key\" .= uiKey\n , \"AttributeUpdates\" .= AttributeUpdates uiUpdates\n , \"ReturnValues\" .= uiReturn\n , \"ReturnConsumedCapacity\" .= uiRetCons\n , \"ReturnItemCollectionMetrics\" .= uiRetMet\n ]\n\n\ndata UpdateItemResponse = UpdateItemResponse {\n uirAttrs :: Maybe Item\n -- ^ Old attributes, if requested\n , uirConsumed :: Maybe ConsumedCapacity\n -- ^ Amount of capacity consumed\n } deriving (Eq,Show,Read,Ord)\n\n\n\ninstance Transaction UpdateItem UpdateItemResponse\n\n\ninstance SignQuery UpdateItem where\n type ServiceConfiguration UpdateItem = DdbConfiguration\n signQuery gi = ddbSignQuery \"UpdateItem\" gi\n\n\ninstance FromJSON UpdateItemResponse where\n parseJSON (Object v) = UpdateItemResponse\n <$> v .:? \"Attributes\"\n <*> v .:? \"ConsumedCapacity\"\n parseJSON _ = fail \"UpdateItemResponse expected a JSON object\"\n\n\ninstance ResponseConsumer r UpdateItemResponse where\n type ResponseMetadata UpdateItemResponse = DdbResponse\n responseConsumer _ _ ref resp = ddbResponseConsumer ref resp\n\n\ninstance AsMemoryResponse UpdateItemResponse where\n type MemoryResponse UpdateItemResponse = UpdateItemResponse\n loadToMemory = return\n\n\n\n\n\n\n\n\n" }, { "path": "Aws/DynamoDb/Commands.hs", "content": "module Aws.DynamoDb.Commands\n ( module Aws.DynamoDb.Commands.BatchGetItem\n , module Aws.DynamoDb.Commands.BatchWriteItem\n , module Aws.DynamoDb.Commands.DeleteItem\n , module Aws.DynamoDb.Commands.GetItem\n , module Aws.DynamoDb.Commands.PutItem\n , module Aws.DynamoDb.Commands.Query\n , module Aws.DynamoDb.Commands.Scan\n , module Aws.DynamoDb.Commands.Table\n , module Aws.DynamoDb.Commands.UpdateItem\n ) where\n\n-------------------------------------------------------------------------------\nimport Aws.DynamoDb.Commands.BatchGetItem\nimport Aws.DynamoDb.Commands.BatchWriteItem\nimport Aws.DynamoDb.Commands.DeleteItem\nimport Aws.DynamoDb.Commands.GetItem\nimport Aws.DynamoDb.Commands.PutItem\nimport Aws.DynamoDb.Commands.Query\nimport Aws.DynamoDb.Commands.Scan\nimport Aws.DynamoDb.Commands.Table\nimport Aws.DynamoDb.Commands.UpdateItem\n-------------------------------------------------------------------------------\n" }, { "path": "Aws/DynamoDb/Core.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE UndecidableInstances #-}\n\n-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynamoDb.Core\n-- Copyright : Soostone Inc, Chris Allen\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n-- Shared types and utilities for DyanmoDb functionality.\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb.Core\n (\n -- * Configuration and Regions\n Region (..)\n , ddbLocal\n , ddbUsEast1\n , ddbUsWest1\n , ddbUsWest2\n , ddbEuWest1\n , ddbEuWest2\n , ddbEuCentral1\n , ddbApNe1\n , ddbApSe1\n , ddbApSe2\n , ddbSaEast1\n , DdbConfiguration (..)\n\n -- * DynamoDB values\n , DValue (..)\n\n -- * Converting to/from 'DValue'\n , DynVal(..)\n , toValue, fromValue\n , Bin (..)\n , OldBool(..)\n\n -- * Defining new 'DynVal' instances\n , DynData(..)\n , DynBinary(..), DynNumber(..), DynString(..), DynBool(..)\n\n -- * Working with key/value pairs\n , Attribute (..)\n , parseAttributeJson\n , attributeJson\n , attributesJson\n\n , attrTuple\n , attr\n , attrAs\n , text, int, double\n , PrimaryKey (..)\n , hk\n , hrk\n\n -- * Working with objects (attribute collections)\n , Item\n , item\n , attributes\n , ToDynItem (..)\n , FromDynItem (..)\n , fromItem\n , Parser (..)\n , getAttr\n , getAttr'\n , parseAttr\n\n -- * Common types used by operations\n , Conditions (..)\n , conditionsJson\n , expectsJson\n\n , Condition (..)\n , conditionJson\n , CondOp (..)\n , CondMerge (..)\n , ConsumedCapacity (..)\n , ReturnConsumption (..)\n , ItemCollectionMetrics (..)\n , ReturnItemCollectionMetrics (..)\n , UpdateReturn (..)\n , QuerySelect (..)\n , querySelectJson\n\n -- * Size estimation\n , DynSize (..)\n , nullAttr\n\n -- * Responses & Errors\n , DdbResponse (..)\n , DdbErrCode (..)\n , shouldRetry\n , DdbError (..)\n\n -- * Internal Helpers\n , ddbSignQuery\n , AmazonError (..)\n , ddbResponseConsumer\n , ddbHttp\n , ddbHttps\n\n ) where\n\n\n-------------------------------------------------------------------------------\nimport Control.Applicative\nimport qualified Control.Exception as C\nimport Control.Monad\n#if MIN_VERSION_base(4,9,0)\nimport qualified Control.Monad.Fail as Fail\n#endif\nimport Control.Monad.Trans\nimport Control.Monad.Trans.Resource (throwM)\nimport qualified Crypto.Hash as CH\nimport Data.Aeson\nimport qualified Data.Aeson as A\nimport qualified Data.Aeson.Key as AK\nimport qualified Data.Aeson.KeyMap as KM\nimport Data.Aeson.Parser as A (json')\nimport Data.Aeson.Types (Pair, parseEither)\nimport qualified Data.Aeson.Types as A\nimport qualified Data.Attoparsec.ByteString as AttoB (endOfInput)\nimport qualified Data.Attoparsec.Text as Atto\nimport qualified Data.ByteArray as ByteArray\nimport qualified Data.ByteString.Base16 as Base16\nimport qualified Data.ByteString.Base64 as Base64\nimport qualified Data.ByteString.Char8 as B\nimport qualified Data.CaseInsensitive as CI\nimport Data.Conduit\nimport Data.Conduit.Attoparsec (sinkParser)\nimport Data.Default\nimport Data.Function (on)\nimport Data.Int\nimport Data.IORef\nimport Data.List\nimport qualified Data.Map as M\nimport Data.Maybe\nimport Data.Monoid ()\nimport qualified Data.Semigroup as Sem\nimport Data.Proxy\nimport Data.Scientific\nimport qualified Data.Serialize as Ser\nimport qualified Data.Set as S\nimport Data.String\nimport Data.Tagged\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport Data.Time\nimport Data.Typeable\nimport qualified Data.Vector as V\nimport Data.Word\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport Safe\n-------------------------------------------------------------------------------\nimport Aws.Core\n-------------------------------------------------------------------------------\n\n-------------------------------------------------------------------------------\n-- | Boolean values stored in DynamoDb. Only used in defining new\n-- 'DynVal' instances.\nnewtype DynBool = DynBool { unDynBool :: Bool }\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | Numeric values stored in DynamoDb. Only used in defining new\n-- 'DynVal' instances.\nnewtype DynNumber = DynNumber { unDynNumber :: Scientific }\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | String values stored in DynamoDb. Only used in defining new\n-- 'DynVal' instances.\nnewtype DynString = DynString { unDynString :: T.Text }\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | Binary values stored in DynamoDb. Only used in defining new\n-- 'DynVal' instances.\nnewtype DynBinary = DynBinary { unDynBinary :: B.ByteString }\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | An internally used closed typeclass for values that have direct\n-- DynamoDb representations. Based on AWS API, this is basically\n-- numbers, strings and binary blobs.\n--\n-- This is here so that any 'DynVal' haskell value can automatically\n-- be lifted to a list or a 'Set' without any instance code\n-- duplication.\n--\n-- Do not try to create your own instances.\nclass Ord a => DynData a where\n fromData :: a -> DValue\n toData :: DValue -> Maybe a\n\ninstance DynData DynBool where\n fromData (DynBool i) = DBool i\n toData (DBool i) = Just $ DynBool i\n toData (DNum i) = DynBool `fmap` do\n (i' :: Int) <- toIntegral i\n case i' of\n 0 -> return False\n 1 -> return True\n _ -> Nothing\n toData _ = Nothing\n\ninstance DynData (S.Set DynBool) where\n fromData set = DBoolSet (S.map unDynBool set)\n toData (DBoolSet i) = Just $ S.map DynBool i\n toData _ = Nothing\n\ninstance DynData DynNumber where\n fromData (DynNumber i) = DNum i\n toData (DNum i) = Just $ DynNumber i\n toData _ = Nothing\n\ninstance DynData (S.Set DynNumber) where\n fromData set = DNumSet (S.map unDynNumber set)\n toData (DNumSet i) = Just $ S.map DynNumber i\n toData _ = Nothing\n\ninstance DynData DynString where\n fromData (DynString i) = DString i\n toData (DString i) = Just $ DynString i\n toData _ = Nothing\n\ninstance DynData (S.Set DynString) where\n fromData set = DStringSet (S.map unDynString set)\n toData (DStringSet i) = Just $ S.map DynString i\n toData _ = Nothing\n\ninstance DynData DynBinary where\n fromData (DynBinary i) = DBinary i\n toData (DBinary i) = Just $ DynBinary i\n toData _ = Nothing\n\ninstance DynData (S.Set DynBinary) where\n fromData set = DBinSet (S.map unDynBinary set)\n toData (DBinSet i) = Just $ S.map DynBinary i\n toData _ = Nothing\n\ninstance DynData DValue where\n fromData = id\n toData = Just\n\n\n-------------------------------------------------------------------------------\n-- | Class of Haskell types that can be represented as DynamoDb values.\n--\n-- This is the conversion layer; instantiate this class for your own\n-- types and then use the 'toValue' and 'fromValue' combinators to\n-- convert in application code.\n--\n-- Each Haskell type instantiated with this class will map to a\n-- DynamoDb-supported type that most naturally represents it.\nclass DynData (DynRep a) => DynVal a where\n\n -- | Which of the 'DynData' instances does this data type directly\n -- map to?\n type DynRep a\n\n -- | Convert to representation\n toRep :: a -> DynRep a\n\n -- | Convert from representation\n fromRep :: DynRep a -> Maybe a\n\n\n-------------------------------------------------------------------------------\n-- | Any singular 'DynVal' can be upgraded to a list.\ninstance (DynData (DynRep [a]), DynVal a) => DynVal [a] where\n type DynRep [a] = S.Set (DynRep a)\n fromRep set = mapM fromRep $ S.toList set\n toRep as = S.fromList $ map toRep as\n\n\n-------------------------------------------------------------------------------\n-- | Any singular 'DynVal' can be upgraded to a 'Set'.\ninstance (DynData (DynRep (S.Set a)), DynVal a, Ord a) => DynVal (S.Set a) where\n type DynRep (S.Set a) = S.Set (DynRep a)\n fromRep set = fmap S.fromList . mapM fromRep $ S.toList set\n toRep as = S.map toRep as\n\n\ninstance DynVal DValue where\n type DynRep DValue = DValue\n fromRep = Just\n toRep = id\n\ninstance DynVal Bool where\n type DynRep Bool = DynBool\n fromRep (DynBool i) = Just i\n toRep i = DynBool i\n\ninstance DynVal Int where\n type DynRep Int = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Int8 where\n type DynRep Int8 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Int16 where\n type DynRep Int16 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Int32 where\n type DynRep Int32 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Int64 where\n type DynRep Int64 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Word8 where\n type DynRep Word8 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Word16 where\n type DynRep Word16 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Word32 where\n type DynRep Word32 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Word64 where\n type DynRep Word64 = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal Integer where\n type DynRep Integer = DynNumber\n fromRep (DynNumber i) = toIntegral i\n toRep i = DynNumber (fromIntegral i)\n\n\ninstance DynVal T.Text where\n type DynRep T.Text = DynString\n fromRep (DynString i) = Just i\n toRep i = DynString i\n\n\ninstance DynVal B.ByteString where\n type DynRep B.ByteString = DynBinary\n fromRep (DynBinary i) = Just i\n toRep i = DynBinary i\n\n\ninstance DynVal Double where\n type DynRep Double = DynNumber\n fromRep (DynNumber i) = Just $ toRealFloat i\n toRep i = DynNumber (fromFloatDigits i)\n\n\n-------------------------------------------------------------------------------\n-- | Encoded as number of days\ninstance DynVal Day where\n type DynRep Day = DynNumber\n fromRep (DynNumber i) = ModifiedJulianDay <$> (toIntegral i)\n toRep (ModifiedJulianDay i) = DynNumber (fromIntegral i)\n\n\n-------------------------------------------------------------------------------\n-- | Losslessly encoded via 'Integer' picoseconds\ninstance DynVal UTCTime where\n type DynRep UTCTime = DynNumber\n fromRep num = fromTS <$> fromRep num\n toRep x = toRep (toTS x)\n\n\n-------------------------------------------------------------------------------\npico :: Rational\npico = toRational $ (10 :: Integer) ^ (12 :: Integer)\n\n\n-------------------------------------------------------------------------------\ndayPico :: Integer\ndayPico = 86400 * round pico\n\n\n-------------------------------------------------------------------------------\n-- | Convert UTCTime to picoseconds\n--\n-- TODO: Optimize performance?\ntoTS :: UTCTime -> Integer\ntoTS (UTCTime (ModifiedJulianDay i) diff) = i' + diff'\n where\n diff' = floor (toRational diff * pico)\n i' = i * dayPico\n\n\n-------------------------------------------------------------------------------\n-- | Convert picoseconds to UTCTime\n--\n-- TODO: Optimize performance?\nfromTS :: Integer -> UTCTime\nfromTS i = UTCTime (ModifiedJulianDay days) diff\n where\n (days, secs) = i `divMod` dayPico\n diff = fromRational ((toRational secs) / pico)\n\n\n\n-- | Type wrapper for binary data to be written to DynamoDB. Wrap any\n-- 'Serialize' instance in there and 'DynVal' will know how to\n-- automatically handle conversions in binary form.\nnewtype Bin a = Bin { getBin :: a }\n deriving (Eq,Show,Read,Ord,Typeable,Enum)\n\n\ninstance (Ser.Serialize a) => DynVal (Bin a) where\n type DynRep (Bin a) = DynBinary\n toRep (Bin i) = DynBinary (Ser.encode i)\n fromRep (DynBinary i) = either (const Nothing) (Just . Bin) $\n Ser.decode i\n\nnewtype OldBool = OldBool Bool\n\ninstance DynVal OldBool where\n type DynRep OldBool = DynNumber\n fromRep (DynNumber i) = OldBool `fmap` do\n (i' :: Int) <- toIntegral i\n case i' of\n 0 -> return False\n 1 -> return True\n _ -> Nothing\n toRep (OldBool b) = DynNumber (if b then 1 else 0)\n\n\n-------------------------------------------------------------------------------\n-- | Encode a Haskell value.\ntoValue :: DynVal a => a -> DValue\ntoValue a = fromData $ toRep a\n\n\n-------------------------------------------------------------------------------\n-- | Decode a Haskell value.\nfromValue :: DynVal a => DValue -> Maybe a\nfromValue d = toData d >>= fromRep\n\n\ntoIntegral :: (Integral a, RealFrac a1) => a1 -> Maybe a\ntoIntegral sc = Just $ floor sc\n\n\n\n-- | Value types natively recognized by DynamoDb. We pretty much\n-- exactly reflect the AWS API onto Haskell types.\ndata DValue\n = DNull\n | DNum Scientific\n | DString T.Text\n | DBinary B.ByteString\n -- ^ Binary data will automatically be base64 marshalled.\n | DNumSet (S.Set Scientific)\n | DStringSet (S.Set T.Text)\n | DBinSet (S.Set B.ByteString)\n -- ^ Binary data will automatically be base64 marshalled.\n | DBool Bool\n | DBoolSet (S.Set Bool)\n -- ^ Composite data\n | DList (V.Vector DValue)\n | DMap (M.Map T.Text DValue)\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\ninstance IsString DValue where\n fromString t = DString (T.pack t)\n\n-------------------------------------------------------------------------------\n-- | Primary keys consist of either just a Hash key (mandatory) or a\n-- hash key and a range key (optional).\ndata PrimaryKey = PrimaryKey {\n pkHash :: Attribute\n , pkRange :: Maybe Attribute\n } deriving (Read,Show,Ord,Eq,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | Construct a hash-only primary key.\n--\n-- >>> hk \"user-id\" \"ABCD\"\n--\n-- >>> hk \"user-id\" (mkVal 23)\nhk :: T.Text -> DValue -> PrimaryKey\nhk k v = PrimaryKey (attr k v) Nothing\n\n\n-------------------------------------------------------------------------------\n-- | Construct a hash-and-range primary key.\nhrk :: T.Text -- ^ Hash key name\n -> DValue -- ^ Hash key value\n -> T.Text -- ^ Range key name\n -> DValue -- ^ Range key value\n -> PrimaryKey\nhrk k v k2 v2 = PrimaryKey (attr k v) (Just (attr k2 v2))\n\n\ninstance ToJSON PrimaryKey where\n toJSON (PrimaryKey h Nothing) = toJSON h\n toJSON (PrimaryKey h (Just r)) =\n let Object p1 = toJSON h\n Object p2 = toJSON r\n in Object (p1 `KM.union` p2)\n\ninstance FromJSON PrimaryKey where\n parseJSON p = do\n l <- listPKey p\n case length l of\n 1 -> return $ head l \n _ -> fail \"Unable to parse PrimaryKey\" \n where listPKey p'= map (\\(k,dval)-> hk (AK.toText k) dval)\n . KM.toList <$> parseJSON p'\n\n\n-- | A key-value pair\ndata Attribute = Attribute {\n attrName :: T.Text\n , attrVal :: DValue\n } deriving (Read,Show,Ord,Eq,Typeable)\n\n\n-- | Convert attribute to a tuple representation\nattrTuple :: Attribute -> (T.Text, DValue)\nattrTuple (Attribute a b) = (a,b)\n\n\n-- | Convenience function for constructing key-value pairs\nattr :: DynVal a => T.Text -> a -> Attribute\nattr k v = Attribute k (toValue v)\n\n\n-- | 'attr' with type witness to help with cases where you're manually\n-- supplying values in code.\n--\n-- >> item [ attrAs text \"name\" \"john\" ]\nattrAs :: DynVal a => Proxy a -> T.Text -> a -> Attribute\nattrAs _ k v = attr k v\n\n\n-- | Type witness for 'Text'. See 'attrAs'.\ntext :: Proxy T.Text\ntext = Proxy\n\n\n-- | Type witness for 'Integer'. See 'attrAs'.\nint :: Proxy Integer\nint = Proxy\n\n\n-- | Type witness for 'Double'. See 'attrAs'.\ndouble :: Proxy Double\ndouble = Proxy\n\n\n-- | A DynamoDb object is simply a key-value dictionary.\ntype Item = M.Map T.Text DValue\n\n\n-------------------------------------------------------------------------------\n-- | Pack a list of attributes into an Item.\nitem :: [Attribute] -> Item\nitem = M.fromList . map attrTuple\n\n\n-------------------------------------------------------------------------------\n-- | Unpack an 'Item' into a list of attributes.\nattributes :: M.Map T.Text DValue -> [Attribute]\nattributes = map (\\ (k, v) -> Attribute k v) . M.toList\n\n\nshowT :: Show a => a -> T.Text\nshowT = T.pack . show\n\n\ninstance ToJSON DValue where\n toJSON DNull = object [\"NULL\" .= True]\n toJSON (DNum i) = object [\"N\" .= showT i]\n toJSON (DString i) = object [\"S\" .= i]\n toJSON (DBinary i) = object [\"B\" .= (T.decodeUtf8 $ Base64.encode i)]\n toJSON (DNumSet i) = object [\"NS\" .= map showT (S.toList i)]\n toJSON (DStringSet i) = object [\"SS\" .= S.toList i]\n toJSON (DBinSet i) = object [\"BS\" .= map (T.decodeUtf8 . Base64.encode) (S.toList i)]\n toJSON (DBool i) = object [\"BOOL\" .= i]\n toJSON (DList i) = object [\"L\" .= i]\n toJSON (DMap i) = object [\"M\" .= i]\n toJSON x = error $ \"aws: bug: DynamoDB can't handle \" ++ show x\n\n\ninstance FromJSON DValue where\n parseJSON o = do\n (obj :: [(T.Text, Value)]) <- M.toList `liftM` parseJSON o\n case obj of\n [(\"NULL\", _)] -> return DNull\n [(\"N\", numStr)] -> DNum <$> parseScientific numStr\n [(\"S\", str)] -> DString <$> parseJSON str\n [(\"B\", bin)] -> do\n res <- (Base64.decode . T.encodeUtf8) <$> parseJSON bin\n either fail (return . DBinary) res\n [(\"NS\", s)] -> do xs <- mapM parseScientific =<< parseJSON s\n return $ DNumSet $ S.fromList xs\n [(\"SS\", s)] -> DStringSet <$> parseJSON s\n [(\"BS\", s)] -> do\n xs <- mapM (either fail return . Base64.decode . T.encodeUtf8)\n =<< parseJSON s\n return $ DBinSet $ S.fromList xs\n [(\"BOOL\", b)] -> DBool <$> parseJSON b\n [(\"L\", attrs)] -> DList <$> parseJSON attrs\n [(\"M\", attrs)] -> DMap <$> parseJSON attrs\n\n x -> fail $ \"aws: unknown dynamodb value: \" ++ show x\n\n where\n parseScientific (String str) =\n case Atto.parseOnly Atto.scientific str of\n Left e -> fail (\"parseScientific failed: \" ++ e)\n Right a -> return a\n parseScientific (Number n) = return n\n parseScientific _ = fail \"Unexpected JSON type in parseScientific\"\n\n\ninstance ToJSON Attribute where\n toJSON a = object $ [attributeJson a]\n\n\n-------------------------------------------------------------------------------\n-- | Parse a JSON object that contains attributes\nparseAttributeJson :: Value -> A.Parser [Attribute]\nparseAttributeJson (Object v) = mapM conv $ KM.toList v\n where\n conv (k, o) = Attribute (AK.toText k) <$> parseJSON o\nparseAttributeJson _ = error \"Attribute JSON must be an Object\"\n\n\n-- | Convert into JSON object for AWS.\nattributesJson :: [Attribute] -> Value\nattributesJson as = object $ map attributeJson as\n\n\n-- | Convert into JSON pair\nattributeJson :: Attribute -> Pair\nattributeJson (Attribute nm v) = AK.fromText nm .= v\n\n\n-------------------------------------------------------------------------------\n-- | Errors defined by AWS.\ndata DdbErrCode\n = AccessDeniedException\n | ConditionalCheckFailedException\n | IncompleteSignatureException\n | InvalidSignatureException\n | LimitExceededException\n | MissingAuthenticationTokenException\n | ProvisionedThroughputExceededException\n | ResourceInUseException\n | ResourceNotFoundException\n | ThrottlingException\n | ValidationException\n | RequestTooLarge\n | InternalFailure\n | InternalServerError\n | ServiceUnavailableException\n | SerializationException\n -- ^ Raised by AWS when the request JSON is missing fields or is\n -- somehow malformed.\n deriving (Read,Show,Eq,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | Whether the action should be retried based on the received error.\nshouldRetry :: DdbErrCode -> Bool\nshouldRetry e = go e\n where\n go LimitExceededException = True\n go ProvisionedThroughputExceededException = True\n go ResourceInUseException = True\n go ThrottlingException = True\n go InternalFailure = True\n go InternalServerError = True\n go ServiceUnavailableException = True\n go _ = False\n\n\n-------------------------------------------------------------------------------\n-- | Errors related to this library.\ndata DdbLibraryError\n = UnknownDynamoErrCode T.Text\n -- ^ A DynamoDB error code we do not know about.\n | JsonProtocolError Value T.Text\n -- ^ A JSON response we could not parse.\n deriving (Show,Eq,Typeable)\n\n\n-- | Potential errors raised by DynamoDB\ndata DdbError = DdbError {\n ddbStatusCode :: Int\n -- ^ 200 if successful, 400 for client errors and 500 for\n -- server-side errors.\n , ddbErrCode :: DdbErrCode\n , ddbErrMsg :: T.Text\n } deriving (Show,Eq,Typeable)\n\n\ninstance C.Exception DdbError\ninstance C.Exception DdbLibraryError\n\n\n-- | Response metadata that is present in every DynamoDB response.\ndata DdbResponse = DdbResponse {\n ddbrCrc :: Maybe T.Text\n , ddbrMsgId :: Maybe T.Text\n }\n\n\ninstance Loggable DdbResponse where\n toLogText (DdbResponse id2 rid) =\n \"DynamoDB: request ID=\" `mappend`\n fromMaybe \"\" rid `mappend`\n \", x-amz-id-2=\" `mappend`\n fromMaybe \"\" id2\n\ninstance Sem.Semigroup DdbResponse where\n a <> b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b)\n\ninstance Monoid DdbResponse where\n mempty = DdbResponse Nothing Nothing\n mappend = (Sem.<>)\n\n\ndata Region = Region {\n rUri :: B.ByteString\n , rName :: B.ByteString\n } deriving (Eq,Show,Read,Typeable)\n\n\ndata DdbConfiguration qt = DdbConfiguration {\n ddbcRegion :: Region\n -- ^ The regional endpoint. Ex: 'ddbUsEast'\n , ddbcProtocol :: Protocol\n -- ^ 'HTTP' or 'HTTPS'\n , ddbcPort :: Maybe Int\n -- ^ Port override (mostly for local dev connection)\n } deriving (Show,Typeable)\n\ninstance Default (DdbConfiguration NormalQuery) where\n def = DdbConfiguration ddbUsEast1 HTTPS Nothing\n\ninstance DefaultServiceConfiguration (DdbConfiguration NormalQuery) where\n defServiceConfig = ddbHttps ddbUsEast1\n debugServiceConfig = ddbHttp ddbUsEast1\n\n\n-------------------------------------------------------------------------------\n-- | DynamoDb local connection (for development)\nddbLocal :: Region\nddbLocal = Region \"127.0.0.1\" \"local\"\n\nddbUsEast1 :: Region\nddbUsEast1 = Region \"dynamodb.us-east-1.amazonaws.com\" \"us-east-1\"\n\nddbUsWest1 :: Region\nddbUsWest1 = Region \"dynamodb.us-west-1.amazonaws.com\" \"us-west-1\"\n\nddbUsWest2 :: Region\nddbUsWest2 = Region \"dynamodb.us-west-2.amazonaws.com\" \"us-west-2\"\n\nddbEuWest1 :: Region\nddbEuWest1 = Region \"dynamodb.eu-west-1.amazonaws.com\" \"eu-west-1\"\n\nddbEuWest2 :: Region\nddbEuWest2 = Region \"dynamodb.eu-west-2.amazonaws.com\" \"eu-west-2\"\n\nddbEuCentral1 :: Region\nddbEuCentral1 = Region \"dynamodb.eu-central-1.amazonaws.com\" \"eu-central-1\"\n\nddbApNe1 :: Region\nddbApNe1 = Region \"dynamodb.ap-northeast-1.amazonaws.com\" \"ap-northeast-1\"\n\nddbApSe1 :: Region\nddbApSe1 = Region \"dynamodb.ap-southeast-1.amazonaws.com\" \"ap-southeast-1\"\n\nddbApSe2 :: Region\nddbApSe2 = Region \"dynamodb.ap-southeast-2.amazonaws.com\" \"ap-southeast-2\"\n\nddbSaEast1 :: Region\nddbSaEast1 = Region \"dynamodb.sa-east-1.amazonaws.com\" \"sa-east-1\"\n\nddbHttp :: Region -> DdbConfiguration NormalQuery\nddbHttp endpoint = DdbConfiguration endpoint HTTP Nothing\n\nddbHttps :: Region -> DdbConfiguration NormalQuery\nddbHttps endpoint = DdbConfiguration endpoint HTTPS Nothing\n\n\nddbSignQuery\n :: A.ToJSON a\n => B.ByteString\n -> a\n -> DdbConfiguration qt\n -> SignatureData\n -> SignedQuery\nddbSignQuery target body di sd\n = SignedQuery {\n sqMethod = Post\n , sqProtocol = ddbcProtocol di\n , sqHost = host\n , sqPort = fromMaybe (defaultPort (ddbcProtocol di)) (ddbcPort di)\n , sqPath = \"/\"\n , sqQuery = []\n , sqDate = Just $ signatureTime sd\n , sqAuthorization = Just auth\n , sqContentType = Just \"application/x-amz-json-1.0\"\n , sqContentMd5 = Nothing\n , sqAmzHeaders = amzHeaders ++ maybe [] (\\tok -> [(\"x-amz-security-token\",tok)]) (iamToken credentials)\n , sqOtherHeaders = []\n , sqBody = Just $ HTTP.RequestBodyLBS bodyLBS\n , sqStringToSign = canonicalRequest\n }\n where\n credentials = signatureCredentials sd\n\n Region{..} = ddbcRegion di\n host = rUri\n\n sigTime = fmtTime \"%Y%m%dT%H%M%SZ\" $ signatureTime sd\n\n bodyLBS = A.encode body\n bodyHash = Base16.encode $ ByteArray.convert (CH.hashlazy bodyLBS :: CH.Digest CH.SHA256)\n\n -- for some reason AWS doesn't want the x-amz-security-token in the canonical request\n amzHeaders = [ (\"x-amz-date\", sigTime)\n , (\"x-amz-target\", dyApiVersion Sem.<> target)\n ]\n\n canonicalHeaders = sortBy (compare `on` fst) $ amzHeaders ++\n [(\"host\", host),\n (\"content-type\", \"application/x-amz-json-1.0\")]\n\n canonicalRequest = B.concat $ intercalate [\"\\n\"] (\n [ [\"POST\"]\n , [\"/\"]\n , [] -- query string\n ] ++\n map (\\(a,b) -> [CI.foldedCase a,\":\",b]) canonicalHeaders ++\n [ [] -- end headers\n , intersperse \";\" (map (CI.foldedCase . fst) canonicalHeaders)\n , [bodyHash]\n ])\n\n auth = authorizationV4 sd HmacSHA256 rName \"dynamodb\"\n \"content-type;host;x-amz-date;x-amz-target\"\n canonicalRequest\n\ndata AmazonError = AmazonError {\n aeType :: T.Text\n , aeMessage :: Maybe T.Text\n }\n\ninstance FromJSON AmazonError where\n parseJSON (Object v) = AmazonError\n <$> v .: \"__type\"\n <*> (Just <$> (v .: \"message\" <|> v .: \"Message\") <|> pure Nothing)\n parseJSON _ = error $ \"aws: unexpected AmazonError message\"\n\n\n\n\n-------------------------------------------------------------------------------\nddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a\nddbResponseConsumer ref resp = do\n val <- runConduit $ HTTP.responseBody resp .| sinkParser (A.json' <* AttoB.endOfInput)\n case statusCode of\n 200 -> rSuccess val\n _ -> rError val\n where\n\n header = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)\n amzId = header \"x-amzn-RequestId\"\n amzCrc = header \"x-amz-crc32\"\n meta = DdbResponse amzCrc amzId\n tellMeta = liftIO $ tellMetadataRef ref meta\n\n rSuccess val =\n case A.fromJSON val of\n A.Success a -> return a\n A.Error err -> do\n tellMeta\n throwM $ JsonProtocolError val (T.pack err)\n\n rError val = do\n tellMeta\n case parseEither parseJSON val of\n Left e ->\n throwM $ JsonProtocolError val (T.pack e)\n\n Right err'' -> do\n let e = T.drop 1 . snd . T.breakOn \"#\" $ aeType err''\n errCode <- readErrCode e\n throwM $ DdbError statusCode errCode (fromMaybe \"\" $ aeMessage err'')\n\n readErrCode txt =\n let txt' = T.unpack txt\n in case readMay txt' of\n Just e -> return $ e\n Nothing -> throwM (UnknownDynamoErrCode txt)\n\n HTTP.Status{..} = HTTP.responseStatus resp\n\n\n-- | Conditions used by mutation operations ('PutItem', 'UpdateItem',\n-- etc.). The default 'def' instance is empty (no condition).\ndata Conditions = Conditions CondMerge [Condition]\n deriving (Eq,Show,Read,Ord,Typeable)\n\ninstance Default Conditions where\n def = Conditions CondAnd []\n\n\n\nexpectsJson :: Conditions -> [A.Pair]\nexpectsJson = conditionsJson \"Expected\"\n\n\n-- | JSON encoding of conditions parameter in various contexts.\nconditionsJson :: T.Text -> Conditions -> [A.Pair]\nconditionsJson key (Conditions op es) = b ++ a\n where\n a = if null es\n then []\n else [AK.fromText key .= object (map conditionJson es)]\n\n b = if length (take 2 es) > 1\n then [\"ConditionalOperator\" .= String (rendCondOp op) ]\n else []\n\n\n-------------------------------------------------------------------------------\nrendCondOp :: CondMerge -> T.Text\nrendCondOp CondAnd = \"AND\"\nrendCondOp CondOr = \"OR\"\n\n\n-------------------------------------------------------------------------------\n-- | How to merge multiple conditions.\ndata CondMerge = CondAnd | CondOr\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-- | A condition used by mutation operations ('PutItem', 'UpdateItem', etc.).\ndata Condition = Condition {\n condAttr :: T.Text\n -- ^ Attribute to use as the basis for this conditional\n , condOp :: CondOp\n -- ^ Operation on the selected attribute\n } deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\n-- | Conditional operation to perform on a field.\ndata CondOp\n = DEq DValue\n | NotEq DValue\n | DLE DValue\n | DLT DValue\n | DGE DValue\n | DGT DValue\n | NotNull\n | IsNull\n | Contains DValue\n | NotContains DValue\n | Begins DValue\n | In [DValue]\n | Between DValue DValue\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\n-------------------------------------------------------------------------------\ngetCondValues :: CondOp -> [DValue]\ngetCondValues c = case c of\n DEq v -> [v]\n NotEq v -> [v]\n DLE v -> [v]\n DLT v -> [v]\n DGE v -> [v]\n DGT v -> [v]\n NotNull -> []\n IsNull -> []\n Contains v -> [v]\n NotContains v -> [v]\n Begins v -> [v]\n In v -> v\n Between a b -> [a,b]\n\n\n-------------------------------------------------------------------------------\nrenderCondOp :: CondOp -> T.Text\nrenderCondOp c = case c of\n DEq{} -> \"EQ\"\n NotEq{} -> \"NE\"\n DLE{} -> \"LE\"\n DLT{} -> \"LT\"\n DGE{} -> \"GE\"\n DGT{} -> \"GT\"\n NotNull -> \"NOT_NULL\"\n IsNull -> \"NULL\"\n Contains{} -> \"CONTAINS\"\n NotContains{} -> \"NOT_CONTAINS\"\n Begins{} -> \"BEGINS_WITH\"\n In{} -> \"IN\"\n Between{} -> \"BETWEEN\"\n\n\nconditionJson :: Condition -> Pair\nconditionJson Condition{..} = AK.fromText condAttr .= condOp\n\n\ninstance ToJSON CondOp where\n toJSON c = object $ (\"ComparisonOperator\" .= String (renderCondOp c)) : valueList\n where\n valueList =\n let vs = getCondValues c in\n if null vs\n then []\n else [\"AttributeValueList\" .= vs]\n\n-------------------------------------------------------------------------------\ndyApiVersion :: B.ByteString\ndyApiVersion = \"DynamoDB_20120810.\"\n\n\n\n-------------------------------------------------------------------------------\n-- | The standard response metrics on capacity consumption.\ndata ConsumedCapacity = ConsumedCapacity {\n capacityUnits :: Int64\n , capacityGlobalIndex :: [(T.Text, Int64)]\n , capacityLocalIndex :: [(T.Text, Int64)]\n , capacityTableUnits :: Maybe Int64\n , capacityTable :: T.Text\n } deriving (Eq,Show,Read,Ord,Typeable)\n\n\ninstance FromJSON ConsumedCapacity where\n parseJSON (Object o) = ConsumedCapacity\n <$> o .: \"CapacityUnits\"\n <*> (map (\\(k, v) -> (AK.toText k, v)) . KM.toList <$> o .:? \"GlobalSecondaryIndexes\" .!= mempty)\n <*> (map (\\(k, v) -> (AK.toText k, v)) . KM.toList <$> o .:? \"LocalSecondaryIndexes\" .!= mempty)\n <*> (o .:? \"Table\" >>= maybe (return Nothing) (.: \"CapacityUnits\"))\n <*> o .: \"TableName\"\n parseJSON _ = fail \"ConsumedCapacity must be an Object.\"\n\n\n\ndata ReturnConsumption = RCIndexes | RCTotal | RCNone\n deriving (Eq,Show,Read,Ord,Typeable)\n\ninstance ToJSON ReturnConsumption where\n toJSON RCIndexes = String \"INDEXES\"\n toJSON RCTotal = String \"TOTAL\"\n toJSON RCNone = String \"NONE\"\n\ninstance Default ReturnConsumption where\n def = RCNone\n\ndata ReturnItemCollectionMetrics = RICMSize | RICMNone\n deriving (Eq,Show,Read,Ord,Typeable)\n\ninstance ToJSON ReturnItemCollectionMetrics where\n toJSON RICMSize = String \"SIZE\"\n toJSON RICMNone = String \"NONE\"\n\ninstance Default ReturnItemCollectionMetrics where\n def = RICMNone\n\n\ndata ItemCollectionMetrics = ItemCollectionMetrics {\n icmKey :: (T.Text, DValue)\n , icmEstimate :: [Double]\n } deriving (Eq,Show,Read,Ord,Typeable)\n\n\ninstance FromJSON ItemCollectionMetrics where\n parseJSON (Object o) = ItemCollectionMetrics\n <$> (do m <- o .: \"ItemCollectionKey\"\n return $ (\\(k, v) -> (AK.toText k, v)) $ head $ KM.toList m)\n <*> o .: \"SizeEstimateRangeGB\"\n parseJSON _ = fail \"ItemCollectionMetrics must be an Object.\"\n\n\n-------------------------------------------------------------------------------\n-- | What to return from the current update operation\ndata UpdateReturn\n = URNone -- ^ Return nothing\n | URAllOld -- ^ Return old values\n | URUpdatedOld -- ^ Return old values with a newer replacement\n | URAllNew -- ^ Return new values\n | URUpdatedNew -- ^ Return new values that were replacements\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\ninstance ToJSON UpdateReturn where\n toJSON URNone = toJSON (String \"NONE\")\n toJSON URAllOld = toJSON (String \"ALL_OLD\")\n toJSON URUpdatedOld = toJSON (String \"UPDATED_OLD\")\n toJSON URAllNew = toJSON (String \"ALL_NEW\")\n toJSON URUpdatedNew = toJSON (String \"UPDATED_NEW\")\n\n\ninstance Default UpdateReturn where\n def = URNone\n\n\n\n-------------------------------------------------------------------------------\n-- | What to return from a 'Query' or 'Scan' query.\ndata QuerySelect\n = SelectSpecific [T.Text]\n -- ^ Only return selected attributes\n | SelectCount\n -- ^ Return counts instead of attributes\n | SelectProjected\n -- ^ Return index-projected attributes\n | SelectAll\n -- ^ Default. Return everything.\n deriving (Eq,Show,Read,Ord,Typeable)\n\n\ninstance Default QuerySelect where def = SelectAll\n\n-------------------------------------------------------------------------------\nquerySelectJson :: KeyValue A.Value t => QuerySelect -> [t]\nquerySelectJson (SelectSpecific as) =\n [ \"Select\" .= String \"SPECIFIC_ATTRIBUTES\"\n , \"AttributesToGet\" .= as]\nquerySelectJson SelectCount = [\"Select\" .= String \"COUNT\"]\nquerySelectJson SelectProjected = [\"Select\" .= String \"ALL_PROJECTED_ATTRIBUTES\"]\nquerySelectJson SelectAll = [\"Select\" .= String \"ALL_ATTRIBUTES\"]\n\n\n-------------------------------------------------------------------------------\n-- | A class to help predict DynamoDb size of values, attributes and\n-- entire items. The result is given in number of bytes.\nclass DynSize a where\n dynSize :: a -> Int\n\ninstance DynSize DValue where\n dynSize DNull = 8\n dynSize (DBool _) = 8\n dynSize (DBoolSet s) = sum $ map (dynSize . DBool) $ S.toList s\n dynSize (DNum _) = 8\n dynSize (DString a) = T.length a\n dynSize (DBinary bs) = T.length . T.decodeUtf8 $ Base64.encode bs\n dynSize (DNumSet s) = 8 * S.size s\n dynSize (DStringSet s) = sum $ map (dynSize . DString) $ S.toList s\n dynSize (DBinSet s) = sum $ map (dynSize . DBinary) $ S.toList s\n dynSize (DList s) = sum $ map dynSize $ V.toList s\n dynSize (DMap s) = sum $ map dynSize $ M.elems s\n\ninstance DynSize Attribute where\n dynSize (Attribute k v) = T.length k + dynSize v\n\ninstance DynSize Item where\n dynSize m = sum $ map dynSize $ attributes m\n\ninstance DynSize a => DynSize [a] where\n dynSize as = sum $ map dynSize as\n\ninstance DynSize a => DynSize (Maybe a) where\n dynSize = maybe 0 dynSize\n\ninstance (DynSize a, DynSize b) => DynSize (Either a b) where\n dynSize = either dynSize dynSize\n\n\n-------------------------------------------------------------------------------\n-- | Will an attribute be considered empty by DynamoDb?\n--\n-- A 'PutItem' (or similar) with empty attributes will be rejected\n-- with a 'ValidationException'.\nnullAttr :: Attribute -> Bool\nnullAttr (Attribute _ val) =\n case val of\n DString \"\" -> True\n DBinary \"\" -> True\n DNumSet s | S.null s -> True\n DStringSet s | S.null s -> True\n DBinSet s | S.null s -> True\n _ -> False\n\n\n\n\n-------------------------------------------------------------------------------\n--\n-- | Item Parsing\n--\n-------------------------------------------------------------------------------\n\n\n\n-- | Failure continuation.\ntype Failure f r = String -> f r\n\n-- | Success continuation.\ntype Success a f r = a -> f r\n\n\n-- | A continuation-based parser type.\nnewtype Parser a = Parser {\n runParser :: forall f r.\n Failure f r\n -> Success a f r\n -> f r\n }\n\ninstance Monad Parser where\n m >>= g = Parser $ \\kf ks -> let ks' a = runParser (g a) kf ks\n in runParser m kf ks'\n {-# INLINE (>>=) #-}\n return = pure\n {-# INLINE return #-}\n#if !(MIN_VERSION_base(4,13,0))\n fail msg = Parser $ \\kf _ks -> kf msg\n {-# INLINE fail #-}\n#endif\n\n#if MIN_VERSION_base(4,9,0)\ninstance Fail.MonadFail Parser where\n fail msg = Parser $ \\kf _ks -> kf msg\n {-# INLINE fail #-}\n#endif\n\ninstance Functor Parser where\n fmap f m = Parser $ \\kf ks -> let ks' a = ks (f a)\n in runParser m kf ks'\n {-# INLINE fmap #-}\n\ninstance Applicative Parser where\n pure a = Parser $ \\_kf ks -> ks a\n {-# INLINE pure #-}\n (<*>) = apP\n {-# INLINE (<*>) #-}\n\ninstance Alternative Parser where\n empty = fail \"empty\"\n {-# INLINE empty #-}\n (<|>) = mplus\n {-# INLINE (<|>) #-}\n\ninstance MonadPlus Parser where\n mzero = fail \"mzero\"\n {-# INLINE mzero #-}\n mplus a b = Parser $ \\kf ks -> let kf' _ = runParser b kf ks\n in runParser a kf' ks\n {-# INLINE mplus #-}\n\ninstance Sem.Semigroup (Parser a) where\n (<>) = mplus\n {-# INLINE (<>) #-}\n\ninstance Monoid (Parser a) where\n mempty = fail \"mempty\"\n {-# INLINE mempty #-}\n mappend = (Sem.<>)\n {-# INLINE mappend #-}\n\napP :: Parser (a -> b) -> Parser a -> Parser b\napP d e = do\n b <- d\n a <- e\n return (b a)\n{-# INLINE apP #-}\n\n\n-------------------------------------------------------------------------------\n-- | Types convertible to DynamoDb 'Item' collections.\n--\n-- Use 'attr' and 'attrAs' combinators to conveniently define instances.\nclass ToDynItem a where\n toItem :: a -> Item\n\n\n-------------------------------------------------------------------------------\n-- | Types parseable from DynamoDb 'Item' collections.\n--\n-- User 'getAttr' family of functions to applicatively or monadically\n-- parse into your custom types.\nclass FromDynItem a where\n parseItem :: Item -> Parser a\n\n\ninstance ToDynItem Item where toItem = id\n\ninstance FromDynItem Item where parseItem = return\n\n\ninstance DynVal a => ToDynItem [(T.Text, a)] where\n toItem as = item $ map (uncurry attr) as\n\ninstance (Typeable a, DynVal a) => FromDynItem [(T.Text, a)] where\n parseItem i = mapM f $ M.toList i\n where\n f (k,v) = do\n v' <- maybe (fail (valErr (Tagged v :: Tagged a DValue))) return $\n fromValue v\n return (k, v')\n\n\ninstance DynVal a => ToDynItem (M.Map T.Text a) where\n toItem m = toItem $ M.toList m\n\n\ninstance (Typeable a, DynVal a) => FromDynItem (M.Map T.Text a) where\n parseItem i = M.fromList <$> parseItem i\n\n\nvalErr :: forall a. Typeable a => Tagged a DValue -> String\nvalErr (Tagged dv) = \"Can't convert DynamoDb value \" Sem.<> show dv Sem.<>\n \" into type \" Sem.<> (show (typeOf (undefined :: a)))\n\n\n-- | Convenience combinator for parsing fields from an 'Item' returned\n-- by DynamoDb.\ngetAttr\n :: forall a. (Typeable a, DynVal a)\n => T.Text\n -- ^ Attribute name\n -> Item\n -- ^ Item from DynamoDb\n -> Parser a\ngetAttr k m = do\n case M.lookup k m of\n Nothing -> fail (\"Key \" Sem.<> T.unpack k Sem.<> \" not found\")\n Just dv -> maybe (fail (valErr (Tagged dv :: Tagged a DValue))) return $ fromValue dv\n\n\n-- | Parse attribute if it's present in the 'Item'. Fail if attribute\n-- is present but conversion fails.\ngetAttr'\n :: forall a. (DynVal a)\n => T.Text\n -- ^ Attribute name\n -> Item\n -- ^ Item from DynamoDb\n -> Parser (Maybe a)\ngetAttr' k m = do\n case M.lookup k m of\n Nothing -> return Nothing\n Just dv -> return $ fromValue dv\n\n-- | Combinator for parsing an attribute into a 'FromDynItem'.\nparseAttr\n :: FromDynItem a\n => T.Text\n -- ^ Attribute name\n -> Item\n -- ^ Item from DynamoDb\n -> Parser a\nparseAttr k m =\n case M.lookup k m of\n Nothing -> fail (\"Key \" Sem.<> T.unpack k Sem.<> \" not found\")\n Just (DMap dv) -> either (const (fail \"...\")) return $ fromItem dv\n _ -> fail (\"Key \" Sem.<> T.unpack k Sem.<> \" is not a map!\")\n\n-------------------------------------------------------------------------------\n-- | Parse an 'Item' into target type using the 'FromDynItem'\n-- instance.\nfromItem :: FromDynItem a => Item -> Either String a\nfromItem i = runParser (parseItem i) Left Right\n" }, { "path": "Aws/DynamoDb.hs", "content": "-----------------------------------------------------------------------------\n-- |\n-- Module : Aws.DynaboDb\n-- Copyright : Ozgun Ataman, Soostone Inc.\n-- License : BSD3\n--\n-- Maintainer : Ozgun Ataman \n-- Stability : experimental\n--\n----------------------------------------------------------------------------\n\nmodule Aws.DynamoDb\n ( module Aws.DynamoDb.Core\n , module Aws.DynamoDb.Commands\n ) where\n\n-------------------------------------------------------------------------------\nimport Aws.DynamoDb.Commands\nimport Aws.DynamoDb.Core\n-------------------------------------------------------------------------------\n" }, { "path": "Aws/Ec2/InstanceMetadata.hs", "content": "module Aws.Ec2.InstanceMetadata where\n\nimport Control.Applicative\nimport Control.Exception\nimport Control.Monad.Trans.Resource (throwM)\nimport qualified Data.ByteString.Lazy as L\nimport qualified Data.ByteString.Lazy.Char8 as B8\nimport Data.ByteString.Lazy.UTF8 as BU\nimport Data.Typeable\nimport qualified Network.HTTP.Conduit as HTTP\nimport Prelude\n\ndata InstanceMetadataException\n = MetadataNotFound String\n deriving (Show, Typeable)\n\ninstance Exception InstanceMetadataException\n\ngetInstanceMetadata :: HTTP.Manager -> String -> String -> IO L.ByteString\ngetInstanceMetadata mgr p x = do\n req <- HTTP.parseUrlThrow (\"http://169.254.169.254/\" ++ p ++ '/' : x)\n HTTP.responseBody <$> HTTP.httpLbs req mgr\n\ngetInstanceMetadataListing :: HTTP.Manager -> String -> IO [String]\ngetInstanceMetadataListing mgr p = map BU.toString . B8.split '\\n' <$> getInstanceMetadata mgr p \"\"\n\ngetInstanceMetadataFirst :: HTTP.Manager -> String -> IO L.ByteString\ngetInstanceMetadataFirst mgr p = do listing <- getInstanceMetadataListing mgr p\n case listing of\n [] -> throwM (MetadataNotFound p)\n (x:_) -> getInstanceMetadata mgr p x\n\ngetInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> IO L.ByteString\ngetInstanceMetadataOrFirst mgr p (Just x) = getInstanceMetadata mgr p x\ngetInstanceMetadataOrFirst mgr p Nothing = getInstanceMetadataFirst mgr p\n" }, { "path": "Aws/Iam/Commands/AddUserToGroup.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.AddUserToGroup\n ( AddUserToGroup(..)\n , AddUserToGroupResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Adds the specified user to the specified group.\n--\n-- \ndata AddUserToGroup\n = AddUserToGroup {\n autgGroupName :: Text\n -- ^ Name of the group to update.\n , autgUserName :: Text\n -- ^ The of the user to add.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery AddUserToGroup where\n type ServiceConfiguration AddUserToGroup = IamConfiguration\n signQuery AddUserToGroup{..}\n = iamAction \"AddUserToGroup\" [\n (\"GroupName\" , autgGroupName)\n , (\"UserName\" , autgUserName)\n ]\n\ndata AddUserToGroupResponse = AddUserToGroupResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer AddUserToGroup AddUserToGroupResponse where\n type ResponseMetadata AddUserToGroupResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return AddUserToGroupResponse)\n\ninstance Transaction AddUserToGroup AddUserToGroupResponse\n\ninstance AsMemoryResponse AddUserToGroupResponse where\n type MemoryResponse AddUserToGroupResponse = AddUserToGroupResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/CreateAccessKey.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.CreateAccessKey\n ( CreateAccessKey(..)\n , CreateAccessKeyResponse(..)\n , AccessKey(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport qualified Data.Text as Text\nimport Data.Time\nimport Data.Typeable\nimport Prelude\nimport Text.XML.Cursor (($//))\n\n-- | Creates a new AWS secret access key and corresponding AWS access key ID\n-- for the given user name.\n--\n-- If a user name is not provided, IAM will determine the user name based on\n-- the access key signing the request.\n--\n-- \ndata CreateAccessKey = CreateAccessKey (Maybe Text)\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery CreateAccessKey where\n type ServiceConfiguration CreateAccessKey = IamConfiguration\n signQuery (CreateAccessKey user)\n = iamAction' \"CreateAccessKey\" [(\"UserName\",) <$> user]\n\n-- | Represents the IAM @AccessKey@ data type.\n--\n-- \ndata AccessKey\n = AccessKey {\n akAccessKeyId :: Text\n -- ^ The Access Key ID.\n , akCreateDate :: Maybe UTCTime\n -- ^ Date and time at which the access key was created.\n , akSecretAccessKey :: Text\n -- ^ Secret key used to sign requests. The secret key is accessible only\n -- during key creation.\n , akStatus :: AccessKeyStatus\n -- ^ Whether the access key is active or not.\n , akUserName :: Text\n -- ^ The user name for which this key is defined.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ndata CreateAccessKeyResponse\n = CreateAccessKeyResponse AccessKey\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer CreateAccessKey CreateAccessKeyResponse where\n type ResponseMetadata CreateAccessKeyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n let attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n akAccessKeyId <- attr \"AccessKeyId\"\n akSecretAccessKey <- attr \"SecretAccessKey\"\n akStatus <- readAccessKeyStatus <$> attr \"Status\"\n akUserName <- attr \"UserName\"\n akCreateDate <- readDate cursor\n return $ CreateAccessKeyResponse AccessKey{..}\n where\n readDate c = case c $// elCont \"CreateDate\" of\n (x:_) -> Just <$> parseDateTime x\n _ -> return Nothing\n readAccessKeyStatus s\n | Text.toCaseFold s == \"Active\" = AccessKeyActive\n | otherwise = AccessKeyInactive\n\n\ninstance Transaction CreateAccessKey CreateAccessKeyResponse\n\ninstance AsMemoryResponse CreateAccessKeyResponse where\n type MemoryResponse CreateAccessKeyResponse = CreateAccessKeyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/CreateGroup.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.CreateGroup\n ( CreateGroup(..)\n , CreateGroupResponse(..)\n , Group(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Creates a new group.\n--\n-- \ndata CreateGroup\n = CreateGroup {\n cgGroupName :: Text\n -- ^ Name of the new group\n , cgPath :: Maybe Text\n -- ^ Path under which the group will be created. Defaults to @/@ if\n -- omitted.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery CreateGroup where\n type ServiceConfiguration CreateGroup = IamConfiguration\n signQuery CreateGroup{..}\n = iamAction' \"CreateGroup\" [\n Just (\"GroupName\", cgGroupName)\n , (\"Path\",) <$> cgPath\n ]\n\ndata CreateGroupResponse = CreateGroupResponse Group\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer CreateGroup CreateGroupResponse where\n type ResponseMetadata CreateGroupResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $\n fmap CreateGroupResponse . parseGroup\n\ninstance Transaction CreateGroup CreateGroupResponse\n\ninstance AsMemoryResponse CreateGroupResponse where\n type MemoryResponse CreateGroupResponse = CreateGroupResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/CreateUser.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.CreateUser\n ( CreateUser(..)\n , CreateUserResponse(..)\n , User(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Creates a new user.\n--\n-- \ndata CreateUser\n = CreateUser {\n cuUserName :: Text\n -- ^ Name of the new user\n , cuPath :: Maybe Text\n -- ^ Path under which the user will be created. Defaults to @/@ if\n -- omitted.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery CreateUser where\n type ServiceConfiguration CreateUser = IamConfiguration\n signQuery CreateUser{..}\n = iamAction' \"CreateUser\" [\n Just (\"UserName\", cuUserName)\n , (\"Path\",) <$> cuPath\n ]\n\ndata CreateUserResponse = CreateUserResponse User\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer CreateUser CreateUserResponse where\n type ResponseMetadata CreateUserResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $\n fmap CreateUserResponse . parseUser\n\ninstance Transaction CreateUser CreateUserResponse\n\ninstance AsMemoryResponse CreateUserResponse where\n type MemoryResponse CreateUserResponse = CreateUserResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/DeleteAccessKey.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.DeleteAccessKey\n ( DeleteAccessKey(..)\n , DeleteAccessKeyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Deletes the access key associated with the specified user.\n--\n-- \ndata DeleteAccessKey\n = DeleteAccessKey {\n dakAccessKeyId :: Text\n -- ^ ID of the access key to be deleted.\n , dakUserName :: Maybe Text\n -- ^ User name with which the access key is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery DeleteAccessKey where\n type ServiceConfiguration DeleteAccessKey = IamConfiguration\n signQuery DeleteAccessKey{..}\n = iamAction' \"DeleteAccessKey\" [\n Just (\"AccessKeyId\", dakAccessKeyId)\n , (\"UserName\",) <$> dakUserName\n ]\n\ndata DeleteAccessKeyResponse = DeleteAccessKeyResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer DeleteAccessKey DeleteAccessKeyResponse where\n type ResponseMetadata DeleteAccessKeyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return DeleteAccessKeyResponse)\n\ninstance Transaction DeleteAccessKey DeleteAccessKeyResponse\n\ninstance AsMemoryResponse DeleteAccessKeyResponse where\n type MemoryResponse DeleteAccessKeyResponse = DeleteAccessKeyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/DeleteGroup.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.DeleteGroup\n ( DeleteGroup(..)\n , DeleteGroupResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Deletes the specified group.\n--\n-- \ndata DeleteGroup = DeleteGroup Text\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery DeleteGroup where\n type ServiceConfiguration DeleteGroup = IamConfiguration\n signQuery (DeleteGroup groupName)\n = iamAction \"DeleteGroup\" [(\"GroupName\", groupName)]\n\ndata DeleteGroupResponse = DeleteGroupResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer DeleteGroup DeleteGroupResponse where\n type ResponseMetadata DeleteGroupResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return DeleteGroupResponse)\n\ninstance Transaction DeleteGroup DeleteGroupResponse\n\ninstance AsMemoryResponse DeleteGroupResponse where\n type MemoryResponse DeleteGroupResponse = DeleteGroupResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/DeleteGroupPolicy.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.DeleteGroupPolicy\n ( DeleteGroupPolicy(..)\n , DeleteGroupPolicyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Deletes the specified policy associated with the specified group.\n--\n-- \ndata DeleteGroupPolicy\n = DeleteGroupPolicy {\n dgpPolicyName :: Text\n -- ^ Name of the policy to be deleted.\n , dgpGroupName :: Text\n -- ^ Name of the group with whom the policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery DeleteGroupPolicy where\n type ServiceConfiguration DeleteGroupPolicy = IamConfiguration\n signQuery DeleteGroupPolicy{..}\n = iamAction \"DeleteGroupPolicy\" [\n (\"PolicyName\", dgpPolicyName)\n , (\"GroupName\", dgpGroupName)\n ]\n\ndata DeleteGroupPolicyResponse = DeleteGroupPolicyResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer DeleteGroupPolicy DeleteGroupPolicyResponse where\n type ResponseMetadata DeleteGroupPolicyResponse = IamMetadata\n responseConsumer _ _ =\n iamResponseConsumer (const $ return DeleteGroupPolicyResponse)\n\ninstance Transaction DeleteGroupPolicy DeleteGroupPolicyResponse\n\ninstance AsMemoryResponse DeleteGroupPolicyResponse where\n type MemoryResponse DeleteGroupPolicyResponse = DeleteGroupPolicyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/DeleteUser.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.DeleteUser\n ( DeleteUser(..)\n , DeleteUserResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Deletes the specified user.\n--\n-- \ndata DeleteUser = DeleteUser Text\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery DeleteUser where\n type ServiceConfiguration DeleteUser = IamConfiguration\n signQuery (DeleteUser userName)\n = iamAction \"DeleteUser\" [(\"UserName\", userName)]\n\ndata DeleteUserResponse = DeleteUserResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer DeleteUser DeleteUserResponse where\n type ResponseMetadata DeleteUserResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return DeleteUserResponse)\n\ninstance Transaction DeleteUser DeleteUserResponse\n\ninstance AsMemoryResponse DeleteUserResponse where\n type MemoryResponse DeleteUserResponse = DeleteUserResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/DeleteUserPolicy.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.DeleteUserPolicy\n ( DeleteUserPolicy(..)\n , DeleteUserPolicyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Deletes the specified policy associated with the specified user.\n--\n-- \ndata DeleteUserPolicy\n = DeleteUserPolicy {\n dupPolicyName :: Text\n -- ^ Name of the policy to be deleted.\n , dupUserName :: Text\n -- ^ Name of the user with whom the policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery DeleteUserPolicy where\n type ServiceConfiguration DeleteUserPolicy = IamConfiguration\n signQuery DeleteUserPolicy{..}\n = iamAction \"DeleteUserPolicy\" [\n (\"PolicyName\", dupPolicyName)\n , (\"UserName\", dupUserName)\n ]\n\ndata DeleteUserPolicyResponse = DeleteUserPolicyResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer DeleteUserPolicy DeleteUserPolicyResponse where\n type ResponseMetadata DeleteUserPolicyResponse = IamMetadata\n responseConsumer _ _ =\n iamResponseConsumer (const $ return DeleteUserPolicyResponse)\n\ninstance Transaction DeleteUserPolicy DeleteUserPolicyResponse\n\ninstance AsMemoryResponse DeleteUserPolicyResponse where\n type MemoryResponse DeleteUserPolicyResponse = DeleteUserPolicyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/GetGroup.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.GetUser\n ( GetUser(..)\n , GetUserResponse(..)\n , User(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Retrieves information about the given user.\n--\n-- If a user name is not given, IAM determines the user name based on the\n-- access key signing the request.\n--\n-- \ndata GetUser = GetUser (Maybe Text)\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery GetUser where\n type ServiceConfiguration GetUser = IamConfiguration\n signQuery (GetUser user)\n = iamAction' \"GetUser\" [(\"UserName\",) <$> user]\n\ndata GetUserResponse = GetUserResponse User\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer GetUser GetUserResponse where\n type ResponseMetadata GetUserResponse = IamMetadata\n responseConsumer _ _ = iamResponseConsumer $\n fmap GetUserResponse . parseUser\n\ninstance Transaction GetUser GetUserResponse\n\ninstance AsMemoryResponse GetUserResponse where\n type MemoryResponse GetUserResponse = GetUserResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/GetGroupPolicy.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.GetGroupPolicy\n ( GetGroupPolicy(..)\n , GetGroupPolicyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Text\nimport Data.Typeable\nimport qualified Network.HTTP.Types as HTTP\nimport Text.XML.Cursor (($//))\nimport Prelude\n\n-- | Retrieves the specified policy document for the specified group.\n--\n-- \ndata GetGroupPolicy\n = GetGroupPolicy {\n ggpPolicyName :: Text\n -- ^ Name of the policy.\n , ggpGroupName :: Text\n -- ^ Name of the group with whom the policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery GetGroupPolicy where\n type ServiceConfiguration GetGroupPolicy = IamConfiguration\n signQuery GetGroupPolicy{..}\n = iamAction \"GetGroupPolicy\" [\n (\"PolicyName\", ggpPolicyName)\n , (\"GroupName\", ggpGroupName)\n ]\n\ndata GetGroupPolicyResponse\n = GetGroupPolicyResponse {\n ggprPolicyDocument :: Text\n -- ^ The policy document.\n , ggprPolicyName :: Text\n -- ^ Name of the policy.\n , ggprGroupName :: Text\n -- ^ Name of the group with whom the policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer GetGroupPolicy GetGroupPolicyResponse where\n type ResponseMetadata GetGroupPolicyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n let attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n ggprPolicyDocument <- decodePolicy <$>\n attr \"PolicyDocument\"\n ggprPolicyName <- attr \"PolicyName\"\n ggprGroupName <- attr \"GroupName\"\n return GetGroupPolicyResponse{..}\n where\n decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False\n . Text.encodeUtf8\n\n\ninstance Transaction GetGroupPolicy GetGroupPolicyResponse\n\ninstance AsMemoryResponse GetGroupPolicyResponse where\n type MemoryResponse GetGroupPolicyResponse = GetGroupPolicyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/GetUser.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.GetUser\n ( GetUser(..)\n , GetUserResponse(..)\n , User(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Retrieves information about the given user.\n--\n-- If a user name is not given, IAM determines the user name based on the\n-- access key signing the request.\n--\n-- \ndata GetUser = GetUser (Maybe Text)\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery GetUser where\n type ServiceConfiguration GetUser = IamConfiguration\n signQuery (GetUser user)\n = iamAction' \"GetUser\" [(\"UserName\",) <$> user]\n\ndata GetUserResponse = GetUserResponse User\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer GetUser GetUserResponse where\n type ResponseMetadata GetUserResponse = IamMetadata\n responseConsumer _ _ = iamResponseConsumer $\n fmap GetUserResponse . parseUser\n\ninstance Transaction GetUser GetUserResponse\n\ninstance AsMemoryResponse GetUserResponse where\n type MemoryResponse GetUserResponse = GetUserResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/GetUserPolicy.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.GetUserPolicy\n ( GetUserPolicy(..)\n , GetUserPolicyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Text\nimport Data.Typeable\nimport qualified Network.HTTP.Types as HTTP\nimport Text.XML.Cursor (($//))\nimport Prelude\n\n-- | Retrieves the specified policy document for the specified user.\n--\n-- \ndata GetUserPolicy\n = GetUserPolicy {\n gupPolicyName :: Text\n -- ^ Name of the policy.\n , gupUserName :: Text\n -- ^ Name of the user with whom the policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery GetUserPolicy where\n type ServiceConfiguration GetUserPolicy = IamConfiguration\n signQuery GetUserPolicy{..}\n = iamAction \"GetUserPolicy\" [\n (\"PolicyName\", gupPolicyName)\n , (\"UserName\", gupUserName)\n ]\n\ndata GetUserPolicyResponse\n = GetUserPolicyResponse {\n guprPolicyDocument :: Text\n -- ^ The policy document.\n , guprPolicyName :: Text\n -- ^ Name of the policy.\n , guprUserName :: Text\n -- ^ Name of the user with whom the policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer GetUserPolicy GetUserPolicyResponse where\n type ResponseMetadata GetUserPolicyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n let attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n guprPolicyDocument <- decodePolicy <$>\n attr \"PolicyDocument\"\n guprPolicyName <- attr \"PolicyName\"\n guprUserName <- attr \"UserName\"\n return GetUserPolicyResponse{..}\n where\n decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False\n . Text.encodeUtf8\n\n\ninstance Transaction GetUserPolicy GetUserPolicyResponse\n\ninstance AsMemoryResponse GetUserPolicyResponse where\n type MemoryResponse GetUserPolicyResponse = GetUserPolicyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/ListAccessKeys.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.ListAccessKeys\n ( ListAccessKeys(..)\n , ListAccessKeysResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Time\nimport Data.Typeable\nimport Prelude\nimport Text.XML.Cursor (laxElement, ($/), ($//), (&|))\n\n-- | Returns the access keys associated with the specified user.\n--\n-- \ndata ListAccessKeys\n = ListAccessKeys {\n lakUserName :: Maybe Text\n -- ^ Name of the user. If the user name is not specified, IAM will\n -- determine the user based on the key sigining the request.\n , lakMarker :: Maybe Text\n -- ^ Used for paginating requests. Marks the position of the last\n -- request.\n , lakMaxItems :: Maybe Integer\n -- ^ Used for paginating requests. Specifies the maximum number of items\n -- to return in the response. Defaults to 100.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery ListAccessKeys where\n type ServiceConfiguration ListAccessKeys = IamConfiguration\n signQuery ListAccessKeys{..}\n = iamAction' \"ListAccessKeys\" $ [\n (\"UserName\",) <$> lakUserName\n ] <> markedIter lakMarker lakMaxItems\n\n-- | Represents the IAM @AccessKeyMetadata@ data type.\n--\n-- \ndata AccessKeyMetadata\n = AccessKeyMetadata {\n akmAccessKeyId :: Maybe Text\n -- ^ ID of the access key.\n , akmCreateDate :: Maybe UTCTime\n -- ^ Date and time at which the access key was created.\n , akmStatus :: Maybe Text\n -- ^ Whether the access key is active.\n , akmUserName :: Maybe Text\n -- ^ Name of the user with whom the access key is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ndata ListAccessKeysResponse\n = ListAccessKeysResponse {\n lakrAccessKeyMetadata :: [AccessKeyMetadata]\n -- ^ List of 'AccessKeyMetadata' objects\n , lakrIsTruncated :: Bool\n -- ^ @True@ if the request was truncated because of too many items.\n , lakrMarker :: Maybe Text\n -- ^ Marks the position at which the request was truncated. This value\n -- must be passed with the next request to continue listing from the\n -- last position.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer ListAccessKeys ListAccessKeysResponse where\n type ResponseMetadata ListAccessKeysResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n (lakrIsTruncated, lakrMarker) <- markedIterResponse cursor\n lakrAccessKeyMetadata <- sequence $\n cursor $// laxElement \"member\" &| buildAKM\n return ListAccessKeysResponse{..}\n where\n buildAKM m = do\n let mattr name = mhead $ m $/ elContent name\n let akmAccessKeyId = mattr \"AccessKeyId\"\n akmStatus = mattr \"Status\"\n akmUserName = mattr \"UserName\"\n akmCreateDate <- case m $/ elCont \"CreateDate\" of\n (x:_) -> Just <$> parseDateTime x\n _ -> return Nothing\n return AccessKeyMetadata{..}\n\n mhead (x:_) = Just x\n mhead _ = Nothing\n\ninstance Transaction ListAccessKeys ListAccessKeysResponse\n\ninstance IteratedTransaction ListAccessKeys ListAccessKeysResponse where\n nextIteratedRequest request response\n = case lakrMarker response of\n Nothing -> Nothing\n Just marker -> Just $ request { lakMarker = Just marker }\n\ninstance AsMemoryResponse ListAccessKeysResponse where\n type MemoryResponse ListAccessKeysResponse = ListAccessKeysResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/ListGroupPolicies.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.ListGroupPolicies\n ( ListGroupPolicies(..)\n , ListGroupPoliciesResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\nimport Text.XML.Cursor (content, laxElement, ($//), (&/))\n\n-- | Lists the group policies associated with the specified group.\n--\n-- \ndata ListGroupPolicies\n = ListGroupPolicies {\n lgpGroupName :: Text\n -- ^ Policies associated with this group will be listed.\n , lgpMarker :: Maybe Text\n -- ^ Used for paginating requests. Marks the position of the last\n -- request.\n , lgpMaxItems :: Maybe Integer\n -- ^ Used for paginating requests. Specifies the maximum number of items\n -- to return in the response. Defaults to 100.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery ListGroupPolicies where\n type ServiceConfiguration ListGroupPolicies = IamConfiguration\n signQuery ListGroupPolicies{..}\n = iamAction' \"ListGroupPolicies\" $ [\n Just (\"GroupName\", lgpGroupName)\n ] <> markedIter lgpMarker lgpMaxItems\n\ndata ListGroupPoliciesResponse\n = ListGroupPoliciesResponse {\n lgprPolicyNames :: [Text]\n -- ^ List of policy names.\n , lgprIsTruncated :: Bool\n -- ^ @True@ if the request was truncated because of too many items.\n , lgprMarker :: Maybe Text\n -- ^ Marks the position at which the request was truncated. This value\n -- must be passed with the next request to continue listing from the\n -- last position.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer ListGroupPolicies ListGroupPoliciesResponse where\n type ResponseMetadata ListGroupPoliciesResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n (lgprIsTruncated, lgprMarker) <- markedIterResponse cursor\n let lgprPolicyNames = cursor $// laxElement \"member\" &/ content\n return ListGroupPoliciesResponse{..}\n\ninstance Transaction ListGroupPolicies ListGroupPoliciesResponse\n\ninstance IteratedTransaction ListGroupPolicies ListGroupPoliciesResponse where\n nextIteratedRequest request response\n = case lgprMarker response of\n Nothing -> Nothing\n Just marker -> Just $ request { lgpMarker = Just marker }\n\ninstance AsMemoryResponse ListGroupPoliciesResponse where\n type MemoryResponse ListGroupPoliciesResponse = ListGroupPoliciesResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/ListGroups.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.ListGroups\n ( ListGroups(..)\n , ListGroupsResponse(..)\n , Group(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\nimport Text.XML.Cursor (laxElement, ($//), (&|))\n\n-- | Lists groups that have the specified path prefix.\n--\n-- \ndata ListGroups\n = ListGroups {\n lgPathPrefix :: Maybe Text\n -- ^ Groups defined under this path will be listed. If omitted, defaults\n -- to @/@, which lists all groups.\n , lgMarker :: Maybe Text\n -- ^ Used for paginating requests. Marks the position of the last\n -- request.\n , lgMaxItems :: Maybe Integer\n -- ^ Used for paginating requests. Specifies the maximum number of items\n -- to return in the response. Defaults to 100.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery ListGroups where\n type ServiceConfiguration ListGroups = IamConfiguration\n signQuery ListGroups{..}\n = iamAction' \"ListGroups\" $ [\n (\"PathPrefix\",) <$> lgPathPrefix\n ] <> markedIter lgMarker lgMaxItems\n\ndata ListGroupsResponse\n = ListGroupsResponse {\n lgrGroups :: [Group]\n -- ^ List of 'Group's.\n , lgrIsTruncated :: Bool\n -- ^ @True@ if the request was truncated because of too many items.\n , lgrMarker :: Maybe Text\n -- ^ Marks the position at which the request was truncated. This value\n -- must be passed with the next request to continue listing from the\n -- last position.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer ListGroups ListGroupsResponse where\n type ResponseMetadata ListGroupsResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n (lgrIsTruncated, lgrMarker) <- markedIterResponse cursor\n lgrGroups <- sequence $\n cursor $// laxElement \"member\" &| parseGroup\n return ListGroupsResponse{..}\n\ninstance Transaction ListGroups ListGroupsResponse\n\ninstance IteratedTransaction ListGroups ListGroupsResponse where\n nextIteratedRequest request response\n = case lgrMarker response of\n Nothing -> Nothing\n Just marker -> Just $ request { lgMarker = Just marker }\n\ninstance AsMemoryResponse ListGroupsResponse where\n type MemoryResponse ListGroupsResponse = ListGroupsResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/ListMfaDevices.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE RecordWildCards #-}\nmodule Aws.Iam.Commands.ListMfaDevices\n ( ListMfaDevices(..)\n , ListMfaDevicesResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\nimport Text.XML.Cursor (laxElement, ($//), (&|))\n-- | Lists the MFA devices. If the request includes the user name,\n-- then this action lists all the MFA devices associated with the\n-- specified user name. If you do not specify a user name, IAM\n-- determines the user name implicitly based on the AWS access key ID\n-- signing the request.\n--\n-- \n\ndata ListMfaDevices = ListMfaDevices\n { lmfaUserName :: Maybe Text\n -- ^ The name of the user whose MFA devices\n -- you want to list. If you do not specify a\n -- user name, IAM determines the user name\n -- implicitly based on the AWS access key ID\n -- signing the request\n , lmfaMarker :: Maybe Text\n -- ^ Used for paginating requests. Marks the\n -- position of the last request.\n , lmfaMaxItems :: Maybe Integer\n -- ^ Used for paginating requests. Specifies\n -- the maximum number of items to return in\n -- the response. Defaults to 100.\n } deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery ListMfaDevices where\n type ServiceConfiguration ListMfaDevices = IamConfiguration\n signQuery ListMfaDevices{..} = iamAction' \"ListMFADevices\"\n ([ (\"UserName\",) <$> lmfaUserName ]\n <> markedIter lmfaMarker lmfaMaxItems)\n\ndata ListMfaDevicesResponse = ListMfaDevicesResponse\n { lmfarMfaDevices :: [MfaDevice]\n -- ^ List of 'MFA Device's.\n , lmfarIsTruncated :: Bool\n -- ^ @True@ if the request was\n -- truncated because of too many\n -- items.\n , lmfarMarker :: Maybe Text\n -- ^ Marks the position at which the\n -- request was truncated. This value\n -- must be passed with the next\n -- request to continue listing from\n -- the last position.\n } deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer ListMfaDevices ListMfaDevicesResponse where\n type ResponseMetadata ListMfaDevicesResponse = IamMetadata\n responseConsumer _ _req =\n iamResponseConsumer $ \\ cursor -> do\n (lmfarIsTruncated, lmfarMarker) <- markedIterResponse cursor\n lmfarMfaDevices <-\n sequence $ cursor $// laxElement \"member\" &| parseMfaDevice\n return ListMfaDevicesResponse{..}\n\ninstance Transaction ListMfaDevices ListMfaDevicesResponse\n\ninstance IteratedTransaction ListMfaDevices ListMfaDevicesResponse where\n nextIteratedRequest request response\n = case lmfarMarker response of\n Nothing -> Nothing\n Just marker -> Just $ request { lmfaMarker = Just marker }\n\ninstance AsMemoryResponse ListMfaDevicesResponse where\n type MemoryResponse ListMfaDevicesResponse = ListMfaDevicesResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/ListUserPolicies.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.ListUserPolicies\n ( ListUserPolicies(..)\n , ListUserPoliciesResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\nimport Text.XML.Cursor (content, laxElement, ($//), (&/))\n\n-- | Lists the user policies associated with the specified user.\n--\n-- \ndata ListUserPolicies\n = ListUserPolicies {\n lupUserName :: Text\n -- ^ Policies associated with this user will be listed.\n , lupMarker :: Maybe Text\n -- ^ Used for paginating requests. Marks the position of the last\n -- request.\n , lupMaxItems :: Maybe Integer\n -- ^ Used for paginating requests. Specifies the maximum number of items\n -- to return in the response. Defaults to 100.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery ListUserPolicies where\n type ServiceConfiguration ListUserPolicies = IamConfiguration\n signQuery ListUserPolicies{..}\n = iamAction' \"ListUserPolicies\" $ [\n Just (\"UserName\", lupUserName)\n ] <> markedIter lupMarker lupMaxItems\n\ndata ListUserPoliciesResponse\n = ListUserPoliciesResponse {\n luprPolicyNames :: [Text]\n -- ^ List of policy names.\n , luprIsTruncated :: Bool\n -- ^ @True@ if the request was truncated because of too many items.\n , luprMarker :: Maybe Text\n -- ^ Marks the position at which the request was truncated. This value\n -- must be passed with the next request to continue listing from the\n -- last position.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer ListUserPolicies ListUserPoliciesResponse where\n type ResponseMetadata ListUserPoliciesResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n (luprIsTruncated, luprMarker) <- markedIterResponse cursor\n let luprPolicyNames = cursor $// laxElement \"member\" &/ content\n return ListUserPoliciesResponse{..}\n\ninstance Transaction ListUserPolicies ListUserPoliciesResponse\n\ninstance IteratedTransaction ListUserPolicies ListUserPoliciesResponse where\n nextIteratedRequest request response\n = case luprMarker response of\n Nothing -> Nothing\n Just marker -> Just $ request { lupMarker = Just marker }\n\ninstance AsMemoryResponse ListUserPoliciesResponse where\n type MemoryResponse ListUserPoliciesResponse = ListUserPoliciesResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/ListUsers.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.ListUsers\n ( ListUsers(..)\n , ListUsersResponse(..)\n , User(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\nimport Text.XML.Cursor (laxElement, ($//), (&|))\n\n-- | Lists users that have the specified path prefix.\n--\n-- \ndata ListUsers\n = ListUsers {\n luPathPrefix :: Maybe Text\n -- ^ Users defined under this path will be listed. If omitted, defaults\n -- to @/@, which lists all users.\n , luMarker :: Maybe Text\n -- ^ Used for paginating requests. Marks the position of the last\n -- request.\n , luMaxItems :: Maybe Integer\n -- ^ Used for paginating requests. Specifies the maximum number of items\n -- to return in the response. Defaults to 100.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery ListUsers where\n type ServiceConfiguration ListUsers = IamConfiguration\n signQuery ListUsers{..}\n = iamAction' \"ListUsers\" $ [\n (\"PathPrefix\",) <$> luPathPrefix\n ] <> markedIter luMarker luMaxItems\n\ndata ListUsersResponse\n = ListUsersResponse {\n lurUsers :: [User]\n -- ^ List of 'User's.\n , lurIsTruncated :: Bool\n -- ^ @True@ if the request was truncated because of too many items.\n , lurMarker :: Maybe Text\n -- ^ Marks the position at which the request was truncated. This value\n -- must be passed with the next request to continue listing from the\n -- last position.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer ListUsers ListUsersResponse where\n type ResponseMetadata ListUsersResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer $ \\cursor -> do\n (lurIsTruncated, lurMarker) <- markedIterResponse cursor\n lurUsers <- sequence $\n cursor $// laxElement \"member\" &| parseUser\n return ListUsersResponse{..}\n\ninstance Transaction ListUsers ListUsersResponse\n\ninstance IteratedTransaction ListUsers ListUsersResponse where\n nextIteratedRequest request response\n = case lurMarker response of\n Nothing -> Nothing\n Just marker -> Just $ request { luMarker = Just marker }\n\ninstance AsMemoryResponse ListUsersResponse where\n type MemoryResponse ListUsersResponse = ListUsersResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/PutGroupPolicy.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.PutGroupPolicy\n ( PutGroupPolicy(..)\n , PutGroupPolicyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Adds a policy document with the specified name, associated with the\n-- specified group.\n--\n-- \ndata PutGroupPolicy\n = PutGroupPolicy {\n pgpPolicyDocument :: Text\n -- ^ The policy document.\n , pgpPolicyName :: Text\n -- ^ Name of the policy.\n , pgpGroupName :: Text\n -- ^ Name of the group with whom this policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery PutGroupPolicy where\n type ServiceConfiguration PutGroupPolicy = IamConfiguration\n signQuery PutGroupPolicy{..}\n = iamAction \"PutGroupPolicy\" [\n (\"PolicyDocument\", pgpPolicyDocument)\n , (\"PolicyName\" , pgpPolicyName)\n , (\"GroupName\" , pgpGroupName)\n ]\n\ndata PutGroupPolicyResponse = PutGroupPolicyResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer PutGroupPolicy PutGroupPolicyResponse where\n type ResponseMetadata PutGroupPolicyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return PutGroupPolicyResponse)\n\ninstance Transaction PutGroupPolicy PutGroupPolicyResponse\n\ninstance AsMemoryResponse PutGroupPolicyResponse where\n type MemoryResponse PutGroupPolicyResponse = PutGroupPolicyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/PutUserPolicy.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.PutUserPolicy\n ( PutUserPolicy(..)\n , PutUserPolicyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Adds a policy document with the specified name, associated with the\n-- specified user.\n--\n-- \ndata PutUserPolicy\n = PutUserPolicy {\n pupPolicyDocument :: Text\n -- ^ The policy document.\n , pupPolicyName :: Text\n -- ^ Name of the policy.\n , pupUserName :: Text\n -- ^ Name of the user with whom this policy is associated.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery PutUserPolicy where\n type ServiceConfiguration PutUserPolicy = IamConfiguration\n signQuery PutUserPolicy{..}\n = iamAction \"PutUserPolicy\" [\n (\"PolicyDocument\", pupPolicyDocument)\n , (\"PolicyName\" , pupPolicyName)\n , (\"UserName\" , pupUserName)\n ]\n\ndata PutUserPolicyResponse = PutUserPolicyResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer PutUserPolicy PutUserPolicyResponse where\n type ResponseMetadata PutUserPolicyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return PutUserPolicyResponse)\n\ninstance Transaction PutUserPolicy PutUserPolicyResponse\n\ninstance AsMemoryResponse PutUserPolicyResponse where\n type MemoryResponse PutUserPolicyResponse = PutUserPolicyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/RemoveUserFromGroup.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.RemoveUserFromGroup\n ( RemoveUserFromGroup(..)\n , RemoveUserFromGroupResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Data.Text (Text)\nimport Data.Typeable\n\n-- | Removes the specified user from the specified group.\n--\n-- \ndata RemoveUserFromGroup\n = RemoveUserFromGroup {\n rufgGroupName :: Text\n -- ^ Name of the group to update.\n , rufgUserName :: Text\n -- ^ The of the user to add.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery RemoveUserFromGroup where\n type ServiceConfiguration RemoveUserFromGroup = IamConfiguration\n signQuery RemoveUserFromGroup{..}\n = iamAction \"RemoveUserFromGroup\" [\n (\"GroupName\" , rufgGroupName)\n , (\"UserName\" , rufgUserName)\n ]\n\ndata RemoveUserFromGroupResponse = RemoveUserFromGroupResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer RemoveUserFromGroup RemoveUserFromGroupResponse where\n type ResponseMetadata RemoveUserFromGroupResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return RemoveUserFromGroupResponse)\n\ninstance Transaction RemoveUserFromGroup RemoveUserFromGroupResponse\n\ninstance AsMemoryResponse RemoveUserFromGroupResponse where\n type MemoryResponse RemoveUserFromGroupResponse = RemoveUserFromGroupResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/UpdateAccessKey.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.UpdateAccessKey\n ( UpdateAccessKey(..)\n , UpdateAccessKeyResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Changes the status of the specified access key.\n--\n-- \ndata UpdateAccessKey\n = UpdateAccessKey {\n uakAccessKeyId :: Text\n -- ^ ID of the access key to update.\n , uakStatus :: AccessKeyStatus\n -- ^ New status of the access key.\n , uakUserName :: Maybe Text\n -- ^ Name of the user to whom the access key belongs. If omitted, the\n -- user will be determined based on the access key used to sign the\n -- request.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery UpdateAccessKey where\n type ServiceConfiguration UpdateAccessKey = IamConfiguration\n signQuery UpdateAccessKey{..}\n = iamAction' \"UpdateAccessKey\" [\n Just (\"AccessKeyId\", uakAccessKeyId)\n , Just (\"Status\", showStatus uakStatus)\n , (\"UserName\",) <$> uakUserName\n ]\n where\n showStatus AccessKeyActive = \"Active\"\n showStatus _ = \"Inactive\"\n\ndata UpdateAccessKeyResponse = UpdateAccessKeyResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer UpdateAccessKey UpdateAccessKeyResponse where\n type ResponseMetadata UpdateAccessKeyResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return UpdateAccessKeyResponse)\n\ninstance Transaction UpdateAccessKey UpdateAccessKeyResponse\n\ninstance AsMemoryResponse UpdateAccessKeyResponse where\n type MemoryResponse UpdateAccessKeyResponse = UpdateAccessKeyResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/UpdateGroup.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.UpdateGroup\n ( UpdateGroup(..)\n , UpdateGroupResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Updates the name and/or path of the specified group.\n--\n-- \ndata UpdateGroup\n = UpdateGroup {\n ugGroupName :: Text\n -- ^ Name of the group to be updated.\n , ugNewGroupName :: Maybe Text\n -- ^ New name for the group.\n , ugNewPath :: Maybe Text\n -- ^ New path to which the group will be moved.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery UpdateGroup where\n type ServiceConfiguration UpdateGroup = IamConfiguration\n signQuery UpdateGroup{..}\n = iamAction' \"UpdateGroup\" [\n Just (\"GroupName\", ugGroupName)\n , (\"NewGroupName\",) <$> ugNewGroupName\n , (\"NewPath\",) <$> ugNewPath\n ]\n\ndata UpdateGroupResponse = UpdateGroupResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer UpdateGroup UpdateGroupResponse where\n type ResponseMetadata UpdateGroupResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return UpdateGroupResponse)\n\ninstance Transaction UpdateGroup UpdateGroupResponse\n\ninstance AsMemoryResponse UpdateGroupResponse where\n type MemoryResponse UpdateGroupResponse = UpdateGroupResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands/UpdateUser.hs", "content": "{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule Aws.Iam.Commands.UpdateUser\n ( UpdateUser(..)\n , UpdateUserResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Aws.Iam.Internal\nimport Control.Applicative\nimport Data.Text (Text)\nimport Data.Typeable\nimport Prelude\n\n-- | Updates the name and/or path of the specified user.\n--\n-- \ndata UpdateUser\n = UpdateUser {\n uuUserName :: Text\n -- ^ Name of the user to be updated.\n , uuNewUserName :: Maybe Text\n -- ^ New name for the user.\n , uuNewPath :: Maybe Text\n -- ^ New path to which the user will be moved.\n }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SignQuery UpdateUser where\n type ServiceConfiguration UpdateUser = IamConfiguration\n signQuery UpdateUser{..}\n = iamAction' \"UpdateUser\" [\n Just (\"UserName\", uuUserName)\n , (\"NewUserName\",) <$> uuNewUserName\n , (\"NewPath\",) <$> uuNewPath\n ]\n\ndata UpdateUserResponse = UpdateUserResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer UpdateUser UpdateUserResponse where\n type ResponseMetadata UpdateUserResponse = IamMetadata\n responseConsumer _ _\n = iamResponseConsumer (const $ return UpdateUserResponse)\n\ninstance Transaction UpdateUser UpdateUserResponse\n\ninstance AsMemoryResponse UpdateUserResponse where\n type MemoryResponse UpdateUserResponse = UpdateUserResponse\n loadToMemory = return\n" }, { "path": "Aws/Iam/Commands.hs", "content": "module Aws.Iam.Commands\n ( module Aws.Iam.Commands.AddUserToGroup\n , module Aws.Iam.Commands.CreateAccessKey\n , module Aws.Iam.Commands.CreateGroup\n , module Aws.Iam.Commands.CreateUser\n , module Aws.Iam.Commands.DeleteAccessKey\n , module Aws.Iam.Commands.DeleteGroup\n , module Aws.Iam.Commands.DeleteGroupPolicy\n , module Aws.Iam.Commands.DeleteUser\n , module Aws.Iam.Commands.DeleteUserPolicy\n , module Aws.Iam.Commands.GetGroupPolicy\n , module Aws.Iam.Commands.GetUser\n , module Aws.Iam.Commands.GetUserPolicy\n , module Aws.Iam.Commands.ListAccessKeys\n , module Aws.Iam.Commands.ListMfaDevices\n , module Aws.Iam.Commands.ListGroupPolicies\n , module Aws.Iam.Commands.ListGroups\n , module Aws.Iam.Commands.ListUserPolicies\n , module Aws.Iam.Commands.ListUsers\n , module Aws.Iam.Commands.PutGroupPolicy\n , module Aws.Iam.Commands.PutUserPolicy\n , module Aws.Iam.Commands.RemoveUserFromGroup\n , module Aws.Iam.Commands.UpdateAccessKey\n , module Aws.Iam.Commands.UpdateGroup\n , module Aws.Iam.Commands.UpdateUser\n ) where\n\nimport Aws.Iam.Commands.AddUserToGroup\nimport Aws.Iam.Commands.CreateAccessKey\nimport Aws.Iam.Commands.CreateGroup\nimport Aws.Iam.Commands.CreateUser\nimport Aws.Iam.Commands.DeleteAccessKey\nimport Aws.Iam.Commands.DeleteGroup\nimport Aws.Iam.Commands.DeleteGroupPolicy\nimport Aws.Iam.Commands.DeleteUser\nimport Aws.Iam.Commands.DeleteUserPolicy\nimport Aws.Iam.Commands.GetGroupPolicy\nimport Aws.Iam.Commands.GetUser\nimport Aws.Iam.Commands.GetUserPolicy\nimport Aws.Iam.Commands.ListAccessKeys\nimport Aws.Iam.Commands.ListMfaDevices\nimport Aws.Iam.Commands.ListGroupPolicies\nimport Aws.Iam.Commands.ListGroups\nimport Aws.Iam.Commands.ListUserPolicies\nimport Aws.Iam.Commands.ListUsers\nimport Aws.Iam.Commands.PutGroupPolicy\nimport Aws.Iam.Commands.PutUserPolicy\nimport Aws.Iam.Commands.RemoveUserFromGroup\nimport Aws.Iam.Commands.UpdateAccessKey\nimport Aws.Iam.Commands.UpdateGroup\nimport Aws.Iam.Commands.UpdateUser\n" }, { "path": "Aws/Iam/Core.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE RecordWildCards #-}\nmodule Aws.Iam.Core\n ( iamSignQuery\n , iamResponseConsumer\n , IamMetadata(..)\n , IamConfiguration(..)\n , IamError(..)\n\n , parseDateTime\n\n , AccessKeyStatus(..)\n , User(..)\n , parseUser\n , Group(..)\n , parseGroup\n , MfaDevice(..)\n , parseMfaDevice\n ) where\n\nimport Aws.Core\nimport qualified Blaze.ByteString.Builder as Blaze\nimport qualified Blaze.ByteString.Builder.Char8 as Blaze8\nimport Control.Exception (Exception)\nimport Control.Monad\nimport Control.Monad.Trans.Resource (MonadThrow, throwM)\nimport Data.ByteString (ByteString)\nimport Data.IORef\nimport Data.List (intersperse, sort)\nimport Data.Maybe\nimport Data.Monoid ()\nimport qualified Data.Semigroup as Sem\nimport Data.Text (Text)\nimport qualified Data.Text as Text\nimport Data.Time\nimport Data.Typeable\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport Text.XML.Cursor (($//))\nimport qualified Text.XML.Cursor as Cu\n\ndata IamError\n = IamError {\n iamStatusCode :: HTTP.Status\n , iamErrorCode :: Text\n , iamErrorMessage :: Text\n }\n deriving (Show, Typeable)\n\ninstance Exception IamError\n\ndata IamMetadata\n = IamMetadata {\n requestId :: Maybe Text\n }\n deriving (Show, Typeable)\n\ninstance Loggable IamMetadata where\n toLogText (IamMetadata r) = \"IAM: request ID=\" Sem.<> fromMaybe \"\" r\n\ninstance Sem.Semigroup IamMetadata where\n IamMetadata r1 <> IamMetadata r2 = IamMetadata (r1 `mplus` r2)\n\ninstance Monoid IamMetadata where\n mempty = IamMetadata Nothing\n mappend = (Sem.<>)\n\ndata IamConfiguration qt\n = IamConfiguration {\n iamEndpoint :: ByteString\n , iamPort :: Int\n , iamProtocol :: Protocol\n , iamHttpMethod :: Method\n }\n deriving (Show)\n\ninstance DefaultServiceConfiguration (IamConfiguration NormalQuery) where\n defServiceConfig = iam PostQuery HTTPS iamEndpointDefault\n debugServiceConfig = iam PostQuery HTTP iamEndpointDefault\n\ninstance DefaultServiceConfiguration (IamConfiguration UriOnlyQuery) where\n defServiceConfig = iam Get HTTPS iamEndpointDefault\n debugServiceConfig = iam Get HTTP iamEndpointDefault\n\n-- | The default IAM endpoint.\niamEndpointDefault :: ByteString\niamEndpointDefault = \"iam.amazonaws.com\"\n\n-- | Constructs an IamConfiguration with the specified parameters.\niam :: Method -> Protocol -> ByteString -> IamConfiguration qt\niam method protocol endpoint\n = IamConfiguration {\n iamEndpoint = endpoint\n , iamProtocol = protocol\n , iamPort = defaultPort protocol\n , iamHttpMethod = method\n }\n\n-- | Constructs a 'SignedQuery' with the specified request parameters.\niamSignQuery\n :: [(ByteString, ByteString)]\n -- ^ Pairs of parameter names and values that will be passed as part of\n -- the request data.\n -> IamConfiguration qt\n -> SignatureData\n -> SignedQuery\niamSignQuery q IamConfiguration{..} SignatureData{..}\n = SignedQuery {\n sqMethod = iamHttpMethod\n , sqProtocol = iamProtocol\n , sqHost = iamEndpoint\n , sqPort = iamPort\n , sqPath = \"/\"\n , sqQuery = signedQuery\n , sqDate = Just signatureTime\n , sqAuthorization = Nothing\n , sqContentType = Nothing\n , sqContentMd5 = Nothing\n , sqAmzHeaders = []\n , sqOtherHeaders = []\n , sqBody = Nothing\n , sqStringToSign = stringToSign\n }\n where\n sig = signature signatureCredentials HmacSHA256 stringToSign\n signedQuery = (\"Signature\", Just sig):expandedQuery\n accessKey = accessKeyID signatureCredentials\n timestampHeader =\n case signatureTimeInfo of\n AbsoluteTimestamp time -> (\"Timestamp\", Just $ fmtAmzTime time)\n AbsoluteExpires time -> (\"Expires\" , Just $ fmtAmzTime time)\n newline = Blaze8.fromChar '\\n'\n stringToSign = Blaze.toByteString . mconcat . intersperse newline $\n map Blaze.copyByteString\n [httpMethod iamHttpMethod, iamEndpoint, \"/\"]\n ++ [HTTP.renderQueryBuilder False expandedQuery]\n expandedQuery = HTTP.toQuery . sort $ (map (\\(a,b) -> (a, Just b)) q ++) [\n (\"AWSAccessKeyId\" , Just accessKey)\n , (\"SignatureMethod\" , Just $ amzHash HmacSHA256)\n , (\"SignatureVersion\", Just \"2\")\n , (\"Version\" , Just \"2010-05-08\")\n , timestampHeader] ++\n maybe [] (\\tok -> [ (\"SecurityToken\", Just tok)]) (iamToken signatureCredentials)\n\n-- | Reads the metadata from an IAM response and delegates parsing the rest of\n-- the data from the response to the given function.\niamResponseConsumer :: (Cu.Cursor -> Response IamMetadata a)\n -> IORef IamMetadata\n -> HTTPResponseConsumer a\niamResponseConsumer inner md resp = xmlCursorConsumer parse md resp\n where\n parse cursor = do\n let rid = listToMaybe $ cursor $// elContent \"RequestID\"\n tellMetadata $ IamMetadata rid\n case cursor $// Cu.laxElement \"Error\" of\n [] -> inner cursor\n (err:_) -> fromError err\n fromError cursor = do\n errCode <- force \"Missing Error Code\" $ cursor $// elContent \"Code\"\n errMsg <- force \"Missing Error Message\" $ cursor $// elContent \"Message\"\n throwM $ IamError (HTTP.responseStatus resp) errCode errMsg\n\n-- | Parses IAM @DateTime@ data type.\nparseDateTime :: MonadThrow m => String -> m UTCTime\nparseDateTime x\n = case parseTimeM True defaultTimeLocale iso8601UtcDate x of\n Nothing -> throwM $ XmlException $ \"Invalid DateTime: \" ++ x\n Just dt -> return dt\n\n-- | The IAM @User@ data type.\n--\n-- \ndata User\n = User {\n userArn :: Text\n -- ^ ARN used to refer to this user.\n , userCreateDate :: UTCTime\n -- ^ Date and time at which the user was created.\n , userPath :: Text\n -- ^ Path under which the user was created.\n , userUserId :: Text\n -- ^ Unique identifier used to refer to this user. \n , userUserName :: Text\n -- ^ Name of the user.\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | Parses the IAM @User@ data type.\nparseUser :: MonadThrow m => Cu.Cursor -> m User\nparseUser cursor = do\n userArn <- attr \"Arn\"\n userCreateDate <- attr \"CreateDate\" >>= parseDateTime . Text.unpack\n userPath <- attr \"Path\"\n userUserId <- attr \"UserId\"\n userUserName <- attr \"UserName\"\n return User{..}\n where\n attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n\n\n-- | The IAM @Group@ data type.\n--\n-- \ndata Group\n = Group {\n groupArn :: Text\n -- ^ ARN used to refer to this group.\n , groupCreateDate :: UTCTime\n -- ^ Date and time at which the group was created.\n , groupPath :: Text\n -- ^ Path under which the group was created.\n , groupGroupId :: Text\n -- ^ Unique identifier used to refer to this group. \n , groupGroupName :: Text\n -- ^ Name of the group.\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | Parses the IAM @Group@ data type.\nparseGroup :: MonadThrow m => Cu.Cursor -> m Group\nparseGroup cursor = do\n groupArn <- attr \"Arn\"\n groupCreateDate <- attr \"CreateDate\" >>= parseDateTime . Text.unpack\n groupPath <- attr \"Path\"\n groupGroupId <- attr \"GroupId\"\n groupGroupName <- attr \"GroupName\"\n return Group{..}\n where\n attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n\n\ndata AccessKeyStatus = AccessKeyActive | AccessKeyInactive\n deriving (Eq, Ord, Show, Typeable)\n\n-- | The IAM @MFADevice@ data type.\n--\n-- \ndata MfaDevice = MfaDevice\n { mfaEnableDate :: UTCTime\n -- ^ The date when the MFA device was enabled for\n -- the user.\n , mfaSerialNumber :: Text\n -- ^ The serial number that uniquely identifies the\n -- MFA device. For virtual MFA devices, the serial\n -- number is the device ARN.\n , mfaUserName :: Text\n -- ^ The user with whom the MFA device is\n -- associated. Minimum length of 1. Maximum length\n -- of 64.\n } deriving (Eq, Ord, Show, Typeable)\n\n-- | Parses the IAM @MFADevice@ data type.\nparseMfaDevice :: MonadThrow m => Cu.Cursor -> m MfaDevice\nparseMfaDevice cursor = do\n mfaEnableDate <- attr \"EnableDate\" >>= parseDateTime . Text.unpack\n mfaSerialNumber <- attr \"SerialNumber\"\n mfaUserName <- attr \"UserName\"\n return MfaDevice{..}\n where attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n" }, { "path": "Aws/Iam/Internal.hs", "content": "{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n{-# LANGUAGE TupleSections #-}\nmodule Aws.Iam.Internal\n ( iamAction\n , iamAction'\n , markedIter\n , markedIterResponse\n\n -- * Re-exports\n , (<>)\n ) where\n\nimport Aws.Core\nimport Aws.Iam.Core\nimport Control.Applicative\nimport Control.Arrow (second)\nimport Control.Monad\nimport Control.Monad.Trans.Resource (MonadThrow)\nimport Data.ByteString (ByteString)\nimport Data.Maybe\nimport Data.Monoid\nimport Prelude\nimport Data.Text (Text)\nimport qualified Data.Text as Text\nimport qualified Data.Text.Encoding as Text\nimport Text.XML.Cursor (($//))\nimport qualified Text.XML.Cursor as Cu\n\n-- | Similar to 'iamSignQuery'. Accepts parameters in @Text@ form and UTF-8\n-- encodes them. Accepts the @Action@ parameter separately since it's always\n-- required.\niamAction\n :: ByteString\n -> [(ByteString, Text)]\n -> IamConfiguration qt\n -> SignatureData\n -> SignedQuery\niamAction action = iamSignQuery\n . (:) (\"Action\", action)\n . map (second Text.encodeUtf8)\n\n-- | Similar to 'iamAction'. Accepts parameter list with @Maybe@ parameters.\n-- Ignores @Nothing@s.\niamAction'\n :: ByteString\n -> [Maybe (ByteString, Text)]\n -> IamConfiguration qt\n -> SignatureData\n -> SignedQuery\niamAction' action = iamAction action . catMaybes\n\n-- | Returns the parameters @Marker@ and @MaxItems@ that are present in all\n-- IAM data pagination requests.\nmarkedIter :: Maybe Text -> Maybe Integer -> [Maybe (ByteString, Text)]\nmarkedIter marker maxItems\n = [ (\"Marker\" ,) <$> marker\n , (\"MaxItems\",) . encodeInteger <$> maxItems\n ]\n where\n encodeInteger = Text.pack . show\n\n-- | Reads and returns the @IsTruncated@ and @Marker@ attributes present in\n-- all IAM data pagination responses.\nmarkedIterResponse\n :: MonadThrow m\n => Cu.Cursor\n -> m (Bool, Maybe Text)\nmarkedIterResponse cursor = do\n isTruncated <- (Text.toCaseFold \"true\" ==) `liftM` attr \"IsTruncated\"\n marker <- if isTruncated\n then Just `liftM` attr \"Marker\"\n else return Nothing\n return (isTruncated, marker)\n where\n attr name = force (\"Missing \" ++ Text.unpack name) $\n cursor $// elContent name\n" }, { "path": "Aws/Iam.hs", "content": "module Aws.Iam\n ( module Aws.Iam.Commands\n , module Aws.Iam.Core\n ) where\n\nimport Aws.Iam.Commands\nimport Aws.Iam.Core\n" }, { "path": "Aws/Network.hs", "content": "module Aws.Network where\n\nimport Data.Maybe\nimport Control.Exception\nimport Network.BSD (getProtocolNumber)\nimport Network.Socket\nimport System.Timeout\n\n-- Make a good guess if a host is reachable.\nhostAvailable :: String -> IO Bool\nhostAvailable h = do\n sock <- getProtocolNumber \"tcp\" >>= socket AF_INET Stream\n addr <- (addrAddress . head) `fmap` getAddrInfo (Just (defaultHints { addrFlags = [ AI_PASSIVE ] } )) (Just h) (Just \"80\")\n case addr of\n remote@(SockAddrInet _ _) -> do\n v <- catch (timeout 100000 (connect sock remote) >>= return . isJust)\n (\\(_ :: SomeException) -> return False)\n close sock\n return v\n _ -> return False\n" }, { "path": "Aws/S3/Commands/CopyObject.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Aws.S3.Commands.CopyObject\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Control.Arrow (second)\nimport Control.Monad.Trans.Resource (throwM)\nimport qualified Data.ByteString as B\nimport qualified Data.CaseInsensitive as CI\nimport Data.Maybe\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport Data.Time\nimport qualified Network.HTTP.Conduit as HTTP\nimport Text.XML.Cursor (($/), (&|))\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport Prelude\n\ndata CopyMetadataDirective = CopyMetadata | ReplaceMetadata [(T.Text,T.Text)]\n deriving (Show)\n\ndata CopyObject = CopyObject { coObjectName :: T.Text\n , coBucket :: Bucket\n , coSource :: ObjectId\n , coMetadataDirective :: CopyMetadataDirective\n , coIfMatch :: Maybe T.Text\n , coIfNoneMatch :: Maybe T.Text\n , coIfUnmodifiedSince :: Maybe UTCTime\n , coIfModifiedSince :: Maybe UTCTime\n , coStorageClass :: Maybe StorageClass\n , coAcl :: Maybe CannedAcl\n , coContentType :: Maybe B.ByteString\n }\n deriving (Show)\n\ncopyObject :: Bucket -> T.Text -> ObjectId -> CopyMetadataDirective -> CopyObject\ncopyObject bucket obj src meta = CopyObject obj bucket src meta Nothing Nothing Nothing Nothing Nothing Nothing Nothing\n\ndata CopyObjectResponse\n = CopyObjectResponse {\n corVersionId :: Maybe T.Text\n , corLastModified :: UTCTime\n , corETag :: T.Text\n }\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery CopyObject where\n type ServiceConfiguration CopyObject = S3Configuration\n signQuery CopyObject {..} = s3SignQuery S3Query {\n s3QMethod = Put\n , s3QBucket = Just $ T.encodeUtf8 coBucket\n , s3QObject = Just $ T.encodeUtf8 coObjectName\n , s3QSubresources = []\n , s3QQuery = []\n , s3QContentType = coContentType\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [\n Just (\"x-amz-copy-source\",\n oidBucket `T.append` \"/\" `T.append` oidObject `T.append`\n case oidVersion of\n Nothing -> T.empty\n Just v -> \"?versionId=\" `T.append` v)\n , Just (\"x-amz-metadata-directive\", case coMetadataDirective of\n CopyMetadata -> \"COPY\"\n ReplaceMetadata _ -> \"REPLACE\")\n , (\"x-amz-copy-source-if-match\",)\n <$> coIfMatch\n , (\"x-amz-copy-source-if-none-match\",)\n <$> coIfNoneMatch\n , (\"x-amz-copy-source-if-unmodified-since\",)\n <$> textHttpDate <$> coIfUnmodifiedSince\n , (\"x-amz-copy-source-if-modified-since\",)\n <$> textHttpDate <$> coIfModifiedSince\n , (\"x-amz-acl\",)\n <$> writeCannedAcl <$> coAcl\n , (\"x-amz-storage-class\",)\n <$> writeStorageClass <$> coStorageClass\n ] ++ map ( \\x -> (CI.mk . T.encodeUtf8 $\n T.concat [\"x-amz-meta-\", fst x], snd x))\n coMetadata\n , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes []\n , s3QRequestBody = Nothing\n }\n where coMetadata = case coMetadataDirective of\n CopyMetadata -> []\n ReplaceMetadata xs -> xs\n ObjectId{..} = coSource\n\ninstance ResponseConsumer CopyObject CopyObjectResponse where\n type ResponseMetadata CopyObjectResponse = S3Metadata\n responseConsumer _ _ mref = flip s3ResponseConsumer mref $ \\resp -> do\n let vid = T.decodeUtf8 `fmap` lookup \"x-amz-version-id\" (HTTP.responseHeaders resp)\n (lastMod, etag) <- xmlCursorConsumer parse mref resp\n return $ CopyObjectResponse vid lastMod etag\n where parse el = do\n let parseHttpDate' x = case parseTimeM True defaultTimeLocale iso8601UtcDate x of\n Nothing -> throwM $ XmlException (\"Invalid Last-Modified \" ++ x)\n Just y -> return y\n lastMod <- forceM \"Missing Last-Modified\" $ el $/ elContent \"LastModified\" &| (parseHttpDate' . T.unpack)\n etag <- force \"Missing ETag\" $ el $/ elContent \"ETag\"\n return (lastMod, etag)\n\n\ninstance Transaction CopyObject CopyObjectResponse\n\ninstance AsMemoryResponse CopyObjectResponse where\n type MemoryResponse CopyObjectResponse = CopyObjectResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/DeleteBucket.hs", "content": "module Aws.S3.Commands.DeleteBucket\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Data.ByteString.Char8 ({- IsString -})\nimport qualified Data.Text.Encoding as T\n\ndata DeleteBucket = DeleteBucket { dbBucket :: Bucket }\n deriving (Show)\n\ndata DeleteBucketResponse = DeleteBucketResponse {}\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery DeleteBucket where\n type ServiceConfiguration DeleteBucket = S3Configuration\n signQuery DeleteBucket {..} = s3SignQuery S3Query {\n s3QMethod = Delete\n , s3QBucket = Just $ T.encodeUtf8 dbBucket\n , s3QSubresources = []\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n , s3QObject = Nothing\n }\n\ninstance ResponseConsumer DeleteBucket DeleteBucketResponse where\n type ResponseMetadata DeleteBucketResponse = S3Metadata\n responseConsumer _ _ = s3ResponseConsumer $ \\_ -> return DeleteBucketResponse\n\ninstance Transaction DeleteBucket DeleteBucketResponse\n\ninstance AsMemoryResponse DeleteBucketResponse where\n type MemoryResponse DeleteBucketResponse = DeleteBucketResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/DeleteObject.hs", "content": "module Aws.S3.Commands.DeleteObject\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Data.ByteString.Char8 ({- IsString -})\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\n\ndata DeleteObject = DeleteObject {\n doObjectName :: T.Text,\n doBucket :: Bucket\n} deriving (Show)\n\ndata DeleteObjectResponse = DeleteObjectResponse{\n} deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery DeleteObject where\n type ServiceConfiguration DeleteObject = S3Configuration\n signQuery DeleteObject {..} = s3SignQuery S3Query {\n s3QMethod = Delete\n , s3QBucket = Just $ T.encodeUtf8 doBucket\n , s3QSubresources = []\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n , s3QObject = Just $ T.encodeUtf8 doObjectName\n }\n\ninstance ResponseConsumer DeleteObject DeleteObjectResponse where\n type ResponseMetadata DeleteObjectResponse = S3Metadata\n responseConsumer _ _\n = s3ResponseConsumer $ \\_ -> return DeleteObjectResponse\n\ninstance Transaction DeleteObject DeleteObjectResponse\n\ninstance AsMemoryResponse DeleteObjectResponse where\n type MemoryResponse DeleteObjectResponse = DeleteObjectResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/DeleteObjectVersion.hs", "content": "module Aws.S3.Commands.DeleteObjectVersion\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Data.ByteString.Char8 ({- IsString -})\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\n\ndata DeleteObjectVersion = DeleteObjectVersion {\n dovObjectName :: T.Text,\n dovBucket :: Bucket,\n dovVersionId :: T.Text\n} deriving (Show)\n\ndeleteObjectVersion :: Bucket -> T.Text -> T.Text -> DeleteObjectVersion\ndeleteObjectVersion bucket object version\n = DeleteObjectVersion {\n dovObjectName = object\n , dovBucket = bucket\n , dovVersionId = version\n }\n\ndata DeleteObjectVersionResponse = DeleteObjectVersionResponse {\n} deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery DeleteObjectVersion where\n type ServiceConfiguration DeleteObjectVersion = S3Configuration\n signQuery DeleteObjectVersion {..} = s3SignQuery S3Query {\n s3QMethod = Delete\n , s3QBucket = Just $ T.encodeUtf8 dovBucket\n , s3QSubresources = [ (\"versionId\", Just $ T.encodeUtf8 dovVersionId) ]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n , s3QObject = Just $ T.encodeUtf8 dovObjectName\n }\n\ninstance ResponseConsumer DeleteObjectVersion DeleteObjectVersionResponse where\n type ResponseMetadata DeleteObjectVersionResponse = S3Metadata\n responseConsumer _ _\n = s3ResponseConsumer $ \\_ -> return DeleteObjectVersionResponse\n\ninstance Transaction DeleteObjectVersion DeleteObjectVersionResponse\n\ninstance AsMemoryResponse DeleteObjectVersionResponse where\n type MemoryResponse DeleteObjectVersionResponse = DeleteObjectVersionResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/DeleteObjects.hs", "content": "module Aws.S3.Commands.DeleteObjects where\n\nimport Aws.Core\nimport Aws.S3.Core\nimport qualified Crypto.Hash as CH\nimport qualified Data.Map as M\nimport Data.Maybe\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport qualified Text.XML as XML\nimport qualified Text.XML.Cursor as Cu\nimport Text.XML.Cursor (($/), (&|))\nimport qualified Data.ByteString.Char8 as B\nimport Data.ByteString.Char8 ({- IsString -})\nimport Control.Applicative\nimport Prelude\n\ndata DeleteObjects\n = DeleteObjects {\n dosBucket :: Bucket\n , dosObjects :: [(Object, Maybe T.Text)] -- snd is an optional versionId\n , dosQuiet :: Bool\n , dosMultiFactorAuthentication :: Maybe T.Text\n }\n deriving (Show)\n\n-- simple use case: neither mfa, nor version specified, quiet\ndeleteObjects :: Bucket -> [T.Text] -> DeleteObjects\ndeleteObjects bucket objs =\n DeleteObjects {\n dosBucket = bucket\n , dosObjects = zip objs $ repeat Nothing\n , dosQuiet = True\n , dosMultiFactorAuthentication = Nothing\n }\n\ndata DeleteObjectsResponse\n = DeleteObjectsResponse {\n dorDeleted :: [DORDeleted]\n , dorErrors :: [DORErrors]\n }\n deriving (Show)\n\n--omitting DeleteMarker because it appears superfluous\ndata DORDeleted\n = DORDeleted {\n ddKey :: T.Text\n , ddVersionId :: Maybe T.Text\n , ddDeleteMarkerVersionId :: Maybe T.Text\n }\n deriving (Show)\n\ndata DORErrors\n = DORErrors {\n deKey :: T.Text\n , deCode :: T.Text\n , deMessage :: T.Text\n }\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery DeleteObjects where\n type ServiceConfiguration DeleteObjects = S3Configuration\n\n signQuery DeleteObjects {..} = s3SignQuery S3Query\n {\n s3QMethod = Post\n , s3QBucket = Just $ T.encodeUtf8 dosBucket\n , s3QSubresources = HTTP.toQuery [(\"delete\" :: B.ByteString, Nothing :: Maybe B.ByteString)]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Just $ CH.hashlazy dosBody\n , s3QObject = Nothing\n , s3QAmzHeaders = maybeToList $ ((\"x-amz-mfa\", ) . T.encodeUtf8) <$> dosMultiFactorAuthentication\n , s3QOtherHeaders = []\n , s3QRequestBody = Just $ HTTP.RequestBodyLBS dosBody\n }\n where dosBody = XML.renderLBS XML.def XML.Document {\n XML.documentPrologue = XML.Prologue [] Nothing []\n , XML.documentRoot = root\n , XML.documentEpilogue = []\n }\n root = XML.Element {\n XML.elementName = \"Delete\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = quietNode dosQuiet : (objectNode <$> dosObjects)\n }\n objectNode (obj, mbVersion) = XML.NodeElement XML.Element {\n XML.elementName = \"Object\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = keyNode obj : maybeToList (versionNode <$> mbVersion)\n }\n versionNode = toNode \"VersionId\"\n keyNode = toNode \"Key\"\n quietNode b = toNode \"Quiet\" $ if b then \"true\" else \"false\"\n toNode name content = XML.NodeElement XML.Element {\n XML.elementName = name\n , XML.elementAttributes = M.empty\n , XML.elementNodes = [XML.NodeContent content]\n }\n\ninstance ResponseConsumer DeleteObjects DeleteObjectsResponse where\n type ResponseMetadata DeleteObjectsResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse cursor = do\n dorDeleted <- sequence $ cursor $/ Cu.laxElement \"Deleted\" &| parseDeleted\n dorErrors <- sequence $ cursor $/ Cu.laxElement \"Error\" &| parseErrors\n return DeleteObjectsResponse {..}\n parseDeleted c = do\n ddKey <- force \"Missing Key\" $ c $/ elContent \"Key\"\n let ddVersionId = listToMaybe $ c $/ elContent \"VersionId\"\n ddDeleteMarkerVersionId = listToMaybe $ c $/ elContent \"DeleteMarkerVersionId\"\n return DORDeleted {..}\n parseErrors c = do\n deKey <- force \"Missing Key\" $ c $/ elContent \"Key\"\n deCode <- force \"Missing Code\" $ c $/ elContent \"Code\"\n deMessage <- force \"Missing Message\" $ c $/ elContent \"Message\"\n return DORErrors {..}\n\ninstance Transaction DeleteObjects DeleteObjectsResponse\n\ninstance AsMemoryResponse DeleteObjectsResponse where\n type MemoryResponse DeleteObjectsResponse = DeleteObjectsResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/GetBucket.hs", "content": "module Aws.S3.Commands.GetBucket\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Data.ByteString.Char8 ({- IsString -})\nimport Data.Maybe\nimport Text.XML.Cursor (($/), (&|), (&//))\nimport qualified Data.ByteString.Char8 as B8\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Data.Traversable\nimport Prelude\nimport qualified Network.HTTP.Types as HTTP\nimport qualified Text.XML.Cursor as Cu\n\ndata GetBucket\n = GetBucket {\n gbBucket :: Bucket\n , gbDelimiter :: Maybe T.Text\n , gbMarker :: Maybe T.Text\n , gbMaxKeys :: Maybe Int\n , gbPrefix :: Maybe T.Text\n }\n deriving (Show)\n\ngetBucket :: Bucket -> GetBucket\ngetBucket bucket\n = GetBucket {\n gbBucket = bucket\n , gbDelimiter = Nothing\n , gbMarker = Nothing\n , gbMaxKeys = Nothing\n , gbPrefix = Nothing\n }\n\ndata GetBucketResponse\n = GetBucketResponse {\n gbrName :: Bucket\n , gbrDelimiter :: Maybe T.Text\n , gbrMarker :: Maybe T.Text\n , gbrMaxKeys :: Maybe Int\n , gbrPrefix :: Maybe T.Text\n , gbrContents :: [ObjectInfo]\n , gbrCommonPrefixes :: [T.Text]\n , gbrIsTruncated :: Bool\n , gbrNextMarker :: Maybe T.Text\n }\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery GetBucket where\n type ServiceConfiguration GetBucket = S3Configuration\n signQuery GetBucket {..} = s3SignQuery S3Query {\n s3QMethod = Get\n , s3QBucket = Just $ T.encodeUtf8 gbBucket\n , s3QObject = Nothing\n , s3QSubresources = []\n , s3QQuery = HTTP.toQuery [\n (\"delimiter\" :: B8.ByteString ,) <$> gbDelimiter\n , (\"marker\",) <$> gbMarker\n , (\"max-keys\",) . T.pack . show <$> gbMaxKeys\n , (\"prefix\",) <$> gbPrefix\n ]\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer r GetBucketResponse where\n type ResponseMetadata GetBucketResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse cursor\n = do name <- force \"Missing Name\" $ cursor $/ elContent \"Name\"\n let delimiter = listToMaybe $ cursor $/ elContent \"Delimiter\"\n let marker = listToMaybe $ cursor $/ elContent \"Marker\"\n maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent \"MaxKeys\" &| textReadInt\n let truncated = maybe True (/= \"false\") $ listToMaybe $ cursor $/ elContent \"IsTruncated\"\n let nextMarker = listToMaybe $ cursor $/ elContent \"NextMarker\"\n let prefix = listToMaybe $ cursor $/ elContent \"Prefix\"\n contents <- sequence $ cursor $/ Cu.laxElement \"Contents\" &| parseObjectInfo\n let commonPrefixes = cursor $/ Cu.laxElement \"CommonPrefixes\" &// Cu.content\n return GetBucketResponse{\n gbrName = name\n , gbrDelimiter = delimiter\n , gbrMarker = marker\n , gbrMaxKeys = maxKeys\n , gbrPrefix = prefix\n , gbrContents = contents\n , gbrCommonPrefixes = commonPrefixes\n , gbrIsTruncated = truncated\n , gbrNextMarker = nextMarker\n }\n\ninstance Transaction GetBucket GetBucketResponse\n\ninstance IteratedTransaction GetBucket GetBucketResponse where\n nextIteratedRequest request response\n = case (gbrIsTruncated response, gbrNextMarker response, gbrContents response) of\n (True, Just marker, _ ) -> Just $ request { gbMarker = Just marker }\n (True, Nothing, contents@(_:_)) -> Just $ request { gbMarker = Just $ objectKey $ last contents }\n (_, _, _ ) -> Nothing\n\ninstance ListResponse GetBucketResponse ObjectInfo where\n listResponse = gbrContents\n\ninstance AsMemoryResponse GetBucketResponse where\n type MemoryResponse GetBucketResponse = GetBucketResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/GetBucketLocation.hs", "content": "module Aws.S3.Commands.GetBucketLocation\n where\n\nimport Aws.Core\nimport Aws.S3.Core\n\nimport qualified Data.ByteString.Char8 as B8\n\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Types as HTTP\nimport Text.XML.Cursor (($.//))\n\ndata GetBucketLocation\n = GetBucketLocation {\n gblBucket :: Bucket\n } deriving Show\n\ngetBucketLocation :: Bucket -> GetBucketLocation\ngetBucketLocation bucket\n = GetBucketLocation {\n gblBucket = bucket\n }\n\ndata GetBucketLocationResponse\n = GetBucketLocationResponse { gblrLocationConstraint :: LocationConstraint }\n deriving Show\n\ninstance SignQuery GetBucketLocation where\n type ServiceConfiguration GetBucketLocation = S3Configuration\n signQuery GetBucketLocation {..} = s3SignQuery S3Query {\n s3QMethod = Get\n , s3QBucket = Just $ T.encodeUtf8 gblBucket\n , s3QObject = Nothing\n , s3QSubresources = [(\"location\" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]\n , s3QQuery = HTTP.toQuery ([] :: [(B8.ByteString, T.Text)]) \n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer r GetBucketLocationResponse where\n type ResponseMetadata GetBucketLocationResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse cursor = do\n locationConstraint <- force \"Missing Location\" $ cursor $.// elContent \"LocationConstraint\"\n return GetBucketLocationResponse { gblrLocationConstraint = normaliseLocation locationConstraint }\n\ninstance Transaction GetBucketLocation GetBucketLocationResponse\n\ninstance AsMemoryResponse GetBucketLocationResponse where\n type MemoryResponse GetBucketLocationResponse = GetBucketLocationResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/GetBucketObjectVersions.hs", "content": "module Aws.S3.Commands.GetBucketObjectVersions\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Data.ByteString.Char8 ({- IsString -})\nimport Data.Maybe\nimport Text.XML.Cursor (($/), (&|), (&//))\nimport qualified Data.ByteString.Char8 as B8\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Data.Traversable\nimport Prelude\nimport qualified Network.HTTP.Types as HTTP\nimport qualified Text.XML.Cursor as Cu\nimport qualified Text.XML as XML\n\ndata GetBucketObjectVersions\n = GetBucketObjectVersions {\n gbovBucket :: Bucket\n , gbovDelimiter :: Maybe T.Text\n , gbovKeyMarker :: Maybe T.Text\n , gbovMaxKeys :: Maybe Int\n , gbovPrefix :: Maybe T.Text\n , gbovVersionIdMarker :: Maybe T.Text\n }\n deriving (Show)\n\ngetBucketObjectVersions :: Bucket -> GetBucketObjectVersions\ngetBucketObjectVersions bucket\n = GetBucketObjectVersions {\n gbovBucket = bucket\n , gbovDelimiter = Nothing\n , gbovKeyMarker = Nothing\n , gbovMaxKeys = Nothing\n , gbovPrefix = Nothing\n , gbovVersionIdMarker = Nothing\n }\n\ndata GetBucketObjectVersionsResponse\n = GetBucketObjectVersionsResponse {\n gbovrName :: Bucket\n , gbovrDelimiter :: Maybe T.Text\n , gbovrKeyMarker :: Maybe T.Text\n , gbovrMaxKeys :: Maybe Int\n , gbovrPrefix :: Maybe T.Text\n , gbovrVersionIdMarker :: Maybe T.Text\n , gbovrContents :: [ObjectVersionInfo]\n , gbovrCommonPrefixes :: [T.Text]\n , gbovrIsTruncated :: Bool\n , gbovrNextKeyMarker :: Maybe T.Text\n , gbovrNextVersionIdMarker :: Maybe T.Text\n }\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery GetBucketObjectVersions where\n type ServiceConfiguration GetBucketObjectVersions = S3Configuration\n signQuery GetBucketObjectVersions {..} = s3SignQuery S3Query {\n s3QMethod = Get\n , s3QBucket = Just $ T.encodeUtf8 gbovBucket\n , s3QObject = Nothing\n , s3QSubresources = [ (\"versions\", Nothing) ]\n , s3QQuery = HTTP.toQuery [\n (\"delimiter\" :: B8.ByteString ,) <$> gbovDelimiter\n , (\"key-marker\",) <$> gbovKeyMarker\n , (\"max-keys\",) . T.pack . show <$> gbovMaxKeys\n , (\"prefix\",) <$> gbovPrefix\n , (\"version-id-marker\",) <$> gbovVersionIdMarker\n ]\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer r GetBucketObjectVersionsResponse where\n type ResponseMetadata GetBucketObjectVersionsResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse cursor\n = do name <- force \"Missing Name\" $ cursor $/ elContent \"Name\"\n let delimiter = listToMaybe $ cursor $/ elContent \"Delimiter\"\n let keyMarker = listToMaybe $ cursor $/ elContent \"KeyMarker\"\n let versionMarker = listToMaybe $ cursor $/ elContent \"VersionIdMarker\"\n maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent \"MaxKeys\" &| textReadInt\n let truncated = maybe True (/= \"false\") $ listToMaybe $ cursor $/ elContent \"IsTruncated\"\n let nextKeyMarker = listToMaybe $ cursor $/ elContent \"NextKeyMarker\"\n let nextVersionMarker = listToMaybe $ cursor $/ elContent \"NextVersionIdMarker\"\n let prefix = listToMaybe $ cursor $/ elContent \"Prefix\"\n contents <- sequence $ cursor $/ Cu.checkName objectNodeName &| parseObjectVersionInfo\n let commonPrefixes = cursor $/ Cu.laxElement \"CommonPrefixes\" &// Cu.content\n return GetBucketObjectVersionsResponse{\n gbovrName = name\n , gbovrDelimiter = delimiter\n , gbovrKeyMarker = keyMarker\n , gbovrMaxKeys = maxKeys\n , gbovrPrefix = prefix\n , gbovrVersionIdMarker = versionMarker\n , gbovrContents = contents\n , gbovrCommonPrefixes = commonPrefixes\n , gbovrIsTruncated = truncated\n , gbovrNextKeyMarker = nextKeyMarker\n , gbovrNextVersionIdMarker = nextVersionMarker\n }\n objectNodeName n = let fn = T.toCaseFold $ XML.nameLocalName n\n in fn == T.toCaseFold \"Version\" || fn == T.toCaseFold \"DeleteMarker\"\n\ninstance Transaction GetBucketObjectVersions GetBucketObjectVersionsResponse\n\ninstance IteratedTransaction GetBucketObjectVersions GetBucketObjectVersionsResponse where\n nextIteratedRequest request response\n = case (gbovrIsTruncated response, gbovrNextKeyMarker response, gbovrNextVersionIdMarker response, gbovrContents response) of\n (True, Just keyMarker, Just versionMarker, _ ) -> Just $ request { gbovKeyMarker = Just keyMarker, gbovVersionIdMarker = Just versionMarker }\n (True, Nothing, Nothing, contents@(_:_)) -> Just $ request { gbovKeyMarker = Just $ oviKey $ last contents, gbovVersionIdMarker = Just $ oviVersionId $ last contents }\n (_, _, _, _ ) -> Nothing\n\ninstance ListResponse GetBucketObjectVersionsResponse ObjectVersionInfo where\n listResponse = gbovrContents\n\ninstance AsMemoryResponse GetBucketObjectVersionsResponse where\n type MemoryResponse GetBucketObjectVersionsResponse = GetBucketObjectVersionsResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/GetBucketVersioning.hs", "content": "module Aws.S3.Commands.GetBucketVersioning \n( \n module Aws.S3.Commands.GetBucketVersioning\n, VersioningState(..)\n) where\n\nimport Aws.Core\nimport Aws.S3.Commands.PutBucketVersioning (VersioningState(..))\nimport Aws.S3.Core\nimport Control.Monad.Trans.Resource (throwM)\nimport Network.HTTP.Types (toQuery)\nimport qualified Data.Text.Encoding as T\nimport Text.XML.Cursor (($.//))\nimport qualified Data.ByteString.Lazy.Char8 as B8\n\n-- | Gets the versioning state of an existing bucket.\ndata GetBucketVersioning\n = GetBucketVersioning\n { gbvBucket :: Bucket\n }\n deriving (Show)\n\ngetBucketVersioning :: Bucket -> GetBucketVersioning\ngetBucketVersioning = GetBucketVersioning\n\ndata GetBucketVersioningResponse\n = GetBucketVersioningResponse\n { gbvVersioning :: Maybe VersioningState }\n -- ^ Nothing when the bucket is not versioned\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery GetBucketVersioning where\n type ServiceConfiguration GetBucketVersioning = S3Configuration\n\n signQuery GetBucketVersioning{..} = s3SignQuery $ S3Query\n { s3QMethod = Get\n , s3QBucket = Just $ T.encodeUtf8 gbvBucket\n , s3QSubresources = toQuery [(\"versioning\" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QObject = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer r GetBucketVersioningResponse where\n type ResponseMetadata GetBucketVersioningResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse cursor = do\n v <- case cursor $.// elContent \"Status\" of\n [] -> return Nothing\n (\"Enabled\":[]) -> return (Just VersioningEnabled)\n (\"Suspended\":[]) -> return (Just VersioningSuspended)\n _ -> throwM $ XmlException \"Invalid Status\"\n return GetBucketVersioningResponse { gbvVersioning = v }\n\ninstance Transaction GetBucketVersioning GetBucketVersioningResponse\n\ninstance AsMemoryResponse GetBucketVersioningResponse where\n type MemoryResponse GetBucketVersioningResponse = GetBucketVersioningResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/GetObject.hs", "content": "{-# LANGUAGE CPP #-}\n\nmodule Aws.S3.Commands.GetObject\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Control.Monad.Trans.Resource (ResourceT)\nimport Data.ByteString.Char8 ({- IsString -})\nimport qualified Data.ByteString.Char8 as B8\nimport qualified Data.ByteString.Lazy as L\nimport qualified Data.Conduit as C\nimport Data.Conduit ((.|))\nimport qualified Data.Conduit.List as CL\nimport Data.Maybe\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport Prelude\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\n\ndata GetObject\n = GetObject {\n goBucket :: Bucket\n , goObjectName :: Object\n , goVersionId :: Maybe T.Text\n , goResponseContentType :: Maybe T.Text\n , goResponseContentLanguage :: Maybe T.Text\n , goResponseExpires :: Maybe T.Text\n , goResponseCacheControl :: Maybe T.Text\n , goResponseContentDisposition :: Maybe T.Text\n , goResponseContentEncoding :: Maybe T.Text\n , goResponseContentRange :: Maybe (Int,Int)\n , goIfMatch :: Maybe T.Text\n -- ^ 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.\n , goIfNoneMatch :: Maybe T.Text\n -- ^ 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.\n }\n deriving (Show)\n\ngetObject :: Bucket -> T.Text -> GetObject\ngetObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing\n\ndata GetObjectResponse\n = GetObjectResponse {\n gorMetadata :: ObjectMetadata,\n gorResponse :: HTTP.Response (C.ConduitM () B8.ByteString (ResourceT IO) ())\n }\n\ndata GetObjectMemoryResponse\n = GetObjectMemoryResponse ObjectMetadata (HTTP.Response L.ByteString)\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery GetObject where\n type ServiceConfiguration GetObject = S3Configuration\n signQuery GetObject {..} = s3SignQuery S3Query {\n s3QMethod = Get\n , s3QBucket = Just $ T.encodeUtf8 goBucket\n , s3QObject = Just $ T.encodeUtf8 goObjectName\n , s3QSubresources = HTTP.toQuery [\n (\"versionId\" :: B8.ByteString,) <$> goVersionId\n , (\"response-content-type\" :: B8.ByteString,) <$> goResponseContentType\n , (\"response-content-language\",) <$> goResponseContentLanguage\n , (\"response-expires\",) <$> goResponseExpires\n , (\"response-cache-control\",) <$> goResponseCacheControl\n , (\"response-content-disposition\",) <$> goResponseContentDisposition\n , (\"response-content-encoding\",) <$> goResponseContentEncoding\n ]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = catMaybes [\n decodeRange <$> goResponseContentRange\n , (\"if-match\",) . T.encodeUtf8 <$> goIfMatch\n , (\"if-none-match\",) . T.encodeUtf8 <$> goIfNoneMatch\n ]\n , s3QRequestBody = Nothing\n }\n where decodeRange (pos,len) = (\"range\",B8.concat $ [\"bytes=\", B8.pack (show pos), \"-\", B8.pack (show len)])\n\ninstance ResponseConsumer GetObject GetObjectResponse where\n type ResponseMetadata GetObjectResponse = S3Metadata\n responseConsumer httpReq GetObject{} metadata resp\n | status == HTTP.status200 = do\n rsp <- s3BinaryResponseConsumer return metadata resp\n om <- parseObjectMetadata (HTTP.responseHeaders resp)\n return $ GetObjectResponse om rsp\n | otherwise = throwStatusCodeException httpReq resp\n where\n status = HTTP.responseStatus resp\n\ninstance Transaction GetObject GetObjectResponse\n\ninstance AsMemoryResponse GetObjectResponse where\n type MemoryResponse GetObjectResponse = GetObjectMemoryResponse\n loadToMemory (GetObjectResponse om x) = do\n bss <- C.runConduit $ HTTP.responseBody x .| CL.consume\n return $ GetObjectMemoryResponse om x\n { HTTP.responseBody = L.fromChunks bss\n }\n" }, { "path": "Aws/S3/Commands/GetService.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Aws.S3.Commands.GetService\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Data.Maybe\nimport Data.Time.Format\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport Text.XML.Cursor (($/), ($//), (&|))\nimport qualified Data.Text as T\nimport qualified Text.XML.Cursor as Cu\n\ndata GetService = GetService deriving (Show)\n\ndata GetServiceResponse\n = GetServiceResponse {\n gsrOwner :: UserInfo\n , gsrBuckets :: [BucketInfo]\n }\n deriving (Show)\n\ninstance ResponseConsumer r GetServiceResponse where\n type ResponseMetadata GetServiceResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where\n parse el = do\n owner <- forceM \"Missing Owner\" $ el $/ Cu.laxElement \"Owner\" &| parseUserInfo\n buckets <- sequence $ el $// Cu.laxElement \"Bucket\" &| parseBucket\n return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets }\n\n parseBucket el = do\n name <- force \"Missing owner Name\" $ el $/ elContent \"Name\"\n creationDateString <- force \"Missing owner CreationDate\" $ el $/ elContent \"CreationDate\" &| T.unpack\n creationDate <- force \"Invalid CreationDate\" . maybeToList $ parseTimeM True defaultTimeLocale iso8601UtcDate creationDateString\n return BucketInfo { bucketName = name, bucketCreationDate = creationDate }\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery GetService where\n type ServiceConfiguration GetService = S3Configuration\n signQuery GetService = s3SignQuery S3Query {\n s3QMethod = Get\n , s3QBucket = Nothing\n , s3QObject = Nothing\n , s3QSubresources = []\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n }\n\ninstance Transaction GetService GetServiceResponse\n\ninstance AsMemoryResponse GetServiceResponse where\n type MemoryResponse GetServiceResponse = GetServiceResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/HeadObject.hs", "content": "module Aws.S3.Commands.HeadObject\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Data.ByteString.Char8 ({- IsString -})\nimport qualified Data.ByteString.Char8 as B8\nimport Data.Maybe\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport Prelude\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\n\ndata HeadObject\n = HeadObject {\n hoBucket :: Bucket\n , hoObjectName :: Object\n , hoVersionId :: Maybe T.Text\n , hoIfMatch :: Maybe T.Text\n -- ^ 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.\n , hoIfNoneMatch :: Maybe T.Text\n -- ^ 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.\n }\n deriving (Show)\n\nheadObject :: Bucket -> T.Text -> HeadObject\nheadObject b o = HeadObject b o Nothing Nothing Nothing\n\ndata HeadObjectResponse\n = HeadObjectResponse {\n horMetadata :: Maybe ObjectMetadata\n } deriving (Show)\n\ndata HeadObjectMemoryResponse\n = HeadObjectMemoryResponse (Maybe ObjectMetadata)\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery HeadObject where\n type ServiceConfiguration HeadObject = S3Configuration\n signQuery HeadObject {..} = s3SignQuery S3Query {\n s3QMethod = Head\n , s3QBucket = Just $ T.encodeUtf8 hoBucket\n , s3QObject = Just $ T.encodeUtf8 hoObjectName\n , s3QSubresources = HTTP.toQuery [\n (\"versionId\" :: B8.ByteString,) <$> hoVersionId\n ]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = catMaybes [\n (\"if-match\",) . T.encodeUtf8 <$> hoIfMatch\n , (\"if-none-match\",) . T.encodeUtf8 <$> hoIfNoneMatch\n ]\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer HeadObject HeadObjectResponse where\n type ResponseMetadata HeadObjectResponse = S3Metadata\n responseConsumer httpReq HeadObject{} _ resp\n | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers\n | status == HTTP.status404 = return $ HeadObjectResponse Nothing\n | otherwise = throwStatusCodeException httpReq resp\n where\n status = HTTP.responseStatus resp\n headers = HTTP.responseHeaders resp\n\ninstance Transaction HeadObject HeadObjectResponse\n\ninstance AsMemoryResponse HeadObjectResponse where\n type MemoryResponse HeadObjectResponse = HeadObjectMemoryResponse\n loadToMemory (HeadObjectResponse om) = return (HeadObjectMemoryResponse om)\n" }, { "path": "Aws/S3/Commands/Multipart.hs", "content": "module Aws.S3.Commands.Multipart\nwhere\nimport Aws.Aws\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Control.Arrow (second)\nimport Control.Monad\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Resource\nimport qualified Crypto.Hash as CH\nimport Data.ByteString.Char8 ({- IsString -})\nimport Data.Conduit\nimport qualified Data.Conduit.List as CL\nimport Data.Maybe\nimport Text.XML.Cursor (($/))\nimport qualified Data.ByteString.Char8 as B8\nimport qualified Data.ByteString.Lazy as BL\nimport qualified Data.CaseInsensitive as CI\nimport qualified Data.Map as M\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport qualified Text.XML as XML\nimport Prelude\n\n{-\nAws supports following 6 api for Multipart-Upload.\nCurrently this code does not support number 3 and 6.\n\n1. Initiate Multipart Upload\n2. Upload Part\n3. Upload Part - Copy\n4. Complete Multipart Upload\n5. Abort Multipart Upload\n6. List Parts\n\n-}\n\ndata InitiateMultipartUpload\n = InitiateMultipartUpload {\n imuBucket :: Bucket\n , imuObjectName :: Object\n , imuCacheControl :: Maybe T.Text\n , imuContentDisposition :: Maybe T.Text\n , imuContentEncoding :: Maybe T.Text\n , imuContentType :: Maybe T.Text\n , imuExpires :: Maybe Int\n , imuMetadata :: [(T.Text,T.Text)]\n , imuStorageClass :: Maybe StorageClass\n , imuWebsiteRedirectLocation :: Maybe T.Text\n , imuAcl :: Maybe CannedAcl\n , imuServerSideEncryption :: Maybe ServerSideEncryption\n , imuAutoMakeBucket :: Bool -- ^ Internet Archive S3 nonstandard extension\n }\n deriving (Show)\n\npostInitiateMultipartUpload :: Bucket -> T.Text -> InitiateMultipartUpload\npostInitiateMultipartUpload b o =\n InitiateMultipartUpload\n b o\n Nothing Nothing Nothing Nothing Nothing\n [] Nothing Nothing Nothing Nothing\n False\n\ndata InitiateMultipartUploadResponse\n = InitiateMultipartUploadResponse {\n imurBucket :: !Bucket\n , imurKey :: !T.Text\n , imurUploadId :: !T.Text\n }\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery InitiateMultipartUpload where\n type ServiceConfiguration InitiateMultipartUpload = S3Configuration\n signQuery InitiateMultipartUpload {..} = s3SignQuery S3Query {\n s3QMethod = Post\n , s3QBucket = Just $ T.encodeUtf8 imuBucket\n , s3QObject = Just $ T.encodeUtf8 $ imuObjectName\n , s3QSubresources = HTTP.toQuery[ (\"uploads\" :: B8.ByteString , Nothing :: Maybe B8.ByteString)]\n , s3QQuery = []\n , s3QContentType = T.encodeUtf8 <$> imuContentType\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [\n (\"x-amz-acl\",) <$> writeCannedAcl <$> imuAcl\n , (\"x-amz-storage-class\",) <$> writeStorageClass <$> imuStorageClass\n , (\"x-amz-website-redirect-location\",) <$> imuWebsiteRedirectLocation\n , (\"x-amz-server-side-encryption\",) <$> writeServerSideEncryption <$> imuServerSideEncryption\n , if imuAutoMakeBucket then Just (\"x-amz-auto-make-bucket\", \"1\") else Nothing\n ] ++ map( \\x -> (CI.mk . T.encodeUtf8 $ T.concat [\"x-amz-meta-\", fst x], snd x)) imuMetadata\n , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [\n (\"Expires\",) . T.pack . show <$> imuExpires\n , (\"Cache-Control\",) <$> imuCacheControl\n , (\"Content-Disposition\",) <$> imuContentDisposition\n , (\"Content-Encoding\",) <$> imuContentEncoding\n ]\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer r InitiateMultipartUploadResponse where\n type ResponseMetadata InitiateMultipartUploadResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse cursor\n = do bucket <- force \"Missing Bucket Name\" $ cursor $/ elContent \"Bucket\"\n key <- force \"Missing Key\" $ cursor $/ elContent \"Key\"\n uploadId <- force \"Missing UploadID\" $ cursor $/ elContent \"UploadId\"\n return InitiateMultipartUploadResponse{\n imurBucket = bucket\n , imurKey = key\n , imurUploadId = uploadId\n }\n\ninstance Transaction InitiateMultipartUpload InitiateMultipartUploadResponse\n\ninstance AsMemoryResponse InitiateMultipartUploadResponse where\n type MemoryResponse InitiateMultipartUploadResponse = InitiateMultipartUploadResponse\n loadToMemory = return\n\n\n----------------------------------\n\n\n\ndata UploadPart = UploadPart {\n upObjectName :: T.Text\n , upBucket :: Bucket\n , upPartNumber :: Integer\n , upUploadId :: T.Text\n , upContentType :: Maybe B8.ByteString\n , upContentMD5 :: Maybe (CH.Digest CH.MD5)\n , upServerSideEncryption :: Maybe ServerSideEncryption\n , upRequestBody :: HTTP.RequestBody\n , upExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10\n}\n\nuploadPart :: Bucket -> T.Text -> Integer -> T.Text -> HTTP.RequestBody -> UploadPart\nuploadPart bucket obj p i body =\n UploadPart obj bucket p i\n Nothing Nothing Nothing body False\n\ndata UploadPartResponse\n = UploadPartResponse {\n uprETag :: !T.Text\n }\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery UploadPart where\n type ServiceConfiguration UploadPart = S3Configuration\n signQuery UploadPart {..} = s3SignQuery S3Query {\n s3QMethod = Put\n , s3QBucket = Just $ T.encodeUtf8 upBucket\n , s3QObject = Just $ T.encodeUtf8 upObjectName\n , s3QSubresources = HTTP.toQuery[\n (\"partNumber\" :: B8.ByteString , Just (T.pack (show upPartNumber)) :: Maybe T.Text)\n , (\"uploadId\" :: B8.ByteString, Just upUploadId :: Maybe T.Text)\n ]\n , s3QQuery = []\n , s3QContentType = upContentType\n , s3QContentMd5 = upContentMD5\n , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [\n (\"x-amz-server-side-encryption\",) <$> writeServerSideEncryption <$> upServerSideEncryption\n ]\n , s3QOtherHeaders = catMaybes [\n if upExpect100Continue\n then Just (\"Expect\", \"100-continue\")\n else Nothing\n ]\n , s3QRequestBody = Just upRequestBody\n }\n\ninstance ResponseConsumer UploadPart UploadPartResponse where\n type ResponseMetadata UploadPartResponse = S3Metadata\n responseConsumer _ _ = s3ResponseConsumer $ \\resp -> do\n let etag = fromMaybe \"\" $ T.decodeUtf8 `fmap` lookup \"ETag\" (HTTP.responseHeaders resp)\n return $ UploadPartResponse etag\n\ninstance Transaction UploadPart UploadPartResponse\n\ninstance AsMemoryResponse UploadPartResponse where\n type MemoryResponse UploadPartResponse = UploadPartResponse\n loadToMemory = return\n\n----------------------------\n\n\n\ndata CompleteMultipartUpload\n = CompleteMultipartUpload {\n cmuBucket :: Bucket\n , cmuObjectName :: Object\n , cmuUploadId :: T.Text\n , cmuPartNumberAndEtags :: [(Integer,T.Text)]\n , cmuExpiration :: Maybe T.Text\n , cmuServerSideEncryption :: Maybe T.Text\n , cmuServerSideEncryptionCustomerAlgorithm :: Maybe T.Text\n }\n deriving (Show)\n\npostCompleteMultipartUpload :: Bucket -> T.Text -> T.Text -> [(Integer,T.Text)]-> CompleteMultipartUpload\npostCompleteMultipartUpload b o i p = CompleteMultipartUpload b o i p Nothing Nothing Nothing\n\ndata CompleteMultipartUploadResponse\n = CompleteMultipartUploadResponse {\n cmurLocation :: !T.Text\n , cmurBucket :: !Bucket\n , cmurKey :: !T.Text\n , cmurETag :: !T.Text\n , cmurVersionId :: !(Maybe T.Text)\n } deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery CompleteMultipartUpload where\n type ServiceConfiguration CompleteMultipartUpload = S3Configuration\n signQuery CompleteMultipartUpload {..} = s3SignQuery S3Query {\n s3QMethod = Post\n , s3QBucket = Just $ T.encodeUtf8 cmuBucket\n , s3QObject = Just $ T.encodeUtf8 cmuObjectName\n , s3QSubresources = HTTP.toQuery[\n (\"uploadId\" :: B8.ByteString, Just cmuUploadId :: Maybe T.Text)\n ]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = catMaybes [ (\"x-amz-expiration\",) <$> (T.encodeUtf8 <$> cmuExpiration)\n , (\"x-amz-server-side-encryption\",) <$> (T.encodeUtf8 <$> cmuServerSideEncryption)\n , (\"x-amz-server-side-encryption-customer-algorithm\",)\n <$> (T.encodeUtf8 <$> cmuServerSideEncryptionCustomerAlgorithm)\n ]\n , s3QOtherHeaders = []\n , s3QRequestBody = Just $ HTTP.RequestBodyLBS reqBody\n }\n where reqBody = XML.renderLBS XML.def XML.Document {\n XML.documentPrologue = XML.Prologue [] Nothing []\n , XML.documentRoot = root\n , XML.documentEpilogue = []\n }\n root = XML.Element {\n XML.elementName = \"CompleteMultipartUpload\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = (partNode <$> cmuPartNumberAndEtags)\n }\n partNode (partNumber, etag) = XML.NodeElement XML.Element {\n XML.elementName = \"Part\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = [keyNode (T.pack (show partNumber)),etagNode etag]\n }\n etagNode = toNode \"ETag\"\n keyNode = toNode \"PartNumber\"\n toNode name content = XML.NodeElement XML.Element {\n XML.elementName = name\n , XML.elementAttributes = M.empty\n , XML.elementNodes = [XML.NodeContent content]\n }\n\ninstance ResponseConsumer r CompleteMultipartUploadResponse where\n type ResponseMetadata CompleteMultipartUploadResponse = S3Metadata\n\n responseConsumer _ _ metadata resp = s3XmlResponseConsumer parse metadata resp\n where vid = T.decodeUtf8 `fmap` lookup \"x-amz-version-id\" (HTTP.responseHeaders resp)\n parse cursor\n = do location <- force \"Missing Location\" $ cursor $/ elContent \"Location\"\n bucket <- force \"Missing Bucket Name\" $ cursor $/ elContent \"Bucket\"\n key <- force \"Missing Key\" $ cursor $/ elContent \"Key\"\n etag <- force \"Missing ETag\" $ cursor $/ elContent \"ETag\"\n return CompleteMultipartUploadResponse{\n cmurLocation = location\n , cmurBucket = bucket\n , cmurKey = key\n , cmurETag = etag\n , cmurVersionId = vid\n }\n\ninstance Transaction CompleteMultipartUpload CompleteMultipartUploadResponse\n\ninstance AsMemoryResponse CompleteMultipartUploadResponse where\n type MemoryResponse CompleteMultipartUploadResponse = CompleteMultipartUploadResponse\n loadToMemory = return\n\n----------------------------\n\n\n\ndata AbortMultipartUpload\n = AbortMultipartUpload {\n amuBucket :: Bucket\n , amuObjectName :: Object\n , amuUploadId :: T.Text\n }\n deriving (Show)\n\npostAbortMultipartUpload :: Bucket -> T.Text -> T.Text -> AbortMultipartUpload\npostAbortMultipartUpload b o i = AbortMultipartUpload b o i\n\ndata AbortMultipartUploadResponse\n = AbortMultipartUploadResponse {\n } deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery AbortMultipartUpload where\n type ServiceConfiguration AbortMultipartUpload = S3Configuration\n signQuery AbortMultipartUpload {..} = s3SignQuery S3Query {\n s3QMethod = Delete\n , s3QBucket = Just $ T.encodeUtf8 amuBucket\n , s3QObject = Just $ T.encodeUtf8 amuObjectName\n , s3QSubresources = HTTP.toQuery[\n (\"uploadId\" :: B8.ByteString, Just amuUploadId :: Maybe T.Text)\n ]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = Nothing\n }\n\ninstance ResponseConsumer r AbortMultipartUploadResponse where\n type ResponseMetadata AbortMultipartUploadResponse = S3Metadata\n\n responseConsumer _ _ = s3XmlResponseConsumer parse\n where parse _cursor\n = return AbortMultipartUploadResponse {}\n\ninstance Transaction AbortMultipartUpload AbortMultipartUploadResponse\n\n\ninstance AsMemoryResponse AbortMultipartUploadResponse where\n type MemoryResponse AbortMultipartUploadResponse = AbortMultipartUploadResponse\n loadToMemory = return\n\n\n----------------------------\n\ngetUploadId ::\n Configuration\n -> S3Configuration NormalQuery\n -> HTTP.Manager\n -> T.Text\n -> T.Text\n -> IO T.Text\ngetUploadId cfg s3cfg mgr bucket object = do\n InitiateMultipartUploadResponse {\n imurBucket = _bucket\n , imurKey = _object'\n , imurUploadId = uploadId\n } <- memoryAws cfg s3cfg mgr $ postInitiateMultipartUpload bucket object\n return uploadId\n\n\nsendEtag ::\n Configuration\n -> S3Configuration NormalQuery\n -> HTTP.Manager\n -> T.Text\n -> T.Text\n -> T.Text\n -> [T.Text]\n -> IO CompleteMultipartUploadResponse\nsendEtag cfg s3cfg mgr bucket object uploadId etags = do\n memoryAws cfg s3cfg mgr $\n postCompleteMultipartUpload bucket object uploadId (zip [1..] etags)\n\nputConduit ::\n MonadResource m =>\n Configuration\n -> S3Configuration NormalQuery\n -> HTTP.Manager\n -> T.Text\n -> T.Text\n -> T.Text\n -> ConduitT BL.ByteString T.Text m ()\nputConduit cfg s3cfg mgr bucket object uploadId = loop 1\n where\n loop n = do\n v' <- await\n case v' of\n Just v -> do\n UploadPartResponse etag <- memoryAws cfg s3cfg mgr $\n uploadPart bucket object n uploadId (HTTP.RequestBodyLBS v)\n yield etag\n loop (n+1)\n Nothing -> return ()\n\nchunkedConduit :: (MonadResource m) => Integer -> ConduitT B8.ByteString BL.ByteString m ()\nchunkedConduit size = loop 0 []\n where\n loop :: Monad m => Integer -> [B8.ByteString] -> ConduitT B8.ByteString BL.ByteString m ()\n loop cnt str = await >>= maybe (yieldChunk str) go\n where\n go :: Monad m => B8.ByteString -> ConduitT B8.ByteString BL.ByteString m ()\n go line\n | size <= len = yieldChunk newStr >> loop 0 []\n | otherwise = loop len newStr\n where\n len = fromIntegral (B8.length line) + cnt\n newStr = line:str\n\n yieldChunk :: Monad m => [B8.ByteString] -> ConduitT i BL.ByteString m ()\n yieldChunk = yield . BL.fromChunks . reverse\n\nmultipartUpload ::\n Configuration\n -> S3Configuration NormalQuery\n -> HTTP.Manager\n -> T.Text\n -> T.Text\n -> ConduitT () B8.ByteString (ResourceT IO) ()\n -> Integer\n -> ResourceT IO ()\nmultipartUpload cfg s3cfg mgr bucket object src chunkSize = do\n uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket object\n etags <- (src\n .| chunkedConduit chunkSize\n .| putConduit cfg s3cfg mgr bucket object uploadId\n ) `connect` CL.consume\n void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags\n\nmultipartUploadSink :: MonadResource m\n => Configuration\n -> S3Configuration NormalQuery\n -> HTTP.Manager\n -> T.Text -- ^ Bucket name\n -> T.Text -- ^ Object name\n -> Integer -- ^ chunkSize (minimum: 5MB)\n -> ConduitT B8.ByteString Void m ()\nmultipartUploadSink cfg s3cfg = multipartUploadSinkWithInitiator cfg s3cfg postInitiateMultipartUpload\n\nmultipartUploadWithInitiator ::\n Configuration\n -> S3Configuration NormalQuery\n -> (Bucket -> T.Text -> InitiateMultipartUpload)\n -> HTTP.Manager\n -> T.Text\n -> T.Text\n -> ConduitT () B8.ByteString (ResourceT IO) ()\n -> Integer\n -> ResourceT IO ()\nmultipartUploadWithInitiator cfg s3cfg initiator mgr bucket object src chunkSize = do\n uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object)\n etags <- (src\n .| chunkedConduit chunkSize\n .| putConduit cfg s3cfg mgr bucket object uploadId\n ) `connect` CL.consume\n void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags\n\nmultipartUploadSinkWithInitiator :: MonadResource m\n => Configuration\n -> S3Configuration NormalQuery\n -> (Bucket -> T.Text -> InitiateMultipartUpload) -- ^ Initiator\n -> HTTP.Manager\n -> T.Text -- ^ Bucket name\n -> T.Text -- ^ Object name\n -> Integer -- ^ chunkSize (minimum: 5MB)\n -> ConduitT B8.ByteString Void m ()\nmultipartUploadSinkWithInitiator cfg s3cfg initiator mgr bucket object chunkSize = do\n uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object)\n etags <- chunkedConduit chunkSize\n .| putConduit cfg s3cfg mgr bucket object uploadId\n .| CL.consume\n void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags\n" }, { "path": "Aws/S3/Commands/PutBucket.hs", "content": "module Aws.S3.Commands.PutBucket where\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Monad\nimport Data.Maybe\nimport qualified Data.Map as M\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Text.XML as XML\n\ndata PutBucket\n = PutBucket {\n pbBucket :: Bucket\n , pbCannedAcl :: Maybe CannedAcl\n , pbLocationConstraint :: LocationConstraint\n , pbXStorageClass :: Maybe StorageClass -- ^ Google Cloud Storage S3 nonstandard extension\n }\n deriving (Show)\n\nputBucket :: Bucket -> PutBucket\nputBucket bucket = PutBucket bucket Nothing locationUsClassic Nothing\n\ndata PutBucketResponse\n = PutBucketResponse\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery PutBucket where\n type ServiceConfiguration PutBucket = S3Configuration\n\n signQuery PutBucket{..} = s3SignQuery (S3Query {\n s3QMethod = Put\n , s3QBucket = Just $ T.encodeUtf8 pbBucket\n , s3QSubresources = []\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QObject = Nothing\n , s3QAmzHeaders = case pbCannedAcl of\n Nothing -> []\n Just acl -> [(\"x-amz-acl\", T.encodeUtf8 $ writeCannedAcl acl)]\n , s3QOtherHeaders = []\n , s3QRequestBody\n = guard (not (null elts)) >>\n (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)\n XML.Document {\n XML.documentPrologue = XML.Prologue [] Nothing []\n , XML.documentRoot = root\n , XML.documentEpilogue = []\n }\n })\n where root = XML.Element {\n XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}CreateBucketConfiguration\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = elts\n }\n elts = catMaybes\n [ if T.null pbLocationConstraint then Nothing else Just (locationconstraint pbLocationConstraint)\n , fmap storageclass pbXStorageClass\n ]\n locationconstraint c = XML.NodeElement (XML.Element {\n XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = [XML.NodeContent c]\n })\n storageclass c = XML.NodeElement (XML.Element {\n XML.elementName = \"StorageClass\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = [XML.NodeContent (writeStorageClass c)]\n })\n\ninstance ResponseConsumer r PutBucketResponse where\n type ResponseMetadata PutBucketResponse = S3Metadata\n\n responseConsumer _ _ = s3ResponseConsumer $ \\_ -> return PutBucketResponse\n\ninstance Transaction PutBucket PutBucketResponse\n\ninstance AsMemoryResponse PutBucketResponse where\n type MemoryResponse PutBucketResponse = PutBucketResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/PutBucketVersioning.hs", "content": "module Aws.S3.Commands.PutBucketVersioning where\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Network.HTTP.Types (toQuery)\nimport qualified Data.Map as M\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Text.XML as XML\nimport qualified Data.ByteString.Lazy.Char8 as B8\n\ndata VersioningState = VersioningSuspended | VersioningEnabled\n deriving (Show)\n\n-- | Sets the versioning state of an existing bucket.\ndata PutBucketVersioning\n = PutBucketVersioning\n { pbvBucket :: Bucket\n , pbvVersioningConfiguration :: VersioningState\n }\n deriving (Show)\n\nputBucketVersioning :: Bucket -> VersioningState -> PutBucketVersioning\nputBucketVersioning = PutBucketVersioning\n\ndata PutBucketVersioningResponse\n = PutBucketVersioningResponse\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery PutBucketVersioning where\n type ServiceConfiguration PutBucketVersioning = S3Configuration\n\n signQuery PutBucketVersioning{..} = s3SignQuery $ S3Query\n { s3QMethod = Put\n , s3QBucket = Just $ T.encodeUtf8 pbvBucket\n , s3QSubresources = toQuery [(\"versioning\" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QObject = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)\n XML.Document\n { XML.documentPrologue = XML.Prologue [] Nothing []\n , XML.documentRoot = XML.Element\n { XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}VersioningConfiguration\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = [ XML.NodeElement (XML.Element\n { XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}Status\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = case pbvVersioningConfiguration of\n VersioningSuspended -> [XML.NodeContent \"Suspended\"]\n VersioningEnabled -> [XML.NodeContent \"Enabled\"]\n })]\n }\n , XML.documentEpilogue = []\n }\n }\n\ninstance ResponseConsumer r PutBucketVersioningResponse where\n type ResponseMetadata PutBucketVersioningResponse = S3Metadata\n\n responseConsumer _ _ = s3ResponseConsumer $ \\_ -> return PutBucketVersioningResponse\n\ninstance Transaction PutBucketVersioning PutBucketVersioningResponse\n\ninstance AsMemoryResponse PutBucketVersioningResponse where\n type MemoryResponse PutBucketVersioningResponse = PutBucketVersioningResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/PutObject.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Aws.S3.Commands.PutObject\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport Control.Applicative\nimport Control.Arrow (second)\nimport qualified Crypto.Hash as CH\nimport Data.ByteString.Char8 ({- IsString -})\nimport Data.Maybe\nimport qualified Data.ByteString.Char8 as B\nimport qualified Data.CaseInsensitive as CI\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport Prelude\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types.URI as URI\n\ndata PutObject = PutObject {\n poObjectName :: T.Text,\n poBucket :: Bucket,\n poContentType :: Maybe B.ByteString,\n poCacheControl :: Maybe T.Text,\n poContentDisposition :: Maybe T.Text,\n poContentEncoding :: Maybe T.Text,\n poContentMD5 :: Maybe (CH.Digest CH.MD5),\n poExpires :: Maybe Int,\n poAcl :: Maybe CannedAcl,\n poStorageClass :: Maybe StorageClass,\n poWebsiteRedirectLocation :: Maybe T.Text,\n poServerSideEncryption :: Maybe ServerSideEncryption,\n poRequestBody :: HTTP.RequestBody,\n poMetadata :: [(T.Text,T.Text)],\n poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension\n poExpect100Continue :: Bool, -- ^ Note: Requires http-client >= 0.4.10\n poTagging :: [(T.Text,T.Text)] -- ^ tag-set as key/value pairs\n}\n\nputObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject\nputObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False []\n\ndata PutObjectResponse\n = PutObjectResponse\n { porVersionId :: Maybe T.Text\n , porETag :: T.Text\n }\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery PutObject where\n type ServiceConfiguration PutObject = S3Configuration\n signQuery PutObject {..} = s3SignQuery S3Query {\n s3QMethod = Put\n , s3QBucket = Just $ T.encodeUtf8 poBucket\n , s3QSubresources = []\n , s3QQuery = []\n , s3QContentType = poContentType\n , s3QContentMd5 = poContentMD5\n , s3QAmzHeaders = map (second T.encodeUtf8) (catMaybes [\n (\"x-amz-acl\",) <$> writeCannedAcl <$> poAcl\n , (\"x-amz-storage-class\",) <$> writeStorageClass <$> poStorageClass\n , (\"x-amz-website-redirect-location\",) <$> poWebsiteRedirectLocation\n , (\"x-amz-server-side-encryption\",) <$> writeServerSideEncryption <$> poServerSideEncryption\n , if poAutoMakeBucket then Just (\"x-amz-auto-make-bucket\", \"1\") else Nothing\n ] ++ map( \\x -> (CI.mk . T.encodeUtf8 $ T.concat [\"x-amz-meta-\", fst x], snd x)) poMetadata\n ) ++ if null poTagging\n then []\n else [(\"x-amz-tagging\", URI.renderQuery False $ URI.queryTextToQuery $ map (second Just) poTagging)]\n , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [\n (\"Expires\",) . T.pack . show <$> poExpires\n , (\"Cache-Control\",) <$> poCacheControl\n , (\"Content-Disposition\",) <$> poContentDisposition\n , (\"Content-Encoding\",) <$> poContentEncoding\n , if poExpect100Continue\n then Just (\"Expect\", \"100-continue\")\n else Nothing\n ]\n , s3QRequestBody = Just poRequestBody\n , s3QObject = Just $ T.encodeUtf8 poObjectName\n }\n\ninstance ResponseConsumer PutObject PutObjectResponse where\n type ResponseMetadata PutObjectResponse = S3Metadata\n responseConsumer _ _ = s3ResponseConsumer $ \\resp -> do\n let vid = T.decodeUtf8 `fmap` lookup \"x-amz-version-id\" (HTTP.responseHeaders resp)\n let etag = fromMaybe \"\" $ T.decodeUtf8 `fmap` lookup \"ETag\" (HTTP.responseHeaders resp)\n return $ PutObjectResponse vid etag\n\ninstance Transaction PutObject PutObjectResponse\n\ninstance AsMemoryResponse PutObjectResponse where\n type MemoryResponse PutObjectResponse = PutObjectResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands/RestoreObject.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Aws.S3.Commands.RestoreObject\nwhere\n\nimport Aws.Core\nimport Aws.S3.Core\nimport qualified Data.ByteString.Lazy.Char8 as B8\nimport qualified Data.Map as M\nimport Data.Maybe\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Types as HTTP\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Text.XML as XML\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport Prelude\n\ndata RestoreObject\n = RestoreObject { roObjectName :: Object\n , roBucket :: Bucket\n , roVersionId :: Maybe T.Text\n , roTier :: RestoreObjectTier\n , roObjectLifetimeDays :: RestoreObjectLifetimeDays\n }\n deriving (Show)\n\ndata RestoreObjectTier\n = RestoreObjectTierExpedited\n | RestoreObjectTierStandard\n | RestoreObjectTierBulk\n deriving (Show)\n\ndata RestoreObjectLifetimeDays = RestoreObjectLifetimeDays Integer\n deriving (Show)\n\nrestoreObject :: Bucket -> T.Text -> RestoreObjectTier -> RestoreObjectLifetimeDays -> RestoreObject\nrestoreObject bucket obj tier lifetime = RestoreObject obj bucket Nothing tier lifetime\n\ndata RestoreObjectResponse\n = RestoreObjectAccepted\n | RestoreObjectAlreadyRestored\n | RestoreObjectAlreadyInProgress\n deriving (Show)\n\n-- | ServiceConfiguration: 'S3Configuration'\ninstance SignQuery RestoreObject where\n type ServiceConfiguration RestoreObject = S3Configuration\n signQuery RestoreObject {..} = s3SignQuery S3Query\n { s3QMethod = Post\n , s3QBucket = Just $ T.encodeUtf8 roBucket\n , s3QObject = Just $ T.encodeUtf8 roObjectName\n , s3QSubresources = HTTP.toQuery\n [ Just ( \"restore\" :: B8.ByteString, Nothing :: Maybe T.Text)\n , case roVersionId of\n Nothing -> Nothing\n Just v -> Just (\"versionId\" :: B8.ByteString, Just v)\n ]\n , s3QQuery = []\n , s3QContentType = Nothing\n , s3QContentMd5 = Nothing\n , s3QAmzHeaders = []\n , s3QOtherHeaders = []\n , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)\n XML.Document\n { XML.documentPrologue = XML.Prologue [] Nothing []\n , XML.documentRoot = XML.Element\n { XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}RestoreRequest\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes =\n [ XML.NodeElement (XML.Element\n { XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}Days\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = case roObjectLifetimeDays of\n RestoreObjectLifetimeDays n -> [XML.NodeContent (T.pack (show n))]\n })\n , XML.NodeElement (XML.Element\n { XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}GlacierJobParameters\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes =\n [ XML.NodeElement (XML.Element\n { XML.elementName = \"{http://s3.amazonaws.com/doc/2006-03-01/}Tier\"\n , XML.elementAttributes = M.empty\n , XML.elementNodes = case roTier of\n RestoreObjectTierExpedited -> [XML.NodeContent \"Expedited\"]\n RestoreObjectTierStandard -> [XML.NodeContent \"Standard\"]\n RestoreObjectTierBulk -> [XML.NodeContent \"Bulk\"] \n })\n ]\n })\n ]\n }\n , XML.documentEpilogue = []\n }\n }\n\ninstance ResponseConsumer RestoreObject RestoreObjectResponse where\n type ResponseMetadata RestoreObjectResponse = S3Metadata\n responseConsumer httpReq _ _ resp\n | status == HTTP.status202 = return RestoreObjectAccepted\n | status == HTTP.status200 = return RestoreObjectAlreadyRestored\n | status == HTTP.status409 = return RestoreObjectAlreadyInProgress\n | otherwise = throwStatusCodeException httpReq resp\n where\n status = HTTP.responseStatus resp\n\ninstance Transaction RestoreObject RestoreObjectResponse\n\ninstance AsMemoryResponse RestoreObjectResponse where\n type MemoryResponse RestoreObjectResponse = RestoreObjectResponse\n loadToMemory = return\n" }, { "path": "Aws/S3/Commands.hs", "content": "module Aws.S3.Commands\n(\n module Aws.S3.Commands.CopyObject\n, module Aws.S3.Commands.DeleteBucket\n, module Aws.S3.Commands.DeleteObject\n, module Aws.S3.Commands.DeleteObjectVersion\n, module Aws.S3.Commands.DeleteObjects\n, module Aws.S3.Commands.GetBucket\n, module Aws.S3.Commands.GetBucketLocation\n, module Aws.S3.Commands.GetBucketObjectVersions\n, module Aws.S3.Commands.GetBucketVersioning\n, module Aws.S3.Commands.GetObject\n, module Aws.S3.Commands.GetService\n, module Aws.S3.Commands.HeadObject\n, module Aws.S3.Commands.PutBucket\n, module Aws.S3.Commands.PutBucketVersioning\n, module Aws.S3.Commands.PutObject\n, module Aws.S3.Commands.RestoreObject\n, module Aws.S3.Commands.Multipart\n)\nwhere\n\nimport Aws.S3.Commands.CopyObject\nimport Aws.S3.Commands.DeleteBucket\nimport Aws.S3.Commands.DeleteObject\nimport Aws.S3.Commands.DeleteObjectVersion\nimport Aws.S3.Commands.DeleteObjects\nimport Aws.S3.Commands.GetBucket\nimport Aws.S3.Commands.GetBucketLocation\nimport Aws.S3.Commands.GetBucketObjectVersions\nimport Aws.S3.Commands.GetBucketVersioning\nimport Aws.S3.Commands.GetObject\nimport Aws.S3.Commands.GetService\nimport Aws.S3.Commands.HeadObject\nimport Aws.S3.Commands.PutBucket\nimport Aws.S3.Commands.PutBucketVersioning\nimport Aws.S3.Commands.PutObject\nimport Aws.S3.Commands.RestoreObject\nimport Aws.S3.Commands.Multipart\n" }, { "path": "Aws/S3/Core.hs", "content": "{-# LANGUAGE CPP, BangPatterns #-}\nmodule Aws.S3.Core where\n\nimport Aws.Core\nimport Control.Arrow (first, (***))\nimport Control.Monad\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Resource (MonadThrow, throwM)\nimport Data.Char (isAscii, isAlphaNum, toUpper, ord)\nimport Data.Conduit ((.|))\nimport Data.Function\nimport Data.Functor\nimport Data.IORef\nimport Data.List\nimport Data.Maybe\nimport Data.Monoid\nimport qualified Data.Semigroup as Sem\nimport Control.Applicative ((<|>))\nimport Data.Time\nimport Data.Typeable\nimport Numeric (showHex)\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport Text.XML.Cursor (($/), (&|))\nimport qualified Data.Attoparsec.ByteString as Atto\nimport qualified Blaze.ByteString.Builder as Blaze\nimport qualified Blaze.ByteString.Builder.Char8 as Blaze8\nimport qualified Control.Exception as C\nimport qualified Crypto.Hash as CH\nimport qualified Data.ByteArray as ByteArray\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Char8 as B8\nimport qualified Data.ByteString.Base16 as Base16\nimport qualified Data.ByteString.Base64 as Base64\nimport qualified Data.CaseInsensitive as CI\nimport qualified Data.Conduit as C\nimport qualified Data.Map as Map\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport qualified Text.XML as XML\nimport qualified Text.XML.Cursor as Cu\nimport Prelude\n\ndata S3Authorization\n = S3AuthorizationHeader\n | S3AuthorizationQuery\n deriving (Show)\n\ndata RequestStyle\n = PathStyle -- ^ Requires correctly setting region endpoint, but allows non-DNS compliant bucket names in the US standard region.\n | BucketStyle -- ^ Bucket name must be DNS compliant.\n | VHostStyle\n deriving (Show)\n\ndata S3SignPayloadMode\n = AlwaysUnsigned -- ^ Always use the \"UNSIGNED-PAYLOAD\" option.\n | SignWithEffort -- ^ Sign the payload when 'HTTP.RequestBody' is a on-memory one ('HTTP.RequestBodyLBS' or 'HTTP.RequestBodyBS'). Otherwise use the \"UNSINGED-PAYLOAD\" option.\n | AlwaysSigned -- ^ Always sign the payload. Note: 'error' called when 'HTTP.RequestBody' is a streaming one.\n deriving (Eq, Show, Read, Typeable)\n\ndata S3SignVersion\n = S3SignV2\n | S3SignV4 { _s3SignPayloadMode :: S3SignPayloadMode }\n deriving (Eq, Show, Read, Typeable)\n\ndata S3Configuration qt\n = S3Configuration\n { s3Protocol :: Protocol\n , s3Endpoint :: B.ByteString\n , s3Region :: Maybe B.ByteString\n , s3RequestStyle :: RequestStyle\n , s3Port :: Int\n , s3ServerSideEncryption :: Maybe ServerSideEncryption\n , s3UseUri :: Bool\n , s3DefaultExpiry :: NominalDiffTime\n , s3SignVersion :: S3SignVersion\n , s3UserAgent :: Maybe T.Text\n }\n deriving (Show)\n\ninstance DefaultServiceConfiguration (S3Configuration NormalQuery) where\n defServiceConfig = s3 HTTPS s3EndpointUsClassic False\n\n debugServiceConfig = s3 HTTP s3EndpointUsClassic False\n\ninstance DefaultServiceConfiguration (S3Configuration UriOnlyQuery) where\n defServiceConfig = s3 HTTPS s3EndpointUsClassic True\n debugServiceConfig = s3 HTTP s3EndpointUsClassic True\n\ns3EndpointUsClassic :: B.ByteString\ns3EndpointUsClassic = \"s3.amazonaws.com\"\n\ns3EndpointUsWest :: B.ByteString\ns3EndpointUsWest = \"s3-us-west-1.amazonaws.com\"\n\ns3EndpointUsWest2 :: B.ByteString\ns3EndpointUsWest2 = \"s3-us-west-2.amazonaws.com\"\n\ns3EndpointEu :: B.ByteString\ns3EndpointEu = \"s3-eu-west-1.amazonaws.com\"\n\ns3EndpointEuWest2 :: B.ByteString\ns3EndpointEuWest2 = \"s3-eu-west-2.amazonaws.com\"\n\ns3EndpointApSouthEast :: B.ByteString\ns3EndpointApSouthEast = \"s3-ap-southeast-1.amazonaws.com\"\n\ns3EndpointApSouthEast2 :: B.ByteString\ns3EndpointApSouthEast2 = \"s3-ap-southeast-2.amazonaws.com\"\n\ns3EndpointApNorthEast :: B.ByteString\ns3EndpointApNorthEast = \"s3-ap-northeast-1.amazonaws.com\"\n\ns3 :: Protocol -> B.ByteString -> Bool -> S3Configuration qt\ns3 protocol endpoint uri\n = S3Configuration\n { s3Protocol = protocol\n , s3Endpoint = endpoint\n , s3Region = Nothing\n , s3RequestStyle = BucketStyle\n , s3Port = defaultPort protocol\n , s3ServerSideEncryption = Nothing\n , s3UseUri = uri\n , s3DefaultExpiry = 15*60\n , s3SignVersion = S3SignV2\n , s3UserAgent = Nothing\n }\n\ns3v4 :: Protocol -> B.ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt\ns3v4 protocol endpoint uri payload\n = S3Configuration\n { s3Protocol = protocol\n , s3Endpoint = endpoint\n , s3Region = Nothing\n , s3RequestStyle = BucketStyle\n , s3Port = defaultPort protocol\n , s3ServerSideEncryption = Nothing\n , s3UseUri = uri\n , s3DefaultExpiry = 15*60\n , s3SignVersion = S3SignV4 payload\n , s3UserAgent = Nothing\n }\n\n\ntype ErrorCode = T.Text\n\ndata S3Error\n = S3Error {\n s3StatusCode :: HTTP.Status\n , s3ErrorCode :: ErrorCode -- Error/Code\n , s3ErrorMessage :: T.Text -- Error/Message\n , s3ErrorResource :: Maybe T.Text -- Error/Resource\n , s3ErrorHostId :: Maybe T.Text -- Error/HostId\n , s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId\n , s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding)\n , s3ErrorBucket :: Maybe T.Text -- Error/Bucket\n , s3ErrorEndpointRaw :: Maybe T.Text -- Error/Endpoint (i.e. correct bucket location)\n , s3ErrorEndpoint :: Maybe B.ByteString -- Error/Endpoint without the bucket prefix\n }\n deriving (Show, Typeable)\n\ninstance C.Exception S3Error\n\ndata S3Metadata\n = S3Metadata {\n s3MAmzId2 :: Maybe T.Text\n , s3MRequestId :: Maybe T.Text\n }\n deriving (Show, Typeable)\n\ninstance Sem.Semigroup S3Metadata where\n S3Metadata a1 r1 <> S3Metadata a2 r2 = S3Metadata (a1 `mplus` a2) (r1 `mplus` r2)\n\ninstance Monoid S3Metadata where\n mempty = S3Metadata Nothing Nothing\n mappend = (Sem.<>)\n\ninstance Loggable S3Metadata where\n toLogText (S3Metadata id2 rid) = \"S3: request ID=\" `mappend`\n fromMaybe \"\" rid `mappend`\n \", x-amz-id-2=\" `mappend`\n fromMaybe \"\" id2\n\ndata S3Query\n = S3Query {\n s3QMethod :: Method\n , s3QBucket :: Maybe B.ByteString\n , s3QObject :: Maybe B.ByteString\n , s3QSubresources :: HTTP.Query\n , s3QQuery :: HTTP.Query\n , s3QContentType :: Maybe B.ByteString\n , s3QContentMd5 :: Maybe (CH.Digest CH.MD5)\n , s3QAmzHeaders :: HTTP.RequestHeaders\n , s3QOtherHeaders :: HTTP.RequestHeaders\n , s3QRequestBody :: Maybe HTTP.RequestBody\n }\n\ninstance Show S3Query where\n show S3Query{..} = \"S3Query [\" ++\n \" method: \" ++ show s3QMethod ++\n \" ; bucket: \" ++ show s3QBucket ++\n \" ; subresources: \" ++ show s3QSubresources ++\n \" ; query: \" ++ show s3QQuery ++\n \" ; request body: \" ++ (case s3QRequestBody of Nothing -> \"no\"; _ -> \"yes\") ++\n \"]\"\n\nhAmzDate, hAmzContentSha256, hAmzAlgorithm, hAmzCredential, hAmzExpires, hAmzSignedHeaders, hAmzSignature, hAmzSecurityToken :: HTTP.HeaderName\nhAmzDate = \"X-Amz-Date\"\nhAmzContentSha256 = \"X-Amz-Content-Sha256\"\nhAmzAlgorithm = \"X-Amz-Algorithm\"\nhAmzCredential = \"X-Amz-Credential\"\nhAmzExpires = \"X-Amz-Expires\"\nhAmzSignedHeaders = \"X-Amz-SignedHeaders\"\nhAmzSignature = \"X-Amz-Signature\"\nhAmzSecurityToken = \"X-Amz-Security-Token\"\n\ns3SignQuery :: S3Query -> S3Configuration qt -> SignatureData -> SignedQuery\ns3SignQuery S3Query{..} S3Configuration{ s3SignVersion = S3SignV2, .. } SignatureData{..}\n = SignedQuery {\n sqMethod = s3QMethod\n , sqProtocol = s3Protocol\n , sqHost = B.intercalate \".\" $ catMaybes host\n , sqPort = s3Port\n , sqPath = mconcat $ catMaybes path\n , sqQuery = sortedSubresources ++ s3QQuery ++ authQuery :: HTTP.Query\n , sqDate = Just signatureTime\n , sqAuthorization = authorization\n , sqContentType = s3QContentType\n , sqContentMd5 = s3QContentMd5\n , sqAmzHeaders = amzHeaders\n , sqOtherHeaders = useragent ++ s3QOtherHeaders\n , sqBody = s3QRequestBody\n , sqStringToSign = stringToSign\n }\n where\n -- This also implements anonymous queries.\n isanon = isAnonymousCredentials signatureCredentials \n amzHeaders = merge $ sortBy (compare `on` fst) $ s3QAmzHeaders ++ \n if isanon \n then []\n else fmap (\\(k, v) -> (CI.mk k, v)) iamTok\n where merge (x1@(k1,v1):x2@(k2,v2):xs) | k1 == k2 = merge ((k1, B8.intercalate \",\" [v1, v2]) : xs)\n | otherwise = x1 : merge (x2 : xs)\n merge xs = xs\n\n urlEncodedS3QObject = s3UriEncode False <$> s3QObject\n (host, path) = case s3RequestStyle of\n PathStyle -> ([Just s3Endpoint], [Just \"/\", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject])\n BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just \"/\", urlEncodedS3QObject])\n VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just \"/\", urlEncodedS3QObject])\n sortedSubresources = sort s3QSubresources\n canonicalizedResource = Blaze8.fromChar '/' `mappend`\n maybe mempty (\\s -> Blaze.copyByteString s `mappend` Blaze8.fromChar '/') s3QBucket `mappend`\n maybe mempty Blaze.copyByteString urlEncodedS3QObject `mappend`\n encodeQuerySign sortedSubresources\n -- query parameters overriding response headers must not be URI encoded when calculating signature\n -- http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#ConstructingTheCanonicalizedResourceElement\n -- Note this is limited to amazon auth version 2 in the new auth version 4 this weird exception is not present\n encodeQuerySign qs =\n let ceq = Blaze8.fromChar '='\n cqt = Blaze8.fromChar '?'\n camp = Blaze8.fromChar '&'\n overrideParams = map B8.pack [\"response-content-type\", \"response-content-language\", \"response-expires\", \"response-cache-control\", \"response-content-disposition\", \"response-content-encoding\"]\n encItem (k, mv) =\n let enc = if k `elem` overrideParams then Blaze.copyByteString else HTTP.urlEncodeBuilder True\n in enc k `mappend` maybe mempty (mappend ceq . enc) mv\n in case intersperse camp (map encItem qs) of\n [] -> mempty\n qs' -> mconcat (cqt :qs')\n\n ti = case (s3UseUri, signatureTimeInfo) of\n (False, ti') -> ti'\n (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time\n (True, AbsoluteExpires time) -> AbsoluteExpires time\n sig = signature signatureCredentials HmacSHA1 stringToSign\n iamTok = maybe [] (\\x -> [(\"x-amz-security-token\", x)]) (iamToken signatureCredentials)\n stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\\n') . concat $\n [[Blaze.copyByteString $ httpMethod s3QMethod]\n , [maybe mempty (Blaze.copyByteString . Base64.encode . ByteArray.convert) s3QContentMd5]\n , [maybe mempty Blaze.copyByteString s3QContentType]\n , [Blaze.copyByteString $ case ti of\n AbsoluteTimestamp time -> fmtRfc822Time time\n AbsoluteExpires time -> fmtTimeEpochSeconds time]\n , map amzHeader amzHeaders\n , [canonicalizedResource]\n ]\n where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v\n (authorization, authQuery) = case ti of\n AbsoluteTimestamp _\n | isanon -> (Nothing, [])\n | otherwise -> (Just $ return $ B.concat [\"AWS \", accessKeyID signatureCredentials, \":\", sig], [])\n AbsoluteExpires time -> (Nothing, HTTP.toQuery $ makeAuthQuery time)\n makeAuthQuery time\n | isanon = []\n | otherwise = \n [ (\"Expires\" :: B8.ByteString, fmtTimeEpochSeconds time)\n , (\"AWSAccessKeyId\", accessKeyID signatureCredentials)\n , (\"SignatureMethod\", \"HmacSHA256\")\n , (\"Signature\", sig)] ++ iamTok\n \n useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent\ns3SignQuery sq@S3Query{..} sc@S3Configuration{ s3SignVersion = S3SignV4 signpayload, .. } sd@SignatureData{..}\n | isAnonymousCredentials signatureCredentials =\n s3SignQuery sq (sc { s3SignVersion = S3SignV2 }) sd\n | otherwise = SignedQuery\n { sqMethod = s3QMethod\n , sqProtocol = s3Protocol\n , sqHost = B.intercalate \".\" $ catMaybes host\n , sqPort = s3Port\n , sqPath = mconcat $ catMaybes path\n , sqQuery = queryString ++ signatureQuery :: HTTP.Query\n , sqDate = Just signatureTime\n , sqAuthorization = authorization\n , sqContentType = s3QContentType\n , sqContentMd5 = s3QContentMd5\n , sqAmzHeaders = Map.toList amzHeaders\n , sqOtherHeaders = useragent ++ s3QOtherHeaders\n , sqBody = s3QRequestBody\n , sqStringToSign = stringToSign\n }\n where\n -- V4 signing\n -- * \n -- * \n -- * \n\n iamTok = maybe [] (\\x -> [(hAmzSecurityToken, x)]) $ iamToken signatureCredentials\n\n amzHeaders = Map.fromList $ (hAmzDate, sigTime):(hAmzContentSha256, payloadHash):iamTok ++ s3QAmzHeaders\n where\n -- needs to match the one produces in the @authorizationV4@\n sigTime = fmtTime \"%Y%m%dT%H%M%SZ\" $ signatureTime\n payloadHash = case (signpayload, s3QRequestBody) of\n (AlwaysUnsigned, _) -> \"UNSIGNED-PAYLOAD\"\n (_, Nothing) -> emptyBodyHash\n (_, Just (HTTP.RequestBodyLBS lbs)) -> Base16.encode $ ByteArray.convert (CH.hashlazy lbs :: CH.Digest CH.SHA256)\n (_, Just (HTTP.RequestBodyBS bs)) -> Base16.encode $ ByteArray.convert (CH.hash bs :: CH.Digest CH.SHA256)\n (SignWithEffort, _) -> \"UNSIGNED-PAYLOAD\"\n (AlwaysSigned, _) -> error \"aws: RequestBody must be a on-memory one when AlwaysSigned mode.\"\n emptyBodyHash = \"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855\"\n\n (host, path) = case s3RequestStyle of\n PathStyle -> ([Just s3Endpoint], [Just \"/\", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject])\n BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just \"/\", urlEncodedS3QObject])\n VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just \"/\", urlEncodedS3QObject])\n where\n urlEncodedS3QObject = s3UriEncode False <$> s3QObject\n\n -- must provide host in the canonical headers.\n canonicalHeaders = Map.union amzHeaders . Map.fromList $ catMaybes\n [ Just (\"host\", B.intercalate \".\" $ catMaybes host)\n , (\"content-type\",) <$> s3QContentType\n ]\n signedHeaders = B8.intercalate \";\" (map CI.foldedCase $ Map.keys canonicalHeaders)\n stringToSign = B.intercalate \"\\n\" $\n [ httpMethod s3QMethod -- method\n , mconcat . catMaybes $ path -- path\n , s3RenderQuery False $ sort queryString -- query string\n ] ++\n Map.foldMapWithKey (\\a b -> [CI.foldedCase a Sem.<> \":\" Sem.<> b]) canonicalHeaders ++\n [ \"\" -- end headers\n , signedHeaders\n , amzHeaders Map.! hAmzContentSha256\n ]\n\n (authorization, signatureQuery, queryString) = case ti of\n AbsoluteTimestamp _ -> (Just auth, [], allQueries)\n AbsoluteExpires time ->\n ( Nothing\n , [(CI.original hAmzSignature, Just sig)]\n , (allQueries ++) . HTTP.toQuery . map (first CI.original) $\n [ (hAmzAlgorithm, \"AWS4-HMAC-SHA256\")\n , (hAmzCredential, cred)\n , (hAmzDate, amzHeaders Map.! hAmzDate)\n , (hAmzExpires, B8.pack . (show :: Integer -> String) . floor $ diffUTCTime time signatureTime)\n , (hAmzSignedHeaders, signedHeaders)\n ] ++ iamTok\n )\n where\n allQueries = s3QSubresources ++ s3QQuery\n region = fromMaybe (s3ExtractRegion s3Endpoint) s3Region\n auth = authorizationV4 sd HmacSHA256 region \"s3\" signedHeaders stringToSign\n sig = signatureV4 sd HmacSHA256 region \"s3\" stringToSign\n cred = credentialV4 sd region \"s3\"\n ti = case (s3UseUri, signatureTimeInfo) of\n (False, t) -> t\n (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time\n (True, AbsoluteExpires time) -> AbsoluteExpires time\n \n useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent\n\n-- | Custom UriEncode function\n-- see \ns3UriEncode\n :: Bool -- ^ Whether encode slash characters\n -> B.ByteString\n -> B.ByteString\ns3UriEncode encodeSlash = B8.concatMap $ \\c ->\n if (isAscii c && isAlphaNum c) || (c `elem` nonEncodeMarks)\n then B8.singleton c\n else B8.pack $ '%' : map toUpper (showHex (ord c) \"\")\n where\n nonEncodeMarks :: String\n nonEncodeMarks = if encodeSlash\n then \"_-~.\"\n else \"_-~./\"\n\ns3RenderQuery\n :: Bool -- ^ Whether prepend a question mark\n -> HTTP.Query\n -> B.ByteString\ns3RenderQuery qm = mconcat . qmf . intersperse (B8.singleton '&') . map renderItem\n where\n qmf = if qm then (\"?\":) else id\n\n renderItem :: HTTP.QueryItem -> B8.ByteString\n renderItem (k, Just v) = s3UriEncode True k Sem.<> \"=\" Sem.<> s3UriEncode True v\n renderItem (k, Nothing) = s3UriEncode True k Sem.<> \"=\"\n\n-- | Extract a S3 region from the S3 endpoint. AWS encodes the region names\n-- in the hostnames of endpoints in a way that makes this possible,\n-- see: \n-- For other S3 implementations, may instead need to specify s3Region.\ns3ExtractRegion :: B.ByteString -> B.ByteString\ns3ExtractRegion \"s3.amazonaws.com\" = \"us-east-1\"\ns3ExtractRegion \"s3-external-1.amazonaws.com\" = \"us-east-1\"\ns3ExtractRegion domain = either (const domain) B.pack $ Atto.parseOnly parser domain\n where\n -- s3.dualstack..amazonaws.com\n -- s3-.amazonaws.com\n -- s3..amazonaws.com\n parser = do\n _ <- Atto.string \"s3\"\n _ <- Atto.string \".dualstack.\" <|> Atto.string \"-\" <|> Atto.string \".\"\n r <- Atto.manyTill Atto.anyWord8 $ Atto.string \".amazonaws.com\"\n Atto.endOfInput\n return r\n\ns3ResponseConsumer :: HTTPResponseConsumer a\n -> IORef S3Metadata\n -> HTTPResponseConsumer a\ns3ResponseConsumer inner metadataRef = s3BinaryResponseConsumer inner' metadataRef\n where inner' resp =\n do\n !res <- inner resp\n return res\n\ns3BinaryResponseConsumer :: HTTPResponseConsumer a\n -> IORef S3Metadata\n -> HTTPResponseConsumer a\ns3BinaryResponseConsumer inner metadata resp = do\n let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)\n let amzId2 = headerString \"x-amz-id-2\"\n let requestId = headerString \"x-amz-request-id\"\n\n let m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId }\n liftIO $ tellMetadataRef metadata m\n\n if HTTP.responseStatus resp >= HTTP.status300\n then s3ErrorResponseConsumer resp\n else inner resp\n\ns3XmlResponseConsumer :: (Cu.Cursor -> Response S3Metadata a)\n -> IORef S3Metadata\n -> HTTPResponseConsumer a\ns3XmlResponseConsumer parse metadataRef =\n s3ResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef\n\ns3ErrorResponseConsumer :: HTTPResponseConsumer a\ns3ErrorResponseConsumer resp\n = do doc <- C.runConduit $ HTTP.responseBody resp .| XML.sinkDoc XML.def\n let cursor = Cu.fromDocument doc\n liftIO $ case parseError cursor of\n Right err -> throwM err\n Left otherErr -> throwM otherErr\n where\n parseError :: Cu.Cursor -> Either C.SomeException S3Error\n parseError root = do code <- force \"Missing error Code\" $ root $/ elContent \"Code\"\n message <- force \"Missing error Message\" $ root $/ elContent \"Message\"\n let resource = listToMaybe $ root $/ elContent \"Resource\"\n hostId = listToMaybe $ root $/ elContent \"HostId\"\n accessKeyId = listToMaybe $ root $/ elContent \"AWSAccessKeyId\"\n bucket = listToMaybe $ root $/ elContent \"Bucket\"\n endpointRaw = listToMaybe $ root $/ elContent \"Endpoint\"\n endpoint = T.encodeUtf8 <$> (T.stripPrefix (fromMaybe \"\" bucket Sem.<> \".\") =<< endpointRaw)\n stringToSign = do unprocessed <- listToMaybe $ root $/ elCont \"StringToSignBytes\"\n bytes <- mapM readHex2 $ words unprocessed\n return $ B.pack bytes\n return S3Error {\n s3StatusCode = HTTP.responseStatus resp\n , s3ErrorCode = code\n , s3ErrorMessage = message\n , s3ErrorResource = resource\n , s3ErrorHostId = hostId\n , s3ErrorAccessKeyId = accessKeyId\n , s3ErrorStringToSign = stringToSign\n , s3ErrorBucket = bucket\n , s3ErrorEndpointRaw = endpointRaw\n , s3ErrorEndpoint = endpoint\n }\n\ntype CanonicalUserId = T.Text\n\ndata UserInfo\n = UserInfo {\n userId :: CanonicalUserId\n , userDisplayName :: Maybe T.Text\n }\n deriving (Show)\n\nparseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo\nparseUserInfo el = do id_ <- force \"Missing user ID\" $ el $/ elContent \"ID\"\n displayName <- return $ case (el $/ elContent \"DisplayName\") of\n (x:_) -> Just x\n [] -> Nothing\n return UserInfo { userId = id_, userDisplayName = displayName }\n\ndata CannedAcl\n = AclPrivate\n | AclPublicRead\n | AclPublicReadWrite\n | AclAuthenticatedRead\n | AclBucketOwnerRead\n | AclBucketOwnerFullControl\n | AclLogDeliveryWrite\n deriving (Show)\n\nwriteCannedAcl :: CannedAcl -> T.Text\nwriteCannedAcl AclPrivate = \"private\"\nwriteCannedAcl AclPublicRead = \"public-read\"\nwriteCannedAcl AclPublicReadWrite = \"public-read-write\"\nwriteCannedAcl AclAuthenticatedRead = \"authenticated-read\"\nwriteCannedAcl AclBucketOwnerRead = \"bucket-owner-read\"\nwriteCannedAcl AclBucketOwnerFullControl = \"bucket-owner-full-control\"\nwriteCannedAcl AclLogDeliveryWrite = \"log-delivery-write\"\n\ndata StorageClass\n = Standard\n | StandardInfrequentAccess\n | ReducedRedundancy\n | Glacier\n | OtherStorageClass T.Text\n deriving (Show)\n\nparseStorageClass :: T.Text -> StorageClass\nparseStorageClass \"STANDARD\" = Standard\nparseStorageClass \"STANDARD_IA\" = StandardInfrequentAccess\nparseStorageClass \"REDUCED_REDUNDANCY\" = ReducedRedundancy\nparseStorageClass \"GLACIER\" = Glacier\nparseStorageClass s = OtherStorageClass s\n\nwriteStorageClass :: StorageClass -> T.Text\nwriteStorageClass Standard = \"STANDARD\"\nwriteStorageClass StandardInfrequentAccess = \"STANDARD_IA\"\nwriteStorageClass ReducedRedundancy = \"REDUCED_REDUNDANCY\"\nwriteStorageClass Glacier = \"GLACIER\"\nwriteStorageClass (OtherStorageClass s) = s\n\ndata ServerSideEncryption\n = AES256\n deriving (Show)\n\nparseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption\nparseServerSideEncryption \"AES256\" = return AES256\nparseServerSideEncryption s = throwM . XmlException $ \"Invalid Server Side Encryption: \" ++ T.unpack s\n\nwriteServerSideEncryption :: ServerSideEncryption -> T.Text\nwriteServerSideEncryption AES256 = \"AES256\"\n\ntype Bucket = T.Text\n\ndata BucketInfo\n = BucketInfo {\n bucketName :: Bucket\n , bucketCreationDate :: UTCTime\n }\n deriving (Show)\n\ntype Object = T.Text\n\ndata ObjectId\n = ObjectId {\n oidBucket :: Bucket\n , oidObject :: Object\n , oidVersion :: Maybe T.Text\n }\n deriving (Show)\n\ndata ObjectVersionInfo\n = ObjectVersion {\n oviKey :: T.Text\n , oviVersionId :: T.Text\n , oviIsLatest :: Bool\n , oviLastModified :: UTCTime\n , oviETag :: T.Text\n , oviSize :: Integer\n , oviStorageClass :: StorageClass\n , oviOwner :: Maybe UserInfo\n }\n | DeleteMarker {\n oviKey :: T.Text\n , oviVersionId :: T.Text\n , oviIsLatest :: Bool\n , oviLastModified :: UTCTime\n , oviOwner :: Maybe UserInfo\n }\n deriving (Show)\n\nparseObjectVersionInfo :: MonadThrow m => Cu.Cursor -> m ObjectVersionInfo\nparseObjectVersionInfo el\n = do key <- force \"Missing object Key\" $ el $/ elContent \"Key\"\n versionId <- force \"Missing object VersionId\" $ el $/ elContent \"VersionId\"\n isLatest <- forceM \"Missing object IsLatest\" $ el $/ elContent \"IsLatest\" &| textReadBool\n let time s = case (parseTimeM True defaultTimeLocale \"%Y-%m-%dT%H:%M:%S%QZ\" $ T.unpack s) <|>\n (parseTimeM True defaultTimeLocale \"%Y-%m-%dT%H:%M:%S%Q%Z\" $ T.unpack s) of\n Nothing -> throwM $ XmlException \"Invalid time\"\n Just v -> return v\n lastModified <- forceM \"Missing object LastModified\" $ el $/ elContent \"LastModified\" &| time\n owner <- case el $/ Cu.laxElement \"Owner\" &| parseUserInfo of\n (x:_) -> fmap' Just x\n [] -> return Nothing\n case Cu.node el of\n XML.NodeElement e | elName e == \"Version\" ->\n do eTag <- force \"Missing object ETag\" $ el $/ elContent \"ETag\"\n size <- forceM \"Missing object Size\" $ el $/ elContent \"Size\" &| textReadInt\n storageClass <- case el $/ elContent \"StorageClass\" &| parseStorageClass of\n (x:_) -> return x\n [] -> return Standard\n return ObjectVersion{\n oviKey = key\n , oviVersionId = versionId\n , oviIsLatest = isLatest\n , oviLastModified = lastModified\n , oviETag = eTag\n , oviSize = size\n , oviStorageClass = storageClass\n , oviOwner = owner\n }\n XML.NodeElement e | elName e == \"DeleteMarker\" ->\n return DeleteMarker{\n oviKey = key\n , oviVersionId = versionId\n , oviIsLatest = isLatest\n , oviLastModified = lastModified\n , oviOwner = owner\n }\n _ -> throwM $ XmlException \"Invalid object version tag\"\n where\n elName = XML.nameLocalName . XML.elementName\n fmap' :: Monad m => (a -> b) -> m a -> m b\n fmap' f ma = ma >>= return . f\n\ndata ObjectInfo\n = ObjectInfo {\n objectKey :: T.Text\n , objectLastModified :: UTCTime\n , objectETag :: T.Text\n , objectSize :: Integer\n , objectStorageClass :: StorageClass\n , objectOwner :: Maybe UserInfo\n }\n deriving (Show)\n\nparseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo\nparseObjectInfo el\n = do key <- force \"Missing object Key\" $ el $/ elContent \"Key\"\n let time s = case (parseTimeM True defaultTimeLocale \"%Y-%m-%dT%H:%M:%S%QZ\" $ T.unpack s) <|>\n (parseTimeM True defaultTimeLocale \"%Y-%m-%dT%H:%M:%S%Q%Z\" $ T.unpack s) of\n Nothing -> throwM $ XmlException \"Invalid time\"\n Just v -> return v\n lastModified <- forceM \"Missing object LastModified\" $ el $/ elContent \"LastModified\" &| time\n eTag <- force \"Missing object ETag\" $ el $/ elContent \"ETag\"\n size <- forceM \"Missing object Size\" $ el $/ elContent \"Size\" &| textReadInt\n storageClass <- case el $/ elContent \"StorageClass\" &| parseStorageClass of\n (x:_) -> return x\n [] -> return Standard\n owner <- case el $/ Cu.laxElement \"Owner\" &| parseUserInfo of\n (x:_) -> fmap' Just x\n [] -> return Nothing\n return ObjectInfo{\n objectKey = key\n , objectLastModified = lastModified\n , objectETag = eTag\n , objectSize = size\n , objectStorageClass = storageClass\n , objectOwner = owner\n }\n where\n fmap' :: Monad m => (a -> b) -> m a -> m b\n fmap' f ma = ma >>= return . f\n\ndata ObjectMetadata\n = ObjectMetadata {\n omDeleteMarker :: Bool\n , omETag :: T.Text\n , omLastModified :: UTCTime\n , omVersionId :: Maybe T.Text\n-- TODO:\n-- , omExpiration :: Maybe (UTCTime, T.Text)\n , omUserMetadata :: [(T.Text, T.Text)]\n , omMissingUserMetadata :: Maybe T.Text\n , omServerSideEncryption :: Maybe ServerSideEncryption\n }\n deriving (Show)\n\nparseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata\nparseObjectMetadata h = ObjectMetadata\n `liftM` deleteMarker\n `ap` etag\n `ap` lastModified\n `ap` return versionId\n-- `ap` expiration\n `ap` return userMetadata\n `ap` return missingUserMetadata\n `ap` serverSideEncryption\n where deleteMarker = case B8.unpack `fmap` lookup \"x-amz-delete-marker\" h of\n Nothing -> return False\n Just \"true\" -> return True\n Just \"false\" -> return False\n Just x -> throwM $ HeaderException (\"Invalid x-amz-delete-marker \" ++ x)\n etag = case T.decodeUtf8 `fmap` lookup \"ETag\" h of\n Just x -> return x\n Nothing -> throwM $ HeaderException \"ETag missing\"\n lastModified = case B8.unpack `fmap` lookup \"Last-Modified\" h of\n Just ts -> case parseHttpDate ts of\n Just t -> return t\n Nothing -> throwM $ HeaderException (\"Invalid Last-Modified: \" ++ ts)\n Nothing -> throwM $ HeaderException \"Last-Modified missing\"\n versionId = T.decodeUtf8 `fmap` lookup \"x-amz-version-id\" h\n -- expiration = return undefined\n userMetadata = flip mapMaybe ht $\n \\(k, v) -> do i <- T.stripPrefix \"x-amz-meta-\" k\n return (i, v)\n missingUserMetadata = T.decodeUtf8 `fmap` lookup \"x-amz-missing-meta\" h\n serverSideEncryption = case T.decodeUtf8 `fmap` lookup \"x-amz-server-side-encryption\" h of\n Just x -> return $ parseServerSideEncryption x\n Nothing -> return Nothing\n\n ht = map ((T.decodeUtf8 . CI.foldedCase) *** T.decodeUtf8) h\n\ntype LocationConstraint = T.Text\n\nlocationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuWest2, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint\nlocationUsClassic = \"\"\nlocationUsWest = \"us-west-1\"\nlocationUsWest2 = \"us-west-2\"\nlocationEu = \"EU\"\nlocationEuWest2 = \"eu-west-2\"\nlocationEuFrankfurt = \"eu-central-1\"\nlocationApSouthEast = \"ap-southeast-1\"\nlocationApSouthEast2 = \"ap-southeast-2\"\nlocationApNorthEast = \"ap-northeast-1\"\nlocationSA = \"sa-east-1\"\n\nnormaliseLocation :: LocationConstraint -> LocationConstraint\nnormaliseLocation location\n | location == \"eu-west-1\" = locationEu\n | otherwise = location\n" }, { "path": "Aws/S3.hs", "content": "module Aws.S3\n(\n module Aws.S3.Commands\n, module Aws.S3.Core\n)\nwhere\n\nimport Aws.S3.Commands\nimport Aws.S3.Core\n" }, { "path": "Aws/Ses/Commands/DeleteIdentity.hs", "content": "module Aws.Ses.Commands.DeleteIdentity\n ( DeleteIdentity(..)\n , DeleteIdentityResponse(..)\n ) where\n\nimport Data.Text (Text)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | Delete an email address or domain\ndata DeleteIdentity = DeleteIdentity Text\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery DeleteIdentity where\n type ServiceConfiguration DeleteIdentity = SesConfiguration\n signQuery (DeleteIdentity identity) =\n sesSignQuery [ (\"Action\", \"DeleteIdentity\")\n , (\"Identity\", T.encodeUtf8 identity)\n ]\n\n-- | The response sent back by Amazon SES after a\n-- 'DeleteIdentity' command.\ndata DeleteIdentityResponse = DeleteIdentityResponse\n deriving (Eq, Ord, Show, Typeable)\n\n\ninstance ResponseConsumer DeleteIdentity DeleteIdentityResponse where\n type ResponseMetadata DeleteIdentityResponse = SesMetadata\n responseConsumer _ _\n = sesResponseConsumer $ \\_ -> return DeleteIdentityResponse\n\n\ninstance Transaction DeleteIdentity DeleteIdentityResponse where\n\ninstance AsMemoryResponse DeleteIdentityResponse where\n type MemoryResponse DeleteIdentityResponse = DeleteIdentityResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/GetIdentityDkimAttributes.hs", "content": "module Aws.Ses.Commands.GetIdentityDkimAttributes\n ( GetIdentityDkimAttributes(..)\n , GetIdentityDkimAttributesResponse(..)\n , IdentityDkimAttributes(..)\n ) where\n\nimport qualified Data.ByteString.Char8 as BS\nimport Data.Text (Text)\nimport Data.Text as T (toCaseFold)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Text.XML.Cursor (laxElement, ($/), ($//), (&/), (&|))\nimport Control.Applicative\nimport Prelude\n\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | Get notification settings for the given identities.\ndata GetIdentityDkimAttributes = GetIdentityDkimAttributes [Text]\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery GetIdentityDkimAttributes where\n type ServiceConfiguration GetIdentityDkimAttributes = SesConfiguration\n signQuery (GetIdentityDkimAttributes identities) =\n sesSignQuery $ (\"Action\", \"GetIdentityDkimAttributes\")\n : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities)\n where enumMember (n :: Int) = BS.append \"Identities.member.\" (BS.pack $ show n)\n\n\ndata IdentityDkimAttributes =\n IdentityDkimAttributes\n { idIdentity :: Text\n , idDkimEnabled :: Bool\n , idDkimTokens :: [Text]\n , idDkimVerirficationStatus :: Text }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | The response sent back by Amazon SES after a\n-- 'GetIdentityDkimAttributes' command.\ndata GetIdentityDkimAttributesResponse =\n GetIdentityDkimAttributesResponse [IdentityDkimAttributes]\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where\n type ResponseMetadata GetIdentityDkimAttributesResponse = SesMetadata\n responseConsumer _ _ = sesResponseConsumer $ \\cursor -> do\n let buildAttr e = do\n idIdentity <- force \"Missing Key\" $ e $/ elContent \"key\"\n enabled <- force \"Missing DkimEnabled\" $ e $// elContent \"DkimEnabled\"\n idDkimVerirficationStatus <- force \"Missing status\" $\n e $// elContent \"DkimVerificationStatus\"\n let idDkimEnabled = T.toCaseFold enabled == T.toCaseFold \"true\"\n idDkimTokens = e $// laxElement \"DkimTokens\" &/ elContent \"member\"\n return IdentityDkimAttributes{..}\n attributes <- sequence $ cursor $// laxElement \"entry\" &| buildAttr\n return $ GetIdentityDkimAttributesResponse attributes\n\ninstance Transaction GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where\n\ninstance AsMemoryResponse GetIdentityDkimAttributesResponse where\n type MemoryResponse GetIdentityDkimAttributesResponse = GetIdentityDkimAttributesResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/GetIdentityNotificationAttributes.hs", "content": "module Aws.Ses.Commands.GetIdentityNotificationAttributes\n ( GetIdentityNotificationAttributes(..)\n , GetIdentityNotificationAttributesResponse(..)\n , IdentityNotificationAttributes(..)\n ) where\n\nimport Data.Text (Text)\nimport qualified Data.ByteString.Char8 as BS\nimport Control.Applicative\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Text as T (toCaseFold)\nimport Data.Typeable\nimport Text.XML.Cursor (($//), ($/), (&|), laxElement)\nimport Prelude\n\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | Get notification settings for the given identities.\ndata GetIdentityNotificationAttributes = GetIdentityNotificationAttributes [Text]\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery GetIdentityNotificationAttributes where\n type ServiceConfiguration GetIdentityNotificationAttributes = SesConfiguration\n signQuery (GetIdentityNotificationAttributes identities) =\n sesSignQuery $ (\"Action\", \"GetIdentityNotificationAttributes\")\n : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities)\n where enumMember (n :: Int) = BS.append \"Identities.member.\" (BS.pack $ show n)\n\ndata IdentityNotificationAttributes = IdentityNotificationAttributes\n { inIdentity :: Text\n , inBounceTopic :: Maybe Text\n , inComplaintTopic :: Maybe Text\n , inForwardingEnabled :: Bool\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | The response sent back by Amazon SES after a\n-- 'GetIdentityNotificationAttributes' command.\ndata GetIdentityNotificationAttributesResponse =\n GetIdentityNotificationAttributesResponse [IdentityNotificationAttributes]\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where\n type ResponseMetadata GetIdentityNotificationAttributesResponse = SesMetadata\n responseConsumer _ _ = sesResponseConsumer $ \\cursor -> do\n let buildAttr e = do\n inIdentity <- force \"Missing Key\" $ e $/ elContent \"key\"\n fwdText <- force \"Missing ForwardingEnabled\" $ e $// elContent \"ForwardingEnabled\"\n let inBounceTopic = headOrNothing (e $// elContent \"BounceTopic\")\n inComplaintTopic = headOrNothing (e $// elContent \"ComplaintTopic\")\n inForwardingEnabled = T.toCaseFold fwdText == T.toCaseFold \"true\"\n return IdentityNotificationAttributes{..}\n attributes <- sequence $ cursor $// laxElement \"entry\" &| buildAttr\n return $ GetIdentityNotificationAttributesResponse attributes\n where\n headOrNothing (x:_) = Just x\n headOrNothing _ = Nothing\n\ninstance Transaction GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where\n\ninstance AsMemoryResponse GetIdentityNotificationAttributesResponse where\n type MemoryResponse GetIdentityNotificationAttributesResponse = GetIdentityNotificationAttributesResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/GetIdentityVerificationAttributes.hs", "content": "module Aws.Ses.Commands.GetIdentityVerificationAttributes\n ( GetIdentityVerificationAttributes(..)\n , GetIdentityVerificationAttributesResponse(..)\n , IdentityVerificationAttributes(..)\n ) where\n\nimport Data.Text (Text)\nimport qualified Data.ByteString.Char8 as BS\nimport Data.Maybe (listToMaybe)\nimport Control.Applicative\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Text.XML.Cursor (($//), ($/), (&|), laxElement)\nimport Prelude\n\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | Get verification status for a list of email addresses and/or domains\ndata GetIdentityVerificationAttributes = GetIdentityVerificationAttributes [Text]\n deriving (Eq, Ord, Show, Typeable)\n\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery GetIdentityVerificationAttributes where\n type ServiceConfiguration GetIdentityVerificationAttributes = SesConfiguration\n signQuery (GetIdentityVerificationAttributes identities) =\n sesSignQuery $ (\"Action\", \"GetIdentityVerificationAttributes\")\n : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities)\n where enumMember (n :: Int) = BS.append \"Identities.member.\" (BS.pack $ show n)\n\ndata IdentityVerificationAttributes = IdentityVerificationAttributes\n { ivIdentity :: Text\n , ivVerificationStatus :: Text\n , ivVerificationToken :: Maybe Text\n }\n deriving (Eq, Ord, Show, Typeable)\n\n\n-- | The response sent back by Amazon SES after a\n-- 'GetIdentityVerificationAttributes' command.\ndata GetIdentityVerificationAttributesResponse =\n GetIdentityVerificationAttributesResponse [IdentityVerificationAttributes]\n deriving (Eq, Ord, Show, Typeable)\n\n\ninstance ResponseConsumer GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where\n type ResponseMetadata GetIdentityVerificationAttributesResponse = SesMetadata\n responseConsumer _ _ =\n sesResponseConsumer $ \\cursor -> do\n let buildAttr e = do\n ivIdentity <- force \"Missing Key\" $ e $/ elContent \"key\"\n ivVerificationStatus <- force \"Missing Verification Status\" $ e\n $// elContent \"VerificationStatus\"\n let ivVerificationToken = listToMaybe $ e $// elContent \"VerificationToken\"\n return IdentityVerificationAttributes {..}\n attributes <- sequence $ cursor $// laxElement \"entry\" &| buildAttr\n return $ GetIdentityVerificationAttributesResponse attributes\n\n\ninstance Transaction GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where\n\ninstance AsMemoryResponse GetIdentityVerificationAttributesResponse where\n type MemoryResponse GetIdentityVerificationAttributesResponse = GetIdentityVerificationAttributesResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/ListIdentities.hs", "content": "module Aws.Ses.Commands.ListIdentities\n ( ListIdentities(..)\n , ListIdentitiesResponse(..)\n , IdentityType(..)\n ) where\n\nimport Data.Text (Text)\nimport qualified Data.ByteString.Char8 as BS\nimport Data.Maybe (catMaybes)\nimport Control.Applicative\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Text.XML.Cursor (($//), (&/), laxElement)\nimport Prelude\n\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | List email addresses and/or domains\ndata ListIdentities =\n ListIdentities\n { liIdentityType :: Maybe IdentityType\n , liMaxItems :: Maybe Int -- valid range is 1..100\n , liNextToken :: Maybe Text\n }\n deriving (Eq, Ord, Show, Typeable)\n\ndata IdentityType = EmailAddress | Domain\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery ListIdentities where\n type ServiceConfiguration ListIdentities = SesConfiguration\n signQuery ListIdentities {..} =\n let it = case liIdentityType of\n Just EmailAddress -> Just \"EmailAddress\"\n Just Domain -> Just \"Domain\"\n Nothing -> Nothing\n in sesSignQuery $ (\"Action\", \"ListIdentities\")\n : catMaybes\n [ (\"IdentityType\",) <$> it\n , (\"MaxItems\",) . BS.pack . show <$> liMaxItems\n , (\"NextToken\",) . T.encodeUtf8 <$> liNextToken\n ]\n\n-- | The response sent back by Amazon SES after a\n-- 'ListIdentities' command.\ndata ListIdentitiesResponse = ListIdentitiesResponse [Text]\n deriving (Eq, Ord, Show, Typeable)\n\n\ninstance ResponseConsumer ListIdentities ListIdentitiesResponse where\n type ResponseMetadata ListIdentitiesResponse = SesMetadata\n responseConsumer _ _ =\n sesResponseConsumer $ \\cursor -> do\n let ids = cursor $// laxElement \"Identities\" &/ elContent \"member\"\n return $ ListIdentitiesResponse ids\n\n\ninstance Transaction ListIdentities ListIdentitiesResponse where\n\ninstance AsMemoryResponse ListIdentitiesResponse where\n type MemoryResponse ListIdentitiesResponse = ListIdentitiesResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/SendRawEmail.hs", "content": "module Aws.Ses.Commands.SendRawEmail\n ( SendRawEmail(..)\n , SendRawEmailResponse(..)\n ) where\n\nimport Data.Text (Text)\nimport Data.Typeable\nimport Control.Applicative\nimport qualified Data.ByteString.Char8 as BS\nimport Text.XML.Cursor (($//))\nimport qualified Data.Text.Encoding as T\nimport Prelude\n\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | Send a raw e-mail message.\ndata SendRawEmail =\n SendRawEmail\n { srmDestinations :: [EmailAddress]\n , srmRawMessage :: RawMessage\n , srmSource :: Maybe Sender\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery SendRawEmail where\n type ServiceConfiguration SendRawEmail = SesConfiguration\n signQuery SendRawEmail {..} =\n sesSignQuery $ (\"Action\", \"SendRawEmail\") :\n concat [ destinations\n , sesAsQuery srmRawMessage\n , sesAsQuery srmSource\n ]\n where\n destinations = zip (enumMember <$> ([1..] :: [Int]))\n (T.encodeUtf8 <$> srmDestinations)\n enumMember = BS.append \"Destinations.member.\" . BS.pack . show\n\n-- | The response sent back by Amazon SES after a\n-- 'SendRawEmail' command.\ndata SendRawEmailResponse =\n SendRawEmailResponse { srmrMessageId :: Text }\n deriving (Eq, Ord, Show, Typeable)\n\n\ninstance ResponseConsumer SendRawEmail SendRawEmailResponse where\n type ResponseMetadata SendRawEmailResponse = SesMetadata\n responseConsumer _ _ =\n sesResponseConsumer $ \\cursor -> do\n messageId <- force \"MessageId not found\" $ cursor $// elContent \"MessageId\"\n return (SendRawEmailResponse messageId)\n\n\ninstance Transaction SendRawEmail SendRawEmailResponse where\n\ninstance AsMemoryResponse SendRawEmailResponse where\n type MemoryResponse SendRawEmailResponse = SendRawEmailResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/SetIdentityDkimEnabled.hs", "content": "module Aws.Ses.Commands.SetIdentityDkimEnabled\n ( SetIdentityDkimEnabled(..)\n , SetIdentityDkimEnabledResponse(..)\n ) where\n\nimport Aws.Core\nimport Aws.Ses.Core\nimport Data.Text (Text)\nimport Data.Text.Encoding as T\nimport Data.Typeable\n\n-- | Change whether bounces and complaints for the given identity will be\n-- DKIM signed.\ndata SetIdentityDkimEnabled = SetIdentityDkimEnabled\n { sdDkimEnabled :: Bool\n , sdIdentity :: Text\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery SetIdentityDkimEnabled where\n type ServiceConfiguration SetIdentityDkimEnabled = SesConfiguration\n signQuery SetIdentityDkimEnabled{..} =\n sesSignQuery [ (\"Action\", \"SetIdentityDkimEnabled\")\n , (\"Identity\", T.encodeUtf8 sdIdentity)\n , (\"DkimEnabled\", awsBool sdDkimEnabled)\n ]\n\n-- | The response sent back by SES after the 'SetIdentityDkimEnabled' command.\ndata SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer SetIdentityDkimEnabled SetIdentityDkimEnabledResponse where\n type ResponseMetadata SetIdentityDkimEnabledResponse = SesMetadata\n responseConsumer _ _\n = sesResponseConsumer $ \\_ -> return SetIdentityDkimEnabledResponse\n\ninstance Transaction SetIdentityDkimEnabled SetIdentityDkimEnabledResponse\n\ninstance AsMemoryResponse SetIdentityDkimEnabledResponse where\n type MemoryResponse SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs", "content": "module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled\n ( SetIdentityFeedbackForwardingEnabled(..)\n , SetIdentityFeedbackForwardingEnabledResponse(..)\n ) where\n\nimport Data.Text (Text)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | Change whether bounces and complaints for the given identity will be\n-- forwarded as email.\ndata SetIdentityFeedbackForwardingEnabled =\n SetIdentityFeedbackForwardingEnabled\n { sffForwardingEnabled :: Bool\n , sffIdentity :: Text\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery SetIdentityFeedbackForwardingEnabled where\n type ServiceConfiguration SetIdentityFeedbackForwardingEnabled = SesConfiguration\n signQuery SetIdentityFeedbackForwardingEnabled{..} =\n sesSignQuery [ (\"Action\", \"SetIdentityFeedbackForwardingEnabled\")\n , (\"Identity\", T.encodeUtf8 sffIdentity)\n , (\"ForwardingEnabled\", awsBool sffForwardingEnabled)\n ]\n\n-- | The response sent back by SES after the\n-- 'SetIdentityFeedbackForwardingEnabled' command.\ndata SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse where\n type ResponseMetadata SetIdentityFeedbackForwardingEnabledResponse = SesMetadata\n responseConsumer _ _\n = sesResponseConsumer $ \\_ -> return SetIdentityFeedbackForwardingEnabledResponse\n\ninstance Transaction SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse\n\ninstance AsMemoryResponse SetIdentityFeedbackForwardingEnabledResponse where\n type MemoryResponse SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/SetIdentityNotificationTopic.hs", "content": "module Aws.Ses.Commands.SetIdentityNotificationTopic\n ( SetIdentityNotificationTopic(..)\n , SetIdentityNotificationTopicResponse(..)\n , NotificationType(..)\n ) where\n\nimport Data.Text (Text)\nimport Control.Applicative\nimport Data.Maybe (maybeToList)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Prelude\nimport Aws.Core\nimport Aws.Ses.Core\n\ndata NotificationType = Bounce | Complaint\n deriving (Eq, Ord, Show, Typeable)\n\n-- | Change or remove the Amazon SNS notification topic to which notification\n-- of the given type are published.\ndata SetIdentityNotificationTopic =\n SetIdentityNotificationTopic\n { sntIdentity :: Text\n -- ^ The identity for which the SNS topic will be changed.\n , sntNotificationType :: NotificationType\n -- ^ The type of notifications that will be published to the topic.\n , sntSnsTopic :: Maybe Text\n -- ^ @Just@ the ARN of the SNS topic or @Nothing@ to unset the topic.\n }\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery SetIdentityNotificationTopic where\n type ServiceConfiguration SetIdentityNotificationTopic = SesConfiguration\n signQuery SetIdentityNotificationTopic{..} =\n let notificationType = case sntNotificationType of\n Bounce -> \"Bounce\"\n Complaint -> \"Complaint\"\n snsTopic = (\"SnsTopic\",) . T.encodeUtf8 <$> sntSnsTopic\n in sesSignQuery $ [ (\"Action\", \"SetIdentityNotificationTopic\")\n , (\"Identity\", T.encodeUtf8 sntIdentity)\n , (\"NotificationType\", notificationType)\n ] ++ maybeToList snsTopic\n\n-- | The response sent back by SES after the 'SetIdentityNotificationTopic'\n-- command.\ndata SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer SetIdentityNotificationTopic SetIdentityNotificationTopicResponse where\n type ResponseMetadata SetIdentityNotificationTopicResponse = SesMetadata\n responseConsumer _ _\n = sesResponseConsumer $ \\_ -> return SetIdentityNotificationTopicResponse\n\ninstance Transaction SetIdentityNotificationTopic SetIdentityNotificationTopicResponse\n\ninstance AsMemoryResponse SetIdentityNotificationTopicResponse where\n type MemoryResponse SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/VerifyDomainDkim.hs", "content": "module Aws.Ses.Commands.VerifyDomainDkim\n ( VerifyDomainDkim(..)\n , VerifyDomainDkimResponse(..)\n ) where\n\nimport Data.Text (Text)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Aws.Core\nimport Aws.Ses.Core\nimport Text.XML.Cursor (($//), laxElement, (&/))\n\n-- | Verify ownership of a domain.\ndata VerifyDomainDkim = VerifyDomainDkim Text\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery VerifyDomainDkim where\n type ServiceConfiguration VerifyDomainDkim = SesConfiguration\n signQuery (VerifyDomainDkim domain) =\n sesSignQuery [ (\"Action\", \"VerifyDomainDkim\")\n , (\"Domain\", T.encodeUtf8 domain)\n ]\n\n-- | The response sent back by Amazon SES after a 'VerifyDomainDkim' command.\ndata VerifyDomainDkimResponse = VerifyDomainDkimResponse [Text]\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer VerifyDomainDkim VerifyDomainDkimResponse where\n type ResponseMetadata VerifyDomainDkimResponse = SesMetadata\n responseConsumer _ _ =\n sesResponseConsumer $ \\cursor -> do\n let tokens = cursor $// laxElement \"DkimTokens\" &/ elContent \"member\"\n return (VerifyDomainDkimResponse tokens)\n\ninstance Transaction VerifyDomainDkim VerifyDomainDkimResponse where\n\ninstance AsMemoryResponse VerifyDomainDkimResponse where\n type MemoryResponse VerifyDomainDkimResponse = VerifyDomainDkimResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/VerifyDomainIdentity.hs", "content": "module Aws.Ses.Commands.VerifyDomainIdentity\n ( VerifyDomainIdentity(..)\n , VerifyDomainIdentityResponse(..)\n ) where\n\nimport Data.Text (Text)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Aws.Core\nimport Aws.Ses.Core\nimport Text.XML.Cursor (($//))\n\n-- | Verify ownership of a domain.\ndata VerifyDomainIdentity = VerifyDomainIdentity Text\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery VerifyDomainIdentity where\n type ServiceConfiguration VerifyDomainIdentity = SesConfiguration\n signQuery (VerifyDomainIdentity domain) =\n sesSignQuery [ (\"Action\", \"VerifyDomainIdentity\")\n , (\"Domain\", T.encodeUtf8 domain)\n ]\n\n-- | The response sent back by Amazon SES after a\n-- 'VerifyDomainIdentity' command.\ndata VerifyDomainIdentityResponse = VerifyDomainIdentityResponse Text\n deriving (Eq, Ord, Show, Typeable)\n\ninstance ResponseConsumer VerifyDomainIdentity VerifyDomainIdentityResponse where\n type ResponseMetadata VerifyDomainIdentityResponse = SesMetadata\n responseConsumer _ _ =\n sesResponseConsumer $ \\cursor -> do\n token <- force \"Verification token not found\" $ cursor $// elContent \"VerificationToken\"\n return (VerifyDomainIdentityResponse token)\n\ninstance Transaction VerifyDomainIdentity VerifyDomainIdentityResponse where\n\ninstance AsMemoryResponse VerifyDomainIdentityResponse where\n type MemoryResponse VerifyDomainIdentityResponse = VerifyDomainIdentityResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands/VerifyEmailIdentity.hs", "content": "module Aws.Ses.Commands.VerifyEmailIdentity\n ( VerifyEmailIdentity(..)\n , VerifyEmailIdentityResponse(..)\n ) where\n\nimport Data.Text (Text)\nimport Data.Text.Encoding as T (encodeUtf8)\nimport Data.Typeable\nimport Aws.Core\nimport Aws.Ses.Core\n\n-- | List email addresses and/or domains\ndata VerifyEmailIdentity = VerifyEmailIdentity Text\n deriving (Eq, Ord, Show, Typeable)\n\n-- | ServiceConfiguration: 'SesConfiguration'\ninstance SignQuery VerifyEmailIdentity where\n type ServiceConfiguration VerifyEmailIdentity = SesConfiguration\n signQuery (VerifyEmailIdentity address) =\n sesSignQuery [ (\"Action\", \"VerifyEmailIdentity\")\n , (\"EmailAddress\", T.encodeUtf8 address)\n ]\n\n-- | The response sent back by Amazon SES after a\n-- 'VerifyEmailIdentity' command.\ndata VerifyEmailIdentityResponse = VerifyEmailIdentityResponse\n deriving (Eq, Ord, Show, Typeable)\n\n\ninstance ResponseConsumer VerifyEmailIdentity VerifyEmailIdentityResponse where\n type ResponseMetadata VerifyEmailIdentityResponse = SesMetadata\n responseConsumer _ _\n = sesResponseConsumer $ \\_ -> return VerifyEmailIdentityResponse\n\n\ninstance Transaction VerifyEmailIdentity VerifyEmailIdentityResponse where\n\ninstance AsMemoryResponse VerifyEmailIdentityResponse where\n type MemoryResponse VerifyEmailIdentityResponse = VerifyEmailIdentityResponse\n loadToMemory = return\n" }, { "path": "Aws/Ses/Commands.hs", "content": "module Aws.Ses.Commands\n ( module Aws.Ses.Commands.SendRawEmail\n , module Aws.Ses.Commands.ListIdentities\n , module Aws.Ses.Commands.VerifyEmailIdentity\n , module Aws.Ses.Commands.VerifyDomainIdentity\n , module Aws.Ses.Commands.VerifyDomainDkim\n , module Aws.Ses.Commands.DeleteIdentity\n , module Aws.Ses.Commands.GetIdentityDkimAttributes\n , module Aws.Ses.Commands.GetIdentityNotificationAttributes\n , module Aws.Ses.Commands.GetIdentityVerificationAttributes\n , module Aws.Ses.Commands.SetIdentityNotificationTopic\n , module Aws.Ses.Commands.SetIdentityDkimEnabled\n , module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled\n ) where\n\nimport Aws.Ses.Commands.SendRawEmail\nimport Aws.Ses.Commands.ListIdentities\nimport Aws.Ses.Commands.VerifyEmailIdentity\nimport Aws.Ses.Commands.VerifyDomainIdentity\nimport Aws.Ses.Commands.VerifyDomainDkim\nimport Aws.Ses.Commands.DeleteIdentity\nimport Aws.Ses.Commands.GetIdentityDkimAttributes\nimport Aws.Ses.Commands.GetIdentityNotificationAttributes\nimport Aws.Ses.Commands.GetIdentityVerificationAttributes\nimport Aws.Ses.Commands.SetIdentityNotificationTopic\nimport Aws.Ses.Commands.SetIdentityDkimEnabled\nimport Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled\n" }, { "path": "Aws/Ses/Core.hs", "content": "module Aws.Ses.Core\n ( SesError(..)\n , SesMetadata(..)\n\n , SesConfiguration(..)\n , sesEuWest1\n , sesUsEast\n , sesUsEast1\n , sesUsWest2\n , sesHttpsGet\n , sesHttpsPost\n\n , sesSignQuery\n\n , sesResponseConsumer\n\n , RawMessage(..)\n , Destination(..)\n , EmailAddress\n , Sender(..)\n , sesAsQuery\n ) where\n\nimport Aws.Core\nimport qualified Blaze.ByteString.Builder as Blaze\nimport qualified Blaze.ByteString.Builder.Char8 as Blaze8\nimport qualified Control.Exception as C\nimport Control.Monad (mplus)\nimport Control.Monad.Trans.Resource (throwM)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Base64 as B64\nimport Data.ByteString.Char8 ({-IsString-})\nimport Data.IORef\nimport Data.Maybe\nimport Data.Monoid\nimport qualified Data.Semigroup as Sem\nimport Data.Text (Text)\nimport qualified Data.Text.Encoding as TE\nimport Data.Typeable\nimport Prelude\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport Text.XML.Cursor (($/), ($//))\nimport qualified Text.XML.Cursor as Cu\n\ndata SesError\n = SesError {\n sesStatusCode :: HTTP.Status\n , sesErrorCode :: Text\n , sesErrorMessage :: Text\n }\n deriving (Show, Typeable)\n\ninstance C.Exception SesError\n\ndata SesMetadata\n = SesMetadata {\n requestId :: Maybe Text\n }\n deriving (Show, Typeable)\n\ninstance Loggable SesMetadata where\n toLogText (SesMetadata rid) = \"SES: request ID=\" `mappend` fromMaybe \"\" rid\n\ninstance Sem.Semigroup SesMetadata where\n SesMetadata r1 <> SesMetadata r2 = SesMetadata (r1 `mplus` r2)\n\ninstance Monoid SesMetadata where\n mempty = SesMetadata Nothing\n mappend = (Sem.<>)\n\ndata SesConfiguration qt\n = SesConfiguration {\n sesiHttpMethod :: Method\n , sesiHost :: B.ByteString\n }\n deriving (Show)\n\n-- HTTP is not supported right now, always use HTTPS\ninstance DefaultServiceConfiguration (SesConfiguration NormalQuery) where\n defServiceConfig = sesHttpsPost sesUsEast1\n\ninstance DefaultServiceConfiguration (SesConfiguration UriOnlyQuery) where\n defServiceConfig = sesHttpsGet sesUsEast1\n\nsesEuWest1 :: B.ByteString\nsesEuWest1 = \"email.eu-west-1.amazonaws.com\"\n\nsesUsEast :: B.ByteString\nsesUsEast = sesUsEast1\n\nsesUsEast1 :: B.ByteString\nsesUsEast1 = \"email.us-east-1.amazonaws.com\"\n\nsesUsWest2 :: B.ByteString\nsesUsWest2 = \"email.us-west-2.amazonaws.com\"\n\nsesHttpsGet :: B.ByteString -> SesConfiguration qt\nsesHttpsGet endpoint = SesConfiguration Get endpoint\n\nsesHttpsPost :: B.ByteString -> SesConfiguration NormalQuery\nsesHttpsPost endpoint = SesConfiguration PostQuery endpoint\n\nsesSignQuery :: [(B.ByteString, B.ByteString)] -> SesConfiguration qt -> SignatureData -> SignedQuery\nsesSignQuery query si sd\n = SignedQuery {\n sqMethod = sesiHttpMethod si\n , sqProtocol = HTTPS\n , sqHost = sesiHost si\n , sqPort = defaultPort HTTPS\n , sqPath = \"/\"\n , sqQuery = HTTP.simpleQueryToQuery query'\n , sqDate = Just $ signatureTime sd\n , sqAuthorization = Nothing\n , sqContentType = Nothing\n , sqContentMd5 = Nothing\n , sqAmzHeaders = amzHeaders\n , sqOtherHeaders = []\n , sqBody = Nothing\n , sqStringToSign = stringToSign\n }\n where\n stringToSign = fmtRfc822Time (signatureTime sd)\n credentials = signatureCredentials sd\n accessKeyId = accessKeyID credentials\n amzHeaders = catMaybes\n [ Just (\"X-Amzn-Authorization\", authorization)\n , (\"x-amz-security-token\",) `fmap` iamToken credentials\n ]\n authorization = B.concat\n [ \"AWS3-HTTPS AWSAccessKeyId=\"\n , accessKeyId\n , \", Algorithm=HmacSHA256, Signature=\"\n , signature credentials HmacSHA256 stringToSign\n ]\n query' = (\"AWSAccessKeyId\", accessKeyId) : query\n\nsesResponseConsumer :: (Cu.Cursor -> Response SesMetadata a)\n -> IORef SesMetadata\n -> HTTPResponseConsumer a\nsesResponseConsumer inner metadataRef resp = xmlCursorConsumer parse metadataRef resp\n where\n parse cursor = do\n let requestId' = listToMaybe $ cursor $// elContent \"RequestID\"\n tellMetadata $ SesMetadata requestId'\n case cursor $/ Cu.laxElement \"Error\" of\n [] -> inner cursor\n (err:_) -> fromError err\n\n fromError cursor = do\n errCode <- force \"Missing Error Code\" $ cursor $// elContent \"Code\"\n errMessage <- force \"Missing Error Message\" $ cursor $// elContent \"Message\"\n throwM $ SesError (HTTP.responseStatus resp) errCode errMessage\n\nclass SesAsQuery a where\n -- | Write a data type as a list of query parameters.\n sesAsQuery :: a -> [(B.ByteString, B.ByteString)]\n\ninstance SesAsQuery a => SesAsQuery (Maybe a) where\n sesAsQuery = maybe [] sesAsQuery\n\n\n-- | A raw e-mail.\ndata RawMessage = RawMessage { rawMessageData :: B.ByteString }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SesAsQuery RawMessage where\n sesAsQuery = (:[]) . (,) \"RawMessage.Data\" . B64.encode . rawMessageData\n\n\n-- | The destinations of an e-mail.\ndata Destination =\n Destination\n { destinationBccAddresses :: [EmailAddress]\n , destinationCcAddresses :: [EmailAddress]\n , destinationToAddresses :: [EmailAddress]\n } deriving (Eq, Ord, Show, Typeable)\n\ninstance SesAsQuery Destination where\n sesAsQuery (Destination bcc cc to) = concat [ go (s \"Bcc\") bcc\n , go (s \"Cc\") cc\n , go (s \"To\") to ]\n where\n go kind = zipWith f (map Blaze8.fromShow [one..])\n where txt = kind `mappend` s \"Addresses.member.\"\n f n v = ( Blaze.toByteString (txt `mappend` n)\n , TE.encodeUtf8 v )\n s = Blaze.fromByteString\n one = 1 :: Int\n\ninstance Sem.Semigroup Destination where\n (Destination a1 a2 a3) <> (Destination b1 b2 b3) =\n Destination (a1 ++ b1) (a2 ++ b2) (a3 ++ b3)\n\ninstance Monoid Destination where\n mempty = Destination [] [] []\n mappend = (Sem.<>)\n\n-- | An e-mail address.\ntype EmailAddress = Text\n\n\n-- | The sender's e-mail address.\ndata Sender = Sender { senderAddress :: EmailAddress }\n deriving (Eq, Ord, Show, Typeable)\n\ninstance SesAsQuery Sender where\n sesAsQuery = (:[]) . (,) \"Source\" . TE.encodeUtf8 . senderAddress\n" }, { "path": "Aws/Ses.hs", "content": "module Aws.Ses\n ( module Aws.Ses.Commands\n , module Aws.Ses.Core\n ) where\n\nimport Aws.Ses.Commands\nimport Aws.Ses.Core\n" }, { "path": "Aws/SimpleDb/Commands/Attributes.hs", "content": "module Aws.SimpleDb.Commands.Attributes where\n\nimport Aws.Core\nimport Aws.SimpleDb.Core\nimport Control.Applicative\nimport Control.Monad\nimport Data.Maybe\nimport Prelude\nimport Text.XML.Cursor (($//), (&|))\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Text.XML.Cursor as Cu\n\ndata GetAttributes\n = GetAttributes {\n gaItemName :: T.Text\n , gaAttributeName :: Maybe T.Text\n , gaConsistentRead :: Bool\n , gaDomainName :: T.Text\n }\n deriving (Show)\n\ndata GetAttributesResponse\n = GetAttributesResponse {\n garAttributes :: [Attribute T.Text]\n }\n deriving (Show)\n\ngetAttributes :: T.Text -> T.Text -> GetAttributes\ngetAttributes item domain = GetAttributes { gaItemName = item, gaAttributeName = Nothing, gaConsistentRead = False, gaDomainName = domain }\n\n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery GetAttributes where\n type ServiceConfiguration GetAttributes = SdbConfiguration\n signQuery GetAttributes{..}\n = sdbSignQuery $\n [(\"Action\", \"GetAttributes\"), (\"ItemName\", T.encodeUtf8 gaItemName), (\"DomainName\", T.encodeUtf8 gaDomainName)] ++\n maybeToList ((\"AttributeName\",) <$> T.encodeUtf8 <$> gaAttributeName) ++\n (guard gaConsistentRead >> [(\"ConsistentRead\", awsTrue)])\n\ninstance ResponseConsumer r GetAttributesResponse where\n type ResponseMetadata GetAttributesResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer parse\n where parse cursor = do\n sdbCheckResponseType () \"GetAttributesResponse\" cursor\n attributes <- sequence $ cursor $// Cu.laxElement \"Attribute\" &| readAttribute\n return $ GetAttributesResponse attributes\n\ninstance Transaction GetAttributes GetAttributesResponse\n\ninstance AsMemoryResponse GetAttributesResponse where\n type MemoryResponse GetAttributesResponse = GetAttributesResponse\n loadToMemory = return\n\ndata PutAttributes\n = PutAttributes {\n paItemName :: T.Text\n , paAttributes :: [Attribute SetAttribute]\n , paExpected :: [Attribute ExpectedAttribute]\n , paDomainName :: T.Text\n }\n deriving (Show)\n\ndata PutAttributesResponse\n = PutAttributesResponse\n deriving (Show)\n \nputAttributes :: T.Text -> [Attribute SetAttribute] -> T.Text -> PutAttributes\nputAttributes item attributes domain = PutAttributes { \n paItemName = item\n , paAttributes = attributes\n , paExpected = []\n , paDomainName = domain \n }\n \n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery PutAttributes where\n type ServiceConfiguration PutAttributes = SdbConfiguration\n signQuery PutAttributes{..}\n = sdbSignQuery $ \n [(\"Action\", \"PutAttributes\"), (\"ItemName\", T.encodeUtf8 paItemName), (\"DomainName\", T.encodeUtf8 paDomainName)] ++\n queryList (attributeQuery setAttributeQuery) \"Attribute\" paAttributes ++\n queryList (attributeQuery expectedAttributeQuery) \"Expected\" paExpected\n\ninstance ResponseConsumer r PutAttributesResponse where\n type ResponseMetadata PutAttributesResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse \"PutAttributesResponse\"\n\ninstance Transaction PutAttributes PutAttributesResponse\n\ninstance AsMemoryResponse PutAttributesResponse where\n type MemoryResponse PutAttributesResponse = PutAttributesResponse\n loadToMemory = return\n\ndata DeleteAttributes\n = DeleteAttributes {\n daItemName :: T.Text\n , daAttributes :: [Attribute DeleteAttribute]\n , daExpected :: [Attribute ExpectedAttribute]\n , daDomainName :: T.Text\n }\n deriving (Show)\n\ndata DeleteAttributesResponse\n = DeleteAttributesResponse\n deriving (Show)\n \ndeleteAttributes :: T.Text -> [Attribute DeleteAttribute] -> T.Text -> DeleteAttributes\ndeleteAttributes item attributes domain = DeleteAttributes { \n daItemName = item\n , daAttributes = attributes\n , daExpected = []\n , daDomainName = domain \n }\n \n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery DeleteAttributes where\n type ServiceConfiguration DeleteAttributes = SdbConfiguration\n signQuery DeleteAttributes{..}\n = sdbSignQuery $ \n [(\"Action\", \"DeleteAttributes\"), (\"ItemName\", T.encodeUtf8 daItemName), (\"DomainName\", T.encodeUtf8 daDomainName)] ++\n queryList (attributeQuery deleteAttributeQuery) \"Attribute\" daAttributes ++\n queryList (attributeQuery expectedAttributeQuery) \"Expected\" daExpected\n\ninstance ResponseConsumer r DeleteAttributesResponse where\n type ResponseMetadata DeleteAttributesResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse \"DeleteAttributesResponse\"\n\ninstance Transaction DeleteAttributes DeleteAttributesResponse\n\ninstance AsMemoryResponse DeleteAttributesResponse where\n type MemoryResponse DeleteAttributesResponse = DeleteAttributesResponse\n loadToMemory = return\n\ndata BatchPutAttributes\n = BatchPutAttributes {\n bpaItems :: [Item [Attribute SetAttribute]]\n , bpaDomainName :: T.Text\n }\n deriving (Show)\n\ndata BatchPutAttributesResponse\n = BatchPutAttributesResponse\n deriving (Show)\n \nbatchPutAttributes :: [Item [Attribute SetAttribute]] -> T.Text -> BatchPutAttributes\nbatchPutAttributes items domain = BatchPutAttributes { bpaItems = items, bpaDomainName = domain }\n\n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery BatchPutAttributes where\n type ServiceConfiguration BatchPutAttributes = SdbConfiguration\n signQuery BatchPutAttributes{..}\n = sdbSignQuery $ \n [(\"Action\", \"BatchPutAttributes\")\n , (\"DomainName\", T.encodeUtf8 bpaDomainName)] ++\n queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) \"Attribute\") \"Item\" bpaItems\n\ninstance ResponseConsumer r BatchPutAttributesResponse where\n type ResponseMetadata BatchPutAttributesResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse \"BatchPutAttributesResponse\"\n\ninstance Transaction BatchPutAttributes BatchPutAttributesResponse\n\ninstance AsMemoryResponse BatchPutAttributesResponse where\n type MemoryResponse BatchPutAttributesResponse = BatchPutAttributesResponse\n loadToMemory = return\n\ndata BatchDeleteAttributes\n = BatchDeleteAttributes {\n bdaItems :: [Item [Attribute DeleteAttribute]]\n , bdaDomainName :: T.Text\n }\n deriving (Show)\n\ndata BatchDeleteAttributesResponse\n = BatchDeleteAttributesResponse\n deriving (Show)\n \nbatchDeleteAttributes :: [Item [Attribute DeleteAttribute]] -> T.Text -> BatchDeleteAttributes\nbatchDeleteAttributes items domain = BatchDeleteAttributes { bdaItems = items, bdaDomainName = domain }\n\n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery BatchDeleteAttributes where\n type ServiceConfiguration BatchDeleteAttributes = SdbConfiguration\n signQuery BatchDeleteAttributes{..}\n = sdbSignQuery $ \n [(\"Action\", \"BatchDeleteAttributes\")\n , (\"DomainName\", T.encodeUtf8 bdaDomainName)] ++\n queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) \"Attribute\") \"Item\" bdaItems\n\ninstance ResponseConsumer r BatchDeleteAttributesResponse where\n type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse \"BatchDeleteAttributesResponse\"\n\ninstance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse\n\ninstance AsMemoryResponse BatchDeleteAttributesResponse where\n type MemoryResponse BatchDeleteAttributesResponse = BatchDeleteAttributesResponse\n loadToMemory = return\n" }, { "path": "Aws/SimpleDb/Commands/Domain.hs", "content": "module Aws.SimpleDb.Commands.Domain where\n\nimport Aws.Core\nimport Aws.SimpleDb.Core\nimport Control.Applicative\nimport Data.Maybe\nimport Data.Time\nimport Data.Time.Clock.POSIX\nimport Prelude\nimport Text.XML.Cursor (($//), (&|))\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\n\ndata CreateDomain\n = CreateDomain {\n cdDomainName :: T.Text\n }\n deriving (Show)\n\ndata CreateDomainResponse \n = CreateDomainResponse\n deriving (Show)\n \ncreateDomain :: T.Text -> CreateDomain\ncreateDomain name = CreateDomain { cdDomainName = name }\n \n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery CreateDomain where\n type ServiceConfiguration CreateDomain = SdbConfiguration\n signQuery CreateDomain{..} = sdbSignQuery [(\"Action\", \"CreateDomain\"), (\"DomainName\", T.encodeUtf8 cdDomainName)]\n\ninstance ResponseConsumer r CreateDomainResponse where\n type ResponseMetadata CreateDomainResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse \"CreateDomainResponse\"\n\ninstance Transaction CreateDomain CreateDomainResponse\n\ninstance AsMemoryResponse CreateDomainResponse where\n type MemoryResponse CreateDomainResponse = CreateDomainResponse\n loadToMemory = return\n\ndata DeleteDomain\n = DeleteDomain {\n ddDomainName :: T.Text\n }\n deriving (Show)\n\ndata DeleteDomainResponse\n = DeleteDomainResponse\n deriving (Show)\n \ndeleteDomain :: T.Text -> DeleteDomain\ndeleteDomain name = DeleteDomain { ddDomainName = name }\n \n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery DeleteDomain where\n type ServiceConfiguration DeleteDomain = SdbConfiguration\n signQuery DeleteDomain{..} = sdbSignQuery [(\"Action\", \"DeleteDomain\"), (\"DomainName\", T.encodeUtf8 ddDomainName)]\n\ninstance ResponseConsumer r DeleteDomainResponse where\n type ResponseMetadata DeleteDomainResponse = SdbMetadata\n responseConsumer _ _\n = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse \"DeleteDomainResponse\"\n\ninstance Transaction DeleteDomain DeleteDomainResponse\n\ninstance AsMemoryResponse DeleteDomainResponse where\n type MemoryResponse DeleteDomainResponse = DeleteDomainResponse\n loadToMemory = return\n\ndata DomainMetadata\n = DomainMetadata {\n dmDomainName :: T.Text\n }\n deriving (Show)\n\ndata DomainMetadataResponse\n = DomainMetadataResponse {\n dmrTimestamp :: UTCTime\n , dmrItemCount :: Integer\n , dmrAttributeValueCount :: Integer\n , dmrAttributeNameCount :: Integer\n , dmrItemNamesSizeBytes :: Integer\n , dmrAttributeValuesSizeBytes :: Integer\n , dmrAttributeNamesSizeBytes :: Integer\n }\n deriving (Show)\n\ndomainMetadata :: T.Text -> DomainMetadata\ndomainMetadata name = DomainMetadata { dmDomainName = name }\n\n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery DomainMetadata where\n type ServiceConfiguration DomainMetadata = SdbConfiguration\n signQuery DomainMetadata{..} = sdbSignQuery [(\"Action\", \"DomainMetadata\"), (\"DomainName\", T.encodeUtf8 dmDomainName)]\n\ninstance ResponseConsumer r DomainMetadataResponse where\n type ResponseMetadata DomainMetadataResponse = SdbMetadata\n\n responseConsumer _ _\n = sdbResponseConsumer parse\n where parse cursor = do\n sdbCheckResponseType () \"DomainMetadataResponse\" cursor\n dmrTimestamp <- forceM \"Timestamp expected\" $ cursor $// elCont \"Timestamp\" &| (fmap posixSecondsToUTCTime . readInt)\n dmrItemCount <- forceM \"ItemCount expected\" $ cursor $// elCont \"ItemCount\" &| readInt\n dmrAttributeValueCount <- forceM \"AttributeValueCount expected\" $ cursor $// elCont \"AttributeValueCount\" &| readInt\n dmrAttributeNameCount <- forceM \"AttributeNameCount expected\" $ cursor $// elCont \"AttributeNameCount\" &| readInt\n dmrItemNamesSizeBytes <- forceM \"ItemNamesSizeBytes expected\" $ cursor $// elCont \"ItemNamesSizeBytes\" &| readInt\n dmrAttributeValuesSizeBytes <- forceM \"AttributeValuesSizeBytes expected\" $ cursor $// elCont \"AttributeValuesSizeBytes\" &| readInt\n dmrAttributeNamesSizeBytes <- forceM \"AttributeNamesSizeBytes expected\" $ cursor $// elCont \"AttributeNamesSizeBytes\" &| readInt\n return DomainMetadataResponse{..}\n\ninstance Transaction DomainMetadata DomainMetadataResponse\n\ninstance AsMemoryResponse DomainMetadataResponse where\n type MemoryResponse DomainMetadataResponse = DomainMetadataResponse\n loadToMemory = return\n\ndata ListDomains\n = ListDomains {\n ldMaxNumberOfDomains :: Maybe Int\n , ldNextToken :: Maybe T.Text\n }\n deriving (Show)\n\ndata ListDomainsResponse\n = ListDomainsResponse {\n ldrDomainNames :: [T.Text]\n , ldrNextToken :: Maybe T.Text\n }\n deriving (Show)\n\nlistDomains :: ListDomains\nlistDomains = ListDomains { ldMaxNumberOfDomains = Nothing, ldNextToken = Nothing }\n\n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery ListDomains where\n type ServiceConfiguration ListDomains = SdbConfiguration\n signQuery ListDomains{..} = sdbSignQuery $ catMaybes [\n Just (\"Action\", \"ListDomains\")\n , (\"MaxNumberOfDomains\",) . T.encodeUtf8 . T.pack . show <$> ldMaxNumberOfDomains\n , (\"NextToken\",) . T.encodeUtf8 <$> ldNextToken\n ]\n\ninstance ResponseConsumer r ListDomainsResponse where\n type ResponseMetadata ListDomainsResponse = SdbMetadata\n responseConsumer _ _ = sdbResponseConsumer parse\n where parse cursor = do\n sdbCheckResponseType () \"ListDomainsResponse\" cursor\n let names = cursor $// elContent \"DomainName\"\n let nextToken = listToMaybe $ cursor $// elContent \"NextToken\"\n return $ ListDomainsResponse names nextToken\n\ninstance Transaction ListDomains ListDomainsResponse\n\ninstance AsMemoryResponse ListDomainsResponse where\n type MemoryResponse ListDomainsResponse = ListDomainsResponse\n loadToMemory = return\n\ninstance ListResponse ListDomainsResponse T.Text where\n listResponse = ldrDomainNames\n\ninstance IteratedTransaction ListDomains ListDomainsResponse where\n nextIteratedRequest req ListDomainsResponse{ldrNextToken=nt} = req{ldNextToken=nt} <$ nt\n --combineIteratedResponse (ListDomainsResponse dn1 _) (ListDomainsResponse dn2 nt2) = ListDomainsResponse (dn1 ++ dn2) nt2\n" }, { "path": "Aws/SimpleDb/Commands/Select.hs", "content": "module Aws.SimpleDb.Commands.Select\nwhere\n\nimport Aws.Core\nimport Aws.SimpleDb.Core\nimport Control.Applicative\nimport Control.Monad\nimport Data.Maybe\nimport Prelude\nimport Text.XML.Cursor (($//), (&|))\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Text.XML.Cursor as Cu\n\ndata Select\n = Select {\n sSelectExpression :: T.Text\n , sConsistentRead :: Bool\n , sNextToken :: Maybe T.Text\n }\n deriving (Show)\n\ndata SelectResponse\n = SelectResponse {\n srItems :: [Item [Attribute T.Text]]\n , srNextToken :: Maybe T.Text\n }\n deriving (Show)\n\nselect :: T.Text -> Select\nselect expr = Select { sSelectExpression = expr, sConsistentRead = False, sNextToken = Nothing }\n\n-- | ServiceConfiguration: 'SdbConfiguration'\ninstance SignQuery Select where\n type ServiceConfiguration Select = SdbConfiguration\n signQuery Select{..}\n = sdbSignQuery . catMaybes $\n [ Just (\"Action\", \"Select\")\n , Just (\"SelectExpression\", T.encodeUtf8 sSelectExpression)\n , (\"ConsistentRead\", awsTrue) <$ guard sConsistentRead\n , ((\"NextToken\",) . T.encodeUtf8) <$> sNextToken\n ]\n\ninstance ResponseConsumer r SelectResponse where\n type ResponseMetadata SelectResponse = SdbMetadata\n responseConsumer _ _ = sdbResponseConsumer parse\n where parse cursor = do\n sdbCheckResponseType () \"SelectResponse\" cursor\n items <- sequence $ cursor $// Cu.laxElement \"Item\" &| readItem\n let nextToken = listToMaybe $ cursor $// elContent \"NextToken\"\n return $ SelectResponse items nextToken\n\ninstance Transaction Select SelectResponse\n\ninstance AsMemoryResponse SelectResponse where\n type MemoryResponse SelectResponse = SelectResponse\n loadToMemory = return\n\ninstance ListResponse SelectResponse (Item [Attribute T.Text]) where\n listResponse = srItems\n\ninstance IteratedTransaction Select SelectResponse where\n nextIteratedRequest req SelectResponse{srNextToken=nt} = req{sNextToken=nt} <$ nt\n-- combineIteratedResponse (SelectResponse s1 _) (SelectResponse s2 nt2) = SelectResponse (s1 ++ s2) nt2\n" }, { "path": "Aws/SimpleDb/Commands.hs", "content": "module Aws.SimpleDb.Commands\n(\n module Aws.SimpleDb.Commands.Attributes\n, module Aws.SimpleDb.Commands.Domain\n, module Aws.SimpleDb.Commands.Select\n)\nwhere\n\nimport Aws.SimpleDb.Commands.Attributes\nimport Aws.SimpleDb.Commands.Domain\nimport Aws.SimpleDb.Commands.Select\n" }, { "path": "Aws/SimpleDb/Core.hs", "content": "module Aws.SimpleDb.Core where\n\nimport Aws.Core\nimport qualified Blaze.ByteString.Builder as Blaze\nimport qualified Blaze.ByteString.Builder.Char8 as Blaze8\nimport qualified Control.Exception as C\nimport Control.Monad\nimport Control.Monad.Trans.Resource (MonadThrow, throwM)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Base64 as Base64\nimport Data.IORef\nimport Data.List\nimport Data.Maybe\nimport Data.Monoid\nimport qualified Data.Semigroup as Sem\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport Data.Typeable\nimport Prelude\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\nimport Text.XML.Cursor (($|), ($/), ($//), (&|))\nimport qualified Text.XML.Cursor as Cu\n\ntype ErrorCode = String\n\ndata SdbError\n = SdbError {\n sdbStatusCode :: HTTP.Status\n , sdbErrorCode :: ErrorCode\n , sdbErrorMessage :: String\n }\n deriving (Show, Typeable)\n\ninstance C.Exception SdbError\n\ndata SdbMetadata\n = SdbMetadata {\n requestId :: Maybe T.Text\n , boxUsage :: Maybe T.Text\n }\n deriving (Show, Typeable)\n\ninstance Loggable SdbMetadata where\n toLogText (SdbMetadata rid bu) = \"SimpleDB: request ID=\" `mappend`\n fromMaybe \"\" rid `mappend`\n \", box usage=\" `mappend`\n fromMaybe \"\" bu\n\ninstance Sem.Semigroup SdbMetadata where\n SdbMetadata r1 b1 <> SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2)\n\ninstance Monoid SdbMetadata where\n mempty = SdbMetadata Nothing Nothing\n mappend = (Sem.<>)\n\ndata SdbConfiguration qt\n = SdbConfiguration {\n sdbiProtocol :: Protocol\n , sdbiHttpMethod :: Method\n , sdbiHost :: B.ByteString\n , sdbiPort :: Int\n }\n deriving (Show)\n\ninstance DefaultServiceConfiguration (SdbConfiguration NormalQuery) where\n defServiceConfig = sdbHttpsPost sdbUsEast\n debugServiceConfig = sdbHttpPost sdbUsEast\n\ninstance DefaultServiceConfiguration (SdbConfiguration UriOnlyQuery) where\n defServiceConfig = sdbHttpsGet sdbUsEast\n debugServiceConfig = sdbHttpGet sdbUsEast\n\nsdbUsEast :: B.ByteString\nsdbUsEast = \"sdb.amazonaws.com\"\n\nsdbUsWest :: B.ByteString\nsdbUsWest = \"sdb.us-west-1.amazonaws.com\"\n\nsdbEuWest :: B.ByteString\nsdbEuWest = \"sdb.eu-west-1.amazonaws.com\"\n\nsdbApSoutheast :: B.ByteString\nsdbApSoutheast = \"sdb.ap-southeast-1.amazonaws.com\"\n\nsdbApNortheast :: B.ByteString\nsdbApNortheast = \"sdb.ap-northeast-1.amazonaws.com\"\n\nsdbHttpGet :: B.ByteString -> SdbConfiguration qt\nsdbHttpGet endpoint = SdbConfiguration HTTP Get endpoint (defaultPort HTTP)\n\nsdbHttpPost :: B.ByteString -> SdbConfiguration NormalQuery\nsdbHttpPost endpoint = SdbConfiguration HTTP PostQuery endpoint (defaultPort HTTP)\n\nsdbHttpsGet :: B.ByteString -> SdbConfiguration qt\nsdbHttpsGet endpoint = SdbConfiguration HTTPS Get endpoint (defaultPort HTTPS)\n\nsdbHttpsPost :: B.ByteString -> SdbConfiguration NormalQuery\nsdbHttpsPost endpoint = SdbConfiguration HTTPS PostQuery endpoint (defaultPort HTTPS)\n\nsdbSignQuery :: [(B.ByteString, B.ByteString)] -> SdbConfiguration qt -> SignatureData -> SignedQuery\nsdbSignQuery q si sd\n = SignedQuery {\n sqMethod = method\n , sqProtocol = sdbiProtocol si\n , sqHost = host\n , sqPort = sdbiPort si\n , sqPath = path\n , sqQuery = sq\n , sqDate = Just $ signatureTime sd\n , sqAuthorization = Nothing\n , sqContentType = Nothing\n , sqContentMd5 = Nothing\n , sqAmzHeaders = []\n , sqOtherHeaders = []\n , sqBody = Nothing\n , sqStringToSign = stringToSign\n }\n where\n ah = HmacSHA256\n q' = HTTP.toQuery . sort $ q ++ (\"Version\", \"2009-04-15\") : queryAuth\n ti = signatureTimeInfo sd\n cr = signatureCredentials sd\n queryAuth = [case ti of\n AbsoluteTimestamp time -> (\"Timestamp\", fmtAmzTime time)\n AbsoluteExpires time -> (\"Expires\", fmtAmzTime time)\n , (\"AWSAccessKeyId\", accessKeyID cr)\n , (\"SignatureMethod\", amzHash ah)\n , (\"SignatureVersion\", \"2\")]\n ++ maybe [] (\\tok -> [(\"SecurityToken\", tok)]) (iamToken cr)\n sq = (\"Signature\", Just sig) : q'\n method = sdbiHttpMethod si\n host = sdbiHost si\n path = \"/\"\n sig = signature cr ah stringToSign\n stringToSign = Blaze.toByteString . mconcat $\n intersperse (Blaze8.fromChar '\\n')\n [Blaze.copyByteString $ httpMethod method\n , Blaze.copyByteString $ host\n , Blaze.copyByteString $ path\n , HTTP.renderQueryBuilder False q']\n\nsdbResponseConsumer :: (Cu.Cursor -> Response SdbMetadata a)\n -> IORef SdbMetadata\n -> HTTPResponseConsumer a\nsdbResponseConsumer inner metadataRef resp\n = xmlCursorConsumer parse metadataRef resp\n where parse cursor\n = do let requestId' = listToMaybe $ cursor $// elContent \"RequestID\"\n let boxUsage' = listToMaybe $ cursor $// elContent \"BoxUsage\"\n tellMetadata $ SdbMetadata requestId' boxUsage'\n case cursor $// Cu.laxElement \"Error\" of\n [] -> inner cursor\n (err:_) -> fromError err\n fromError cursor = do errCode <- force \"Missing Error Code\" $ cursor $// elCont \"Code\"\n errMessage <- force \"Missing Error Message\" $ cursor $// elCont \"Message\"\n throwM $ SdbError (HTTP.responseStatus resp) errCode errMessage\n\nclass SdbFromResponse a where\n sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a\n\nsdbCheckResponseType :: MonadThrow m => a -> T.Text -> Cu.Cursor -> m a\nsdbCheckResponseType a n c = do _ <- force (\"Expected response type \" ++ T.unpack n) (Cu.laxElement n c)\n return a\n\ndecodeBase64 :: MonadThrow m => Cu.Cursor -> m T.Text\ndecodeBase64 cursor =\n let encoded = T.concat $ cursor $/ Cu.content\n encoding = listToMaybe $ cursor $| Cu.laxAttribute \"encoding\" &| T.toCaseFold\n in\n case encoding of\n Nothing -> return encoded\n Just \"base64\" -> case Base64.decode . T.encodeUtf8 $ encoded of\n Left msg -> throwM $ XmlException (\"Invalid Base64 data: \" ++ msg)\n Right x -> return $ T.decodeUtf8 x\n Just actual -> throwM $ XmlException (\"Unrecognized encoding \" ++ T.unpack actual)\n\ndata Attribute a\n = ForAttribute { attributeName :: T.Text, attributeData :: a }\n deriving (Show)\n\nreadAttribute :: MonadThrow m => Cu.Cursor -> m (Attribute T.Text)\nreadAttribute cursor = do\n name <- forceM \"Missing Name\" $ cursor $/ Cu.laxElement \"Name\" &| decodeBase64\n value <- forceM \"Missing Value\" $ cursor $/ Cu.laxElement \"Value\" &| decodeBase64\n return $ ForAttribute name value\n\ndata SetAttribute\n = SetAttribute { setAttribute :: T.Text, isReplaceAttribute :: Bool }\n deriving (Show)\n\nattributeQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Attribute a -> [(B.ByteString, B.ByteString)]\nattributeQuery f (ForAttribute name x) = (\"Name\", T.encodeUtf8 name) : f x\n\naddAttribute :: T.Text -> T.Text -> Attribute SetAttribute\naddAttribute name value = ForAttribute name (SetAttribute value False)\n\nreplaceAttribute :: T.Text -> T.Text -> Attribute SetAttribute\nreplaceAttribute name value = ForAttribute name (SetAttribute value True)\n\nsetAttributeQuery :: SetAttribute -> [(B.ByteString, B.ByteString)]\nsetAttributeQuery (SetAttribute value replace)\n = (\"Value\", T.encodeUtf8 value) : [(\"Replace\", awsTrue) | replace]\n\ndata DeleteAttribute\n = DeleteAttribute\n | ValuedDeleteAttribute { deleteAttributeValue :: T.Text }\n deriving (Show)\n\ndeleteAttributeQuery :: DeleteAttribute -> [(B.ByteString, B.ByteString)]\ndeleteAttributeQuery DeleteAttribute = []\ndeleteAttributeQuery (ValuedDeleteAttribute value) = [(\"Value\", T.encodeUtf8 value)]\n\ndata ExpectedAttribute\n = ExpectedValue { expectedAttributeValue :: T.Text }\n | ExpectedExists { expectedAttributeExists :: Bool }\n deriving (Show)\n\nexpectedValue :: T.Text -> T.Text -> Attribute ExpectedAttribute\nexpectedValue name value = ForAttribute name (ExpectedValue value)\n\nexpectedExists :: T.Text -> Bool -> Attribute ExpectedAttribute\nexpectedExists name exists = ForAttribute name (ExpectedExists exists)\n\nexpectedAttributeQuery :: ExpectedAttribute -> [(B.ByteString, B.ByteString)]\nexpectedAttributeQuery (ExpectedValue value) = [(\"Value\", T.encodeUtf8 value)]\nexpectedAttributeQuery (ExpectedExists exists) = [(\"Exists\", awsBool exists)]\n\ndata Item a\n = Item { itemName :: T.Text, itemData :: a }\n deriving (Show)\n\nreadItem :: MonadThrow m => Cu.Cursor -> m (Item [Attribute T.Text])\nreadItem cursor = do\n name <- force \"Missing Name\" <=< sequence $ cursor $/ Cu.laxElement \"Name\" &| decodeBase64\n attributes <- sequence $ cursor $/ Cu.laxElement \"Attribute\" &| readAttribute\n return $ Item name attributes\n\nitemQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Item a -> [(B.ByteString, B.ByteString)]\nitemQuery f (Item name x) = (\"ItemName\", T.encodeUtf8 name) : f x\n" }, { "path": "Aws/SimpleDb.hs", "content": "module Aws.SimpleDb\n(\n module Aws.SimpleDb.Commands\n, module Aws.SimpleDb.Core\n)\nwhere\n\nimport Aws.SimpleDb.Commands\nimport Aws.SimpleDb.Core\n" }, { "path": "Aws/Sqs/Commands/Message.hs", "content": "module Aws.Sqs.Commands.Message\n(\n-- * User Message Attributes\n UserMessageAttributeCustomType\n, UserMessageAttributeValue(..)\n, UserMessageAttributeName\n, UserMessageAttribute\n\n-- * Send Message\n, SendMessage(..)\n, SendMessageResponse(..)\n\n-- * Delete Message\n, DeleteMessage(..)\n, DeleteMessageResponse(..)\n\n-- * Receive Message\n, Message(..)\n, ReceiveMessage(..)\n, ReceiveMessageResponse(..)\n\n-- * Change Message Visibility\n, ChangeMessageVisibility(..)\n, ChangeMessageVisibilityResponse(..)\n) where\n\nimport Aws.Core\nimport Aws.Sqs.Core\nimport Control.Applicative\nimport Control.Monad.Trans.Resource (throwM)\nimport Data.Maybe\nimport Data.Monoid\nimport Text.XML.Cursor (($/), ($//), (&/), (&|))\nimport qualified Data.ByteString.Base64 as B64\nimport qualified Data.ByteString.Char8 as B\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as TE\nimport Data.Scientific\nimport qualified Network.HTTP.Types as HTTP\nimport Text.Read (readEither)\nimport qualified Text.XML.Cursor as Cu\nimport Prelude\n\n-- -------------------------------------------------------------------------- --\n-- User Message Attributes\n\n-- | You can append a custom type label to the supported data types (String,\n-- Number, and Binary) to create custom data types. This capability is similar\n-- to type traits in programming languages. For example, if you have an\n-- application that needs to know which type of number is being sent in the\n-- message, then you could create custom types similar to the following:\n-- Number.byte, Number.short, Number.int, and Number.float. Another example\n-- using the binary data type is to use Binary.gif and Binary.png to\n-- distinguish among different image file types in a message or batch of\n-- messages. The appended data is optional and opaque to Amazon SQS, which\n-- means that the appended data is not interpreted, validated, or used by\n-- Amazon SQS. The Custom Type extension has the same restrictions on allowed\n-- characters as the message body.\n--\ntype UserMessageAttributeCustomType = T.Text\n\n-- | Message Attribute Value\n--\n-- The user-specified message attribute value. For string data types, the value\n-- attribute has the same restrictions on the content as the message body. For\n-- more information, see SendMessage.\n--\n-- Name, type, and value must not be empty or null. In addition, the message\n-- body should not be empty or null. All parts of the message attribute,\n-- including name, type, and value, are included in the message size\n-- restriction, which is currently 256 KB (262,144 bytes).\n--\n-- The supported message attribute data types are String, Number, and Binary.\n-- You can also provide custom information on the type. The data type has the\n-- same restrictions on the content as the message body. The data type is case\n-- sensitive, and it can be up to 256 bytes long.\n--\n-- \n--\ndata UserMessageAttributeValue\n = UserMessageAttributeString (Maybe UserMessageAttributeCustomType) T.Text\n -- ^ Strings are Unicode with UTF-8 binary encoding.\n\n | UserMessageAttributeNumber (Maybe UserMessageAttributeCustomType) Scientific\n -- ^ Numbers are positive or negative integers or floating point numbers.\n -- Numbers have sufficient range and precision to encompass most of the\n -- possible values that integers, floats, and doubles typically support. A\n -- number can have up to 38 digits of precision, and it can be between\n -- 10^-128 to 10^+126. Leading and trailing zeroes are trimmed.\n\n | UserMessageAttributeBinary (Maybe UserMessageAttributeCustomType) B.ByteString\n -- ^ Binary type attributes can store any binary data, for example,\n -- compressed data, encrypted data, or images.\n\n -- UserMessageAttributesStringList (Maybe UserMessageAttributeCustomType) [T.Text]\n -- -- ^ Not implemented. Reserved for future use.\n\n -- UserMessageAttributeBinaryList (Maybe UserMessageAttributeCustomType) [B.ByteString]\n -- -- ^ Not implemented. Reserved for future use.\n\n deriving (Show, Read, Eq, Ord)\n\n-- | The message attribute name can contain the following characters: A-Z, a-z,\n-- 0-9, underscore(_), hyphen(-), and period (.). The name must not start or\n-- end with a period, and it should not have successive periods. The name is\n-- case sensitive and must be unique among all attribute names for the message.\n-- The name can be up to 256 characters long. The name cannot start with \"AWS.\"\n-- or \"Amazon.\" (or any variations in casing) because these prefixes are\n-- reserved for use by Amazon Web Services.\n--\ntype UserMessageAttributeName = T.Text\n\n-- | Message Attribute\n--\n-- Name, type, and value must not be empty or null. In addition, the message\n-- body should not be empty or null. All parts of the message attribute,\n-- including name, type, and value, are included in the message size\n-- restriction, which is currently 256 KB (262,144 bytes).\n--\n-- \n--\n-- /NOTE/\n--\n-- The Amazon SQS API reference calls this /MessageAttribute/. The Haskell\n-- bindings use this term for what the Amazon documentation calls just\n-- /Attributes/. In order to limit backward compatibility issues we keep the\n-- terminology of the Haskell bindings and call this type\n-- /UserMessageAttributes/.\n--\ntype UserMessageAttribute = (UserMessageAttributeName, UserMessageAttributeValue)\n\nuserMessageAttributesQuery :: [UserMessageAttribute] -> HTTP.Query\nuserMessageAttributesQuery = concat . zipWith msgAttrQuery [1 :: Int ..]\n where\n msgAttrQuery i (name, value) =\n [ ( pre <> \"Name\", Just $ TE.encodeUtf8 name )\n , ( pre <> \"Value.DataType\", Just typ )\n , ( pre <> \"Value.\" <> valueKey, Just encodedValue )\n ]\n where\n pre = \"MessageAttribute.\" <> B.pack (show i) <> \".\"\n customType Nothing t = TE.encodeUtf8 t\n customType (Just c) t = TE.encodeUtf8 $ t <> \".\" <> c\n (typ, valueKey, encodedValue) = case value of\n UserMessageAttributeString c t ->\n (customType c \"String\", \"StringValue\", TE.encodeUtf8 t)\n UserMessageAttributeNumber c n ->\n (customType c \"Number\", \"StringValue\", B.pack $ show n)\n UserMessageAttributeBinary c b ->\n (customType c \"Binary\", \"BinaryValue\", b)\n\n-- -------------------------------------------------------------------------- --\n-- Send Message\n\n-- | Delivers a message to the specified queue. With Amazon SQS, you now have\n-- the ability to send large payload messages that are up to 256KB (262,144\n-- bytes) in size. To send large payloads, you must use an AWS SDK that\n-- supports SigV4 signing. To verify whether SigV4 is supported for an AWS SDK,\n-- check the SDK release notes.\n--\n-- /IMPORTANT/\n--\n-- The following list shows the characters (in Unicode) allowed in your\n-- message, according to the W3C XML specification. For more information, go to\n-- If you send any characters not\n-- included in the list, your request will be rejected.\n--\n-- > #x9 | #xA | #xD | [#x20 to #xD7FF] | [#xE000 to #xFFFD] | [#x10000 to #x10FFFF]\n--\n-- \n--\ndata SendMessage = SendMessage\n { smMessage :: !T.Text\n -- ^ The message to send. String maximum 256 KB in size.\n\n , smQueueName :: !QueueName\n -- ^ The URL of the Amazon SQS queue to take action on.\n\n , smAttributes :: ![UserMessageAttribute]\n -- ^ Each message attribute consists of a Name, Type, and Value.\n\n , smDelaySeconds :: !(Maybe Int)\n -- ^ The number of seconds (0 to 900 - 15 minutes) to delay a specific\n -- message. Messages with a positive DelaySeconds value become available for\n -- processing after the delay time is finished. If you don't specify a value,\n -- the default value for the queue applies.\n }\n deriving (Show, Read, Eq, Ord)\n\n-- | At\n-- \n-- all fields of @SendMessageResult@ are denoted as optional.\n-- At\n-- \n-- all fields are specified as required.\n--\n-- The actual service seems to treat at least 'smrMD5OfMessageAttributes'\n-- as optional.\n--\ndata SendMessageResponse = SendMessageResponse\n { smrMD5OfMessageBody :: !T.Text\n -- ^ An MD5 digest of the non-URL-encoded message body string. This can be\n -- used to verify that Amazon SQS received the message correctly. Amazon SQS\n -- first URL decodes the message before creating the MD5 digest. For\n -- information about MD5, go to .\n\n , smrMessageId :: !MessageId\n -- ^ An element containing the message ID of the message sent to the queue.\n\n , smrMD5OfMessageAttributes :: !(Maybe T.Text)\n -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can\n -- be used to verify that Amazon SQS received the message correctly. Amazon\n -- SQS first URL decodes the message before creating the MD5 digest. For\n -- information about MD5, go to .\n }\n deriving (Show, Read, Eq, Ord)\n\ninstance ResponseConsumer r SendMessageResponse where\n type ResponseMetadata SendMessageResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse el = SendMessageResponse\n <$> force \"Missing MD5 Signature\"\n (el $// Cu.laxElement \"MD5OfMessageBody\" &/ Cu.content)\n <*> (fmap MessageId . force \"Missing Message Id\")\n (el $// Cu.laxElement \"MessageId\" &/ Cu.content)\n <*> (pure . listToMaybe)\n (el $// Cu.laxElement \"MD5OfMessageAttributes\" &/ Cu.content)\n\ninstance SignQuery SendMessage where\n type ServiceConfiguration SendMessage = SqsConfiguration\n signQuery SendMessage{..} = sqsSignQuery SqsQuery\n { sqsQueueName = Just smQueueName\n , sqsQuery =\n [ (\"Action\", Just \"SendMessage\")\n , (\"MessageBody\", Just $ TE.encodeUtf8 smMessage)\n ]\n <> userMessageAttributesQuery smAttributes\n <> maybeToList ((\"DelaySeconds\",) . Just . B.pack . show <$> smDelaySeconds)\n }\n\ninstance Transaction SendMessage SendMessageResponse\n\ninstance AsMemoryResponse SendMessageResponse where\n type MemoryResponse SendMessageResponse = SendMessageResponse\n loadToMemory = return\n\n-- -------------------------------------------------------------------------- --\n-- Delete Message\n\n-- | Deletes the specified message from the specified queue. You specify the\n-- message by using the message's receipt handle and not the message ID you\n-- received when you sent the message. Even if the message is locked by another\n-- reader due to the visibility timeout setting, it is still deleted from the\n-- queue. If you leave a message in the queue for longer than the queue's\n-- configured retention period, Amazon SQS automatically deletes it.\n--\n-- /NOTE/\n--\n-- The receipt handle is associated with a specific instance of receiving the\n-- message. If you receive a message more than once, the receipt handle you get\n-- each time you receive the message is different. When you request\n-- DeleteMessage, if you don't provide the most recently received receipt\n-- handle for the message, the request will still succeed, but the message\n-- might not be deleted.\n--\n-- /IMPORTANT/\n--\n-- It is possible you will receive a message even after you have deleted it.\n-- This might happen on rare occasions if one of the servers storing a copy of\n-- the message is unavailable when you request to delete the message. The copy\n-- remains on the server and might be returned to you again on a subsequent\n-- receive request. You should create your system to be idempotent so that\n-- receiving a particular message more than once is not a problem.\n--\n-- \n--\ndata DeleteMessage = DeleteMessage\n { dmReceiptHandle :: !ReceiptHandle\n -- ^ The receipt handle associated with the message to delete.\n , dmQueueName :: !QueueName\n -- ^ The URL of the Amazon SQS queue to take action on.\n }\n deriving (Show, Read, Eq, Ord)\n\ndata DeleteMessageResponse = DeleteMessageResponse {}\n deriving (Show, Read, Eq, Ord)\n\ninstance ResponseConsumer r DeleteMessageResponse where\n type ResponseMetadata DeleteMessageResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse _ = return DeleteMessageResponse {}\n\ninstance SignQuery DeleteMessage where\n type ServiceConfiguration DeleteMessage = SqsConfiguration\n signQuery DeleteMessage{..} = sqsSignQuery SqsQuery\n { sqsQueueName = Just dmQueueName\n , sqsQuery =\n [ (\"Action\", Just \"DeleteMessage\")\n , (\"ReceiptHandle\", Just $ TE.encodeUtf8 $ printReceiptHandle dmReceiptHandle)\n ]\n }\n\ninstance Transaction DeleteMessage DeleteMessageResponse\n\ninstance AsMemoryResponse DeleteMessageResponse where\n type MemoryResponse DeleteMessageResponse = DeleteMessageResponse\n loadToMemory = return\n\n-- -------------------------------------------------------------------------- --\n-- Receive Message\n\n-- | Retrieves one or more messages, with a maximum limit of 10 messages, from\n-- the specified queue. Long poll support is enabled by using the\n-- WaitTimeSeconds parameter. For more information, see\n-- \n-- in the Amazon SQS Developer Guide.\n--\n-- Short poll is the default behavior where a weighted random set of machines\n-- is sampled on a ReceiveMessage call. This means only the messages on the\n-- sampled machines are returned. If the number of messages in the queue is\n-- small (less than 1000), it is likely you will get fewer messages than you\n-- requested per ReceiveMessage call. If the number of messages in the queue is\n-- extremely small, you might not receive any messages in a particular\n-- ReceiveMessage response; in which case you should repeat the request.\n--\n-- For each message returned, the response includes the following:\n--\n-- Message body\n--\n-- * MD5 digest of the message body. For information about MD5, go to\n-- .\n--\n-- * Message ID you received when you sent the message to the queue.\n--\n-- * Receipt handle.\n--\n-- * Message attributes.\n--\n-- * MD5 digest of the message attributes.\n--\n-- The receipt handle is the identifier you must provide when deleting the\n-- message. For more information, see Queue and Message Identifiers in the\n-- Amazon SQS Developer Guide.\n--\n-- You can provide the VisibilityTimeout parameter in your request, which will\n-- be applied to the messages that Amazon SQS returns in the response. If you\n-- do not include the parameter, the overall visibility timeout for the queue\n-- is used for the returned messages. For more information, see Visibility\n-- Timeout in the Amazon SQS Developer Guide.\n--\n-- /NOTE/\n--\n-- Going forward, new attributes might be added. If you are writing code that\n-- calls this action, we recommend that you structure your code so that it can\n-- handle new attributes gracefully.\n--\n-- \n--\ndata ReceiveMessage = ReceiveMessage\n { rmVisibilityTimeout :: !(Maybe Int)\n -- ^ The duration (in seconds) that the received messages are hidden from\n -- subsequent retrieve requests after being retrieved by a ReceiveMessage\n -- request.\n\n , rmAttributes :: ![MessageAttribute]\n -- ^ A list of attributes that need to be returned along with each message.\n --\n -- The following lists the names and descriptions of the attributes that can\n -- be returned:\n --\n -- * All - returns all values.\n --\n -- * ApproximateFirstReceiveTimestamp - returns the time when the message was\n -- first received (epoch time in milliseconds).\n --\n -- * ApproximateReceiveCount - returns the number of times a message has been\n -- received but not deleted.\n --\n -- * SenderId - returns the AWS account number (or the IP address, if\n -- anonymous access is allowed) of the sender.\n --\n -- * SentTimestamp - returns the time when the message was sent (epoch time\n -- in milliseconds).\n\n , rmMaxNumberOfMessages :: !(Maybe Int)\n -- ^ The maximum number of messages to return. Amazon SQS never returns more\n -- messages than this value but may return fewer. Values can be from 1 to 10.\n -- Default is 1.\n --\n -- All of the messages are not necessarily returned.\n\n , rmUserMessageAttributes :: ![UserMessageAttributeName]\n -- ^ The name of the message attribute, where N is the index. The message\n -- attribute name can contain the following characters: A-Z, a-z, 0-9,\n -- underscore (_), hyphen (-), and period (.). The name must not start or end\n -- with a period, and it should not have successive periods. The name is case\n -- sensitive and must be unique among all attribute names for the message.\n -- The name can be up to 256 characters long. The name cannot start with\n -- \"AWS.\" or \"Amazon.\" (or any variations in casing), because these prefixes\n -- are reserved for use by Amazon Web Services.\n --\n -- When using ReceiveMessage, you can send a list of attribute names to\n -- receive, or you can return all of the attributes by specifying \"All\" or\n -- \".*\" in your request. You can also use \"foo.*\" to return all message\n -- attributes starting with the \"foo\" prefix.\n\n , rmQueueName :: !QueueName\n -- ^The URL of the Amazon SQS queue to take action on.\n\n , rmWaitTimeSeconds :: !(Maybe Int)\n -- ^ The duration (in seconds) for which the call will wait for a message to\n -- arrive in the queue before returning. If a message is available, the call\n -- will return sooner than WaitTimeSeconds.\n\n }\n deriving (Show, Read, Eq, Ord)\n\n-- | An Amazon SQS message.\n--\n-- In\n-- \n-- all elements are denoted as optional.\n-- In\n-- \n-- all elements except for the attributes are specified as required.\n-- At least for the field 'mMD5OfMessageAttributes' the the service\n-- is not always returning a value and therefore we make this field optional.\n--\ndata Message = Message\n { mMessageId :: !T.Text\n -- ^ A unique identifier for the message. Message IDs are considered unique\n -- across all AWS accounts for an extended period of time.\n\n , mReceiptHandle :: !ReceiptHandle\n -- ^ An identifier associated with the act of receiving the message. A new\n -- receipt handle is returned every time you receive a message. When deleting\n -- a message, you provide the last received receipt handle to delete the\n -- message.\n\n , mMD5OfBody :: !T.Text\n -- ^ An MD5 digest of the non-URL-encoded message body string.\n\n , mBody :: T.Text\n -- ^ The message's contents (not URL-encoded).\n\n , mAttributes :: ![(MessageAttribute,T.Text)]\n -- ^ SenderId, SentTimestamp, ApproximateReceiveCount, and/or\n -- ApproximateFirstReceiveTimestamp. SentTimestamp and\n -- ApproximateFirstReceiveTimestamp are each returned as an integer\n -- representing the epoch time in milliseconds.\n\n , mMD5OfMessageAttributes :: !(Maybe T.Text)\n -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can\n -- be used to verify that Amazon SQS received the message correctly. Amazon\n -- SQS first URL decodes the message before creating the MD5 digest. For\n -- information about MD5, go to .\n\n , mUserMessageAttributes :: ![UserMessageAttribute]\n -- ^ Each message attribute consists of a Name, Type, and Value.\n }\n deriving(Show, Read, Eq, Ord)\n\ndata ReceiveMessageResponse = ReceiveMessageResponse\n { rmrMessages :: ![Message]\n }\n deriving (Show, Read, Eq, Ord)\n\nreadMessageAttribute\n :: Cu.Cursor\n -> Response SqsMetadata (MessageAttribute,T.Text)\nreadMessageAttribute cursor = do\n name <- force \"Missing Name\" $ cursor $/ Cu.laxElement \"Name\" &/ Cu.content\n value <- force \"Missing Value\" $ cursor $/ Cu.laxElement \"Value\" &/ Cu.content\n parsedName <- parseMessageAttribute name\n return (parsedName, value)\n\nreadUserMessageAttribute\n :: Cu.Cursor\n -> Response SqsMetadata UserMessageAttribute\nreadUserMessageAttribute cursor = (,)\n <$> force \"Missing Name\" (cursor $/ Cu.laxElement \"Name\" &/ Cu.content)\n <*> readUserMessageAttributeValue cursor\n\nreadUserMessageAttributeValue\n :: Cu.Cursor\n -> Response SqsMetadata UserMessageAttributeValue\nreadUserMessageAttributeValue cursor = do\n typStr <- force \"Missing DataType\"\n $ cursor $// Cu.laxElement \"DataType\" &/ Cu.content\n case parseType typStr of\n (\"String\", c) -> do\n val <- force \"Missing StringValue\"\n $ cursor $// Cu.laxElement \"StringValue\" &/ Cu.content\n return $ UserMessageAttributeString c val\n\n (\"Number\", c) -> do\n valStr <- force \"Missing StringValue\"\n $ cursor $// Cu.laxElement \"StringValue\" &/ Cu.content\n val <- tryXml . readEither $ T.unpack valStr\n return $ UserMessageAttributeNumber c val\n\n (\"Binary\", c) -> do\n val64 <- force \"Missing BinaryValue\"\n $ cursor $// Cu.laxElement \"BinaryValue\" &/ Cu.content\n val <- tryXml . B64.decode $ TE.encodeUtf8 val64\n return $ UserMessageAttributeBinary c val\n\n (x, _) -> throwM . XmlException\n $ \"unknown data type for MessageAttributeValue: \" <> T.unpack x\n where\n parseType s = case T.break (== '.') s of\n (a, \"\") -> (a, Nothing)\n (a, x) -> (a, Just (T.tail x))\n tryXml = either (throwM . XmlException) return\n\nreadMessage :: Cu.Cursor -> Response SqsMetadata Message\nreadMessage cursor = do\n mid <- force \"Missing Message Id\"\n $ cursor $// Cu.laxElement \"MessageId\" &/ Cu.content\n rh <- force \"Missing Receipt Handle\"\n $ cursor $// Cu.laxElement \"ReceiptHandle\" &/ Cu.content\n md5 <- force \"Missing MD5 Signature\"\n $ cursor $// Cu.laxElement \"MD5OfBody\" &/ Cu.content\n body <- force \"Missing Body\"\n $ cursor $// Cu.laxElement \"Body\" &/ Cu.content\n attributes <- sequence\n $ cursor $// Cu.laxElement \"Attribute\" &| readMessageAttribute\n userAttributes <- sequence\n $ cursor $// Cu.laxElement \"MessageAttribute\" &| readUserMessageAttribute\n let md5OfMessageAttributes = listToMaybe\n $ cursor $// Cu.laxElement \"MD5OfMessageAttributes\" &/ Cu.content\n\n return Message\n { mMessageId = mid\n , mReceiptHandle = ReceiptHandle rh\n , mMD5OfBody = md5\n , mBody = body\n , mAttributes = attributes\n , mMD5OfMessageAttributes = md5OfMessageAttributes\n , mUserMessageAttributes = userAttributes\n }\n\nformatMAttributes :: [MessageAttribute] -> HTTP.Query\nformatMAttributes attrs = case attrs of\n [attr] -> [(\"AttributeName\", encodeAttr attr)]\n _ -> zipWith f [1 :: Int ..] attrs\n where\n f x y = (\"AttributeName.\" <> B.pack (show x), encodeAttr y)\n encodeAttr = Just . TE.encodeUtf8 . printMessageAttribute\n\nformatUserMessageAttributes :: [UserMessageAttributeName] -> HTTP.Query\nformatUserMessageAttributes attrs = case attrs of\n [attr] -> [(\"MessageAttributeName\", encodeAttr attr)]\n _ -> zipWith f [1 :: Int ..] attrs\n where\n f x y = (\"MessageAttributeName.\" <> B.pack (show x), encodeAttr y)\n encodeAttr = Just . TE.encodeUtf8\n\ninstance ResponseConsumer r ReceiveMessageResponse where\n type ResponseMetadata ReceiveMessageResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse el = do\n result <- force \"Missing ReceiveMessageResult\"\n $ el $// Cu.laxElement \"ReceiveMessageResult\"\n messages <- sequence\n $ result $// Cu.laxElement \"Message\" &| readMessage\n return ReceiveMessageResponse{ rmrMessages = messages }\n\ninstance SignQuery ReceiveMessage where\n type ServiceConfiguration ReceiveMessage = SqsConfiguration\n signQuery ReceiveMessage{..} = sqsSignQuery SqsQuery\n { sqsQueueName = Just rmQueueName\n , sqsQuery = [ (\"Action\", Just \"ReceiveMessage\") ]\n <> catMaybes\n [ (\"VisibilityTimeout\",) <$> case rmVisibilityTimeout of\n Just x -> Just $ Just $ B.pack $ show x\n Nothing -> Nothing\n\n , (\"MaxNumberOfMessages\",) <$> case rmMaxNumberOfMessages of\n Just x -> Just $ Just $ B.pack $ show x\n Nothing -> Nothing\n\n , (\"WaitTimeSeconds\",) <$> case rmWaitTimeSeconds of\n Just x -> Just $ Just $ B.pack $ show x\n Nothing -> Nothing\n ]\n <> formatMAttributes rmAttributes\n <> formatUserMessageAttributes rmUserMessageAttributes\n }\n\ninstance Transaction ReceiveMessage ReceiveMessageResponse\n\ninstance AsMemoryResponse ReceiveMessageResponse where\n type MemoryResponse ReceiveMessageResponse = ReceiveMessageResponse\n loadToMemory = return\n\n-- -------------------------------------------------------------------------- --\n-- Change Message Visibility\n\n-- | Changes the visibility timeout of a specified message in a queue to a new\n-- value. The maximum allowed timeout value you can set the value to is 12\n-- hours. This means you can't extend the timeout of a message in an existing\n-- queue to more than a total visibility timeout of 12 hours. (For more\n-- information visibility timeout, see Visibility Timeout in the Amazon SQS\n-- Developer Guide.)\n--\n-- For example, let's say you have a message and its default message visibility\n-- timeout is 30 minutes. You could call ChangeMessageVisiblity with a value of\n-- two hours and the effective timeout would be two hours and 30 minutes. When\n-- that time comes near you could again extend the time out by calling\n-- ChangeMessageVisiblity, but this time the maximum allowed timeout would be 9\n-- hours and 30 minutes.\n--\n-- /NOTE/\n--\n-- There is a 120,000 limit for the number of inflight messages per queue.\n-- Messages are inflight after they have been received from the queue by a\n-- consuming component, but have not yet been deleted from the queue. If you\n-- reach the 120,000 limit, you will receive an OverLimit error message from\n-- Amazon SQS. To help avoid reaching the limit, you should delete the messages\n-- from the queue after they have been processed. You can also increase the\n-- number of queues you use to process the messages.\n--\n-- /IMPORTANT/\n--\n-- If you attempt to set the VisibilityTimeout to an amount more than the\n-- maximum time left, Amazon SQS returns an error. It will not automatically\n-- recalculate and increase the timeout to the maximum time remaining.\n--\n-- /IMPORTANT/\n--\n-- Unlike with a queue, when you change the visibility timeout for a specific\n-- message, that timeout value is applied immediately but is not saved in\n-- memory for that message. If you don't delete a message after it is received,\n-- the visibility timeout for the message the next time it is received reverts\n-- to the original timeout value, not the value you set with the\n-- ChangeMessageVisibility action.\n--\n-- \n--\ndata ChangeMessageVisibility = ChangeMessageVisibility\n { cmvReceiptHandle :: !ReceiptHandle\n -- ^ The receipt handle associated with the message whose visibility timeout\n -- should be changed. This parameter is returned by the ReceiveMessage\n -- action.\n\n , cmvVisibilityTimeout :: !Int\n -- ^ The new value (in seconds - from 0 to 43200 - maximum 12 hours) for the\n -- message's visibility timeout.\n\n , cmvQueueName :: !QueueName\n -- ^ The URL of the Amazon SQS queue to take action on.\n }\n deriving (Show, Read, Eq, Ord)\n\ndata ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse {}\n deriving (Show, Read, Eq, Ord)\n\ninstance ResponseConsumer r ChangeMessageVisibilityResponse where\n type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse _ = return ChangeMessageVisibilityResponse {}\n\n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery ChangeMessageVisibility where\n type ServiceConfiguration ChangeMessageVisibility = SqsConfiguration\n signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery\n { sqsQueueName = Just cmvQueueName\n , sqsQuery =\n [ (\"Action\", Just \"ChangeMessageVisibility\")\n , (\"ReceiptHandle\", Just . TE.encodeUtf8 $ printReceiptHandle cmvReceiptHandle)\n , (\"VisibilityTimeout\", Just . B.pack $ show cmvVisibilityTimeout)\n ]\n }\n\ninstance Transaction ChangeMessageVisibility ChangeMessageVisibilityResponse\n\ninstance AsMemoryResponse ChangeMessageVisibilityResponse where\n type MemoryResponse ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse\n loadToMemory = return\n" }, { "path": "Aws/Sqs/Commands/Permission.hs", "content": "\nmodule Aws.Sqs.Commands.Permission where\n\nimport Aws.Core\nimport Aws.Sqs.Core\nimport qualified Data.ByteString.Char8 as B\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as TE\nimport qualified Network.HTTP.Types as HTTP\n\ndata AddPermission = AddPermission {\n apLabel :: T.Text,\n apPermissions :: [(T.Text,SqsPermission)],\n apQueueName :: QueueName\n } deriving (Show)\n\ndata AddPermissionResponse = AddPermissionResponse\n deriving (Show)\n\n\nformatPermissions :: [(T.Text,SqsPermission)] -> [HTTP.QueryItem]\nformatPermissions perms = \n concat $ zipWith(\\ x y -> [(B.pack $ \"AwsAccountId.\" ++ show y, Just $ B.pack $ T.unpack $ fst x), \n (B.pack $ \"ActionName.\" ++ show y, Just $ B.pack $ T.unpack $ printPermission $ snd x)]) perms [1 :: Integer ..]\n\ninstance ResponseConsumer r AddPermissionResponse where\n type ResponseMetadata AddPermissionResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse _ = do\n return AddPermissionResponse {}\n \n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery AddPermission where \n type ServiceConfiguration AddPermission = SqsConfiguration\n signQuery AddPermission {..} = sqsSignQuery SqsQuery {\n sqsQueueName = Just apQueueName, \n sqsQuery = [(\"Action\", Just \"AddPermission\"), \n (\"QueueName\", Just $ B.pack $ T.unpack $ printQueueName apQueueName),\n (\"Label\", Just $ B.pack $ T.unpack apLabel)] ++ formatPermissions apPermissions}\n\ninstance Transaction AddPermission AddPermissionResponse\n\ninstance AsMemoryResponse AddPermissionResponse where\n type MemoryResponse AddPermissionResponse = AddPermissionResponse\n loadToMemory = return\n\ndata RemovePermission = RemovePermission {\n rpLabel :: T.Text,\n rpQueueName :: QueueName \n } deriving (Show)\n\ndata RemovePermissionResponse = RemovePermissionResponse \n deriving (Show)\n\ninstance ResponseConsumer r RemovePermissionResponse where\n type ResponseMetadata RemovePermissionResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where \n parse _ = do\n return RemovePermissionResponse {} \n \n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery RemovePermission where \n type ServiceConfiguration RemovePermission = SqsConfiguration\n signQuery RemovePermission {..} = sqsSignQuery SqsQuery {\n sqsQueueName = Just rpQueueName, \n sqsQuery = [(\"Action\", Just \"RemovePermission\"), \n (\"Label\", Just $ TE.encodeUtf8 rpLabel )]} \n\ninstance Transaction RemovePermission RemovePermissionResponse\n\ninstance AsMemoryResponse RemovePermissionResponse where\n type MemoryResponse RemovePermissionResponse = RemovePermissionResponse\n loadToMemory = return\n" }, { "path": "Aws/Sqs/Commands/Queue.hs", "content": "\nmodule Aws.Sqs.Commands.Queue where\n\nimport Aws.Core\nimport Aws.Sqs.Core\nimport Control.Applicative\nimport Data.Maybe\nimport Prelude\nimport Text.XML.Cursor (($//), (&/))\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as TE\nimport qualified Text.XML.Cursor as Cu\nimport qualified Data.ByteString.Char8 as B\n\ndata CreateQueue = CreateQueue {\n cqDefaultVisibilityTimeout :: Maybe Int,\n cqQueueName :: T.Text\n } deriving (Show)\n\ndata CreateQueueResponse = CreateQueueResponse {\n cqrQueueUrl :: T.Text\n } deriving (Show)\n\n\ninstance ResponseConsumer r CreateQueueResponse where\n type ResponseMetadata CreateQueueResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse el = do\n url <- force \"Missing Queue Url\" $ el $// Cu.laxElement \"QueueUrl\" &/ Cu.content\n return CreateQueueResponse{ cqrQueueUrl = url}\n\n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery CreateQueue where\n type ServiceConfiguration CreateQueue = SqsConfiguration\n signQuery CreateQueue {..} = sqsSignQuery SqsQuery {\n sqsQueueName = Nothing,\n sqsQuery = [(\"Action\", Just \"CreateQueue\"),\n (\"QueueName\", Just $ TE.encodeUtf8 cqQueueName)] ++\n catMaybes [(\"DefaultVisibilityTimeout\",) <$> case cqDefaultVisibilityTimeout of\n Just x -> Just $ Just $ B.pack $ show x\n Nothing -> Nothing]}\n\ninstance Transaction CreateQueue CreateQueueResponse\n\ninstance AsMemoryResponse CreateQueueResponse where\n type MemoryResponse CreateQueueResponse = CreateQueueResponse\n loadToMemory = return\n\ndata DeleteQueue = DeleteQueue {\n dqQueueName :: QueueName \n } deriving (Show)\n\ndata DeleteQueueResponse = DeleteQueueResponse \n deriving (Show)\n\ninstance ResponseConsumer r DeleteQueueResponse where\n type ResponseMetadata DeleteQueueResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse _ = do return DeleteQueueResponse{}\n \n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery DeleteQueue where \n type ServiceConfiguration DeleteQueue = SqsConfiguration\n signQuery DeleteQueue {..} = sqsSignQuery SqsQuery {\n sqsQueueName = Just dqQueueName, \n sqsQuery = [(\"Action\", Just \"DeleteQueue\")]}\n\ninstance Transaction DeleteQueue DeleteQueueResponse\n\ninstance AsMemoryResponse DeleteQueueResponse where\n type MemoryResponse DeleteQueueResponse = DeleteQueueResponse\n loadToMemory = return\n\ndata ListQueues = ListQueues {\n lqQueueNamePrefix :: Maybe T.Text\n } deriving (Show)\n\ndata ListQueuesResponse = ListQueuesResponse {\n lqrQueueUrls :: [T.Text]\n } deriving (Show)\n\ninstance ResponseConsumer r ListQueuesResponse where\n type ResponseMetadata ListQueuesResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse el = do\n let queues = el $// Cu.laxElement \"QueueUrl\" &/ Cu.content\n return ListQueuesResponse { lqrQueueUrls = queues }\n\n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery ListQueues where\n type ServiceConfiguration ListQueues = SqsConfiguration\n signQuery ListQueues{..} = sqsSignQuery SqsQuery {\n sqsQueueName = Nothing,\n sqsQuery = [(\"Action\", Just \"ListQueues\")] ++ catMaybes [\n (\"QueueNamePrefix\",) <$> case lqQueueNamePrefix of\n Just x -> Just $ Just $ TE.encodeUtf8 x\n Nothing -> Nothing]}\n\ninstance Transaction ListQueues ListQueuesResponse\n\ninstance AsMemoryResponse ListQueuesResponse where\n type MemoryResponse ListQueuesResponse = ListQueuesResponse\n loadToMemory = return\n" }, { "path": "Aws/Sqs/Commands/QueueAttributes.hs", "content": "\nmodule Aws.Sqs.Commands.QueueAttributes where\n\nimport Aws.Core\nimport Aws.Sqs.Core\nimport Text.XML.Cursor (($/), ($//), (&/), (&|))\nimport qualified Data.ByteString.Char8 as B\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as TE\nimport qualified Text.XML.Cursor as Cu\n\ndata GetQueueAttributes = GetQueueAttributes {\n gqaQueueName :: QueueName,\n gqaAttributes :: [QueueAttribute]\n}deriving (Show)\n\ndata GetQueueAttributesResponse = GetQueueAttributesResponse{\n gqarAttributes :: [(QueueAttribute,T.Text)]\n} deriving (Show)\n\nparseAttributes :: Cu.Cursor -> [(QueueAttribute, T.Text)]\nparseAttributes el = do\n name <- force \"Missing Name\" $ el $/ Cu.laxElement \"Name\" &/ Cu.content\n value <- force \"Missing Value\" $ el $/ Cu.laxElement \"Value\" &/ Cu.content\n parsedName <- parseQueueAttribute name\n return (parsedName, value)\n\ninstance ResponseConsumer r GetQueueAttributesResponse where\n type ResponseMetadata GetQueueAttributesResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where\n parse el = do\n let attributes = concat $ el $// Cu.laxElement \"Attribute\" &| parseAttributes\n return GetQueueAttributesResponse{ gqarAttributes = attributes }\n\nformatAttributes :: [QueueAttribute] -> [(B.ByteString, Maybe B.ByteString)]\nformatAttributes attrs =\n case length attrs of\n 0 -> undefined\n 1 -> [(\"AttributeName\", Just $ B.pack $ T.unpack $ printQueueAttribute $ attrs !! 0)]\n _ -> zipWith (\\ x y -> ((B.concat [\"AttributeName.\", B.pack $ show $ y]), Just $ B.pack $ T.unpack $ printQueueAttribute x) ) attrs [1 :: Integer ..]\n\n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery GetQueueAttributes where\n type ServiceConfiguration GetQueueAttributes = SqsConfiguration\n signQuery GetQueueAttributes{..} = sqsSignQuery SqsQuery {\n sqsQueueName = Just gqaQueueName,\n sqsQuery = [(\"Action\", Just \"GetQueueAttributes\")] ++ (formatAttributes gqaAttributes)}\n\ninstance Transaction GetQueueAttributes GetQueueAttributesResponse\n\ninstance AsMemoryResponse GetQueueAttributesResponse where\n type MemoryResponse GetQueueAttributesResponse = GetQueueAttributesResponse\n loadToMemory = return\n\ndata SetQueueAttributes = SetQueueAttributes{\n sqaAttribute :: QueueAttribute,\n sqaValue :: T.Text,\n sqaQueueName :: QueueName \n}deriving (Show)\n\ndata SetQueueAttributesResponse = SetQueueAttributesResponse{\n} deriving (Show)\n\ninstance ResponseConsumer r SetQueueAttributesResponse where\n type ResponseMetadata SetQueueAttributesResponse = SqsMetadata\n responseConsumer _ _ = sqsXmlResponseConsumer parse\n where \n parse _ = do\n return SetQueueAttributesResponse {}\n \n-- | ServiceConfiguration: 'SqsConfiguration'\ninstance SignQuery SetQueueAttributes where \n type ServiceConfiguration SetQueueAttributes = SqsConfiguration\n signQuery SetQueueAttributes {..} = sqsSignQuery SqsQuery { \n sqsQueueName = Just sqaQueueName,\n sqsQuery = [(\"Action\", Just \"SetQueueAttributes\"), \n (\"Attribute.Name\", Just $ TE.encodeUtf8 $ printQueueAttribute sqaAttribute),\n (\"Attribute.Value\", Just $ TE.encodeUtf8 sqaValue)]} \n\ninstance Transaction SetQueueAttributes SetQueueAttributesResponse\n\ninstance AsMemoryResponse SetQueueAttributesResponse where\n type MemoryResponse SetQueueAttributesResponse = SetQueueAttributesResponse\n loadToMemory = return\n" }, { "path": "Aws/Sqs/Commands.hs", "content": "module Aws.Sqs.Commands (\n module Aws.Sqs.Commands.Message,\n module Aws.Sqs.Commands.Permission,\n module Aws.Sqs.Commands.Queue,\n module Aws.Sqs.Commands.QueueAttributes\n) where\n\nimport Aws.Sqs.Commands.Message\nimport Aws.Sqs.Commands.Permission\nimport Aws.Sqs.Commands.Queue\nimport Aws.Sqs.Commands.QueueAttributes\n" }, { "path": "Aws/Sqs/Core.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Aws.Sqs.Core where\n\nimport Aws.Core\nimport Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationUsWest2, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationEu, locationEuWest2)\nimport qualified Blaze.ByteString.Builder as Blaze\nimport qualified Blaze.ByteString.Builder.Char8 as Blaze8\nimport qualified Control.Exception as C\nimport Control.Monad\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Resource (MonadThrow, throwM)\nimport qualified Data.ByteString as B\nimport qualified Data.ByteString.Char8 as BC\nimport qualified Data.Conduit\nimport Data.Conduit ((.|))\nimport Data.IORef\nimport Data.List\nimport Data.Maybe\nimport Data.Monoid\nimport qualified Data.Semigroup as Sem\nimport Data.Ord\nimport qualified Data.Text as T\nimport qualified Data.Text.Encoding as T\nimport qualified Data.Text.Encoding as TE\nimport Data.Time\nimport Data.Typeable\nimport Prelude\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\n#if !MIN_VERSION_time(1,5,0)\nimport System.Locale\n#endif\nimport qualified Text.XML as XML\nimport Text.XML.Cursor (($/))\nimport qualified Text.XML.Cursor as Cu\n\ntype ErrorCode = T.Text\n\ndata SqsError\n = SqsError {\n sqsStatusCode :: HTTP.Status\n , sqsErrorCode :: ErrorCode\n , sqsErrorType :: T.Text\n , sqsErrorMessage :: T.Text\n , sqsErrorDetail :: Maybe T.Text\n , sqsErrorMetadata :: Maybe SqsMetadata\n }\n | SqsXmlError { \n sqsXmlErrorMessage :: T.Text\n , sqsXmlErrorMetadata :: Maybe SqsMetadata\n }\n deriving (Show, Typeable)\n\ninstance C.Exception SqsError\n\ndata SqsMetadata\n = SqsMetadata {\n sqsMAmzId2 :: Maybe T.Text\n , sqsMRequestId :: Maybe T.Text\n }\n deriving (Show)\n\ninstance Loggable SqsMetadata where\n toLogText (SqsMetadata id2 rid) = \"SQS: request ID=\" `mappend`\n fromMaybe \"\" rid `mappend`\n \", x-amz-id-2=\" `mappend`\n fromMaybe \"\" id2\n\ninstance Sem.Semigroup SqsMetadata where\n SqsMetadata a1 r1 <> SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2)\n\ninstance Monoid SqsMetadata where\n mempty = SqsMetadata Nothing Nothing\n mappend = (Sem.<>)\n\ndata SqsAuthorization \n = SqsAuthorizationHeader \n | SqsAuthorizationQuery\n deriving (Show)\n\ndata Endpoint\n = Endpoint {\n endpointHost :: B.ByteString\n , endpointDefaultLocationConstraint :: LocationConstraint\n , endpointAllowedLocationConstraints :: [LocationConstraint]\n }\n deriving (Show)\n\ndata SqsConfiguration qt\n = SqsConfiguration {\n sqsProtocol :: Protocol\n , sqsEndpoint :: Endpoint\n , sqsPort :: Int\n , sqsUseUri :: Bool\n , sqsDefaultExpiry :: NominalDiffTime\n }\n deriving (Show)\n\ninstance DefaultServiceConfiguration (SqsConfiguration NormalQuery) where\n defServiceConfig = sqs HTTPS sqsEndpointUsClassic False\n debugServiceConfig = sqs HTTP sqsEndpointUsClassic False\n\ninstance DefaultServiceConfiguration (SqsConfiguration UriOnlyQuery) where\n defServiceConfig = sqs HTTPS sqsEndpointUsClassic True\n debugServiceConfig = sqs HTTP sqsEndpointUsClassic True\n \nsqsEndpointUsClassic :: Endpoint\nsqsEndpointUsClassic \n = Endpoint { \n endpointHost = \"queue.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationUsClassic\n , endpointAllowedLocationConstraints = [locationUsClassic\n , locationUsWest\n , locationEu\n , locationApSouthEast\n , locationApNorthEast]\n }\n\nsqsEndpointUsWest :: Endpoint\nsqsEndpointUsWest\n = Endpoint {\n endpointHost = \"us-west-1.queue.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationUsWest\n , endpointAllowedLocationConstraints = [locationUsWest]\n }\n\nsqsEndpointUsWest2 :: Endpoint\nsqsEndpointUsWest2\n = Endpoint {\n endpointHost = \"us-west-2.queue.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationUsWest2\n , endpointAllowedLocationConstraints = [locationUsWest2]\n }\n\nsqsEndpointEu :: Endpoint\nsqsEndpointEu\n = Endpoint {\n endpointHost = \"eu-west-1.queue.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationEu\n , endpointAllowedLocationConstraints = [locationEu]\n }\n\nsqsEndpointEuWest2 :: Endpoint\nsqsEndpointEuWest2\n = Endpoint {\n endpointHost = \"eu-west-2.queue.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationEuWest2\n , endpointAllowedLocationConstraints = [locationEuWest2]\n }\n\nsqsEndpointApSouthEast :: Endpoint\nsqsEndpointApSouthEast\n = Endpoint {\n endpointHost = \"ap-southeast-1.queue.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationApSouthEast\n , endpointAllowedLocationConstraints = [locationApSouthEast]\n }\n\nsqsEndpointApSouthEast2 :: Endpoint\nsqsEndpointApSouthEast2\n = Endpoint {\n endpointHost = \"sqs.ap-southeast-2.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationApSouthEast2\n , endpointAllowedLocationConstraints = [locationApSouthEast2]\n }\n\nsqsEndpointApNorthEast :: Endpoint\nsqsEndpointApNorthEast\n = Endpoint {\n endpointHost = \"sqs.ap-northeast-1.amazonaws.com\"\n , endpointDefaultLocationConstraint = locationApNorthEast\n , endpointAllowedLocationConstraints = [locationApNorthEast]\n }\n\nsqs :: Protocol -> Endpoint -> Bool -> SqsConfiguration qt\nsqs protocol endpoint uri \n = SqsConfiguration { \n sqsProtocol = protocol\n , sqsEndpoint = endpoint\n , sqsPort = defaultPort protocol\n , sqsUseUri = uri\n , sqsDefaultExpiry = 15*60\n }\n\ndata SqsQuery = SqsQuery{\n sqsQueueName :: Maybe QueueName,\n sqsQuery :: HTTP.Query\n}\n\nsqsSignQuery :: SqsQuery -> SqsConfiguration qt -> SignatureData -> SignedQuery\nsqsSignQuery SqsQuery{..} SqsConfiguration{..} SignatureData{..}\n = SignedQuery {\n sqMethod = method\n , sqProtocol = sqsProtocol\n , sqHost = endpointHost sqsEndpoint\n , sqPort = sqsPort\n , sqPath = path\n , sqQuery = signedQuery\n , sqDate = Just signatureTime\n , sqAuthorization = Nothing \n , sqBody = Nothing\n , sqStringToSign = stringToSign\n , sqContentType = Nothing\n , sqContentMd5 = Nothing\n , sqAmzHeaders = []\n , sqOtherHeaders = []\n }\n where\n method = PostQuery\n path = case sqsQueueName of\n Just x -> TE.encodeUtf8 $ printQueueName x\n Nothing -> \"/\"\n expandedQuery = sortBy (comparing fst) \n ( sqsQuery ++ [ (\"AWSAccessKeyId\", Just(accessKeyID signatureCredentials)), \n (\"Expires\", Just(BC.pack expiresString)), \n (\"SignatureMethod\", Just(\"HmacSHA256\")), (\"SignatureVersion\",Just(\"2\")), (\"Version\",Just(\"2012-11-05\"))] ++\n maybe [] (\\tok -> [(\"SecurityToken\", Just tok)]) (iamToken signatureCredentials))\n\n expires = AbsoluteExpires $ sqsDefaultExpiry `addUTCTime` signatureTime\n\n expiresString = formatTime defaultTimeLocale \"%FT%TZ\" (fromAbsoluteTimeInfo expires)\n\n sig = signature signatureCredentials HmacSHA256 stringToSign\n stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\\n') . concat $\n [[Blaze.copyByteString $ httpMethod method]\n , [Blaze.copyByteString $ endpointHost sqsEndpoint]\n , [Blaze.copyByteString path]\n , [Blaze.copyByteString $ HTTP.renderQuery False expandedQuery ]]\n\n signedQuery = expandedQuery ++ (HTTP.simpleQueryToQuery $ makeAuthQuery)\n\n makeAuthQuery = [(\"Signature\", sig)]\n\nsqsResponseConsumer :: HTTPResponseConsumer a\n -> IORef SqsMetadata\n -> HTTPResponseConsumer a\nsqsResponseConsumer inner metadata resp = do\n let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)\n let amzId2 = headerString \"x-amz-id-2\"\n let requestId = headerString \"x-amz-request-id\"\n\n let m = SqsMetadata { sqsMAmzId2 = amzId2, sqsMRequestId = requestId }\n liftIO $ tellMetadataRef metadata m\n\n if HTTP.responseStatus resp >= HTTP.status400\n then sqsErrorResponseConsumer resp\n else inner resp\n\nsqsXmlResponseConsumer :: (Cu.Cursor -> Response SqsMetadata a)\n -> IORef SqsMetadata\n -> HTTPResponseConsumer a\nsqsXmlResponseConsumer parse metadataRef = sqsResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef\n\nsqsErrorResponseConsumer :: HTTPResponseConsumer a\nsqsErrorResponseConsumer resp\n = do doc <- Data.Conduit.runConduit $ HTTP.responseBody resp .| XML.sinkDoc XML.def\n let cursor = Cu.fromDocument doc\n liftIO $ case parseError cursor of\n Right err -> throwM err\n Left otherErr -> throwM otherErr\n where\n parseError :: Cu.Cursor -> Either C.SomeException SqsError\n parseError root = do cursor <- force \"Missing Error\" $ root $/ Cu.laxElement \"Error\"\n code <- force \"Missing error Code\" $ cursor $/ elContent \"Code\"\n message <- force \"Missing error Message\" $ cursor $/ elContent \"Message\"\n errorType <- force \"Missing error Type\" $ cursor $/ elContent \"Type\"\n let detail = listToMaybe $ cursor $/ elContent \"Detail\"\n\n return SqsError {\n sqsStatusCode = HTTP.responseStatus resp\n , sqsErrorCode = code\n , sqsErrorMessage = message\n , sqsErrorType = errorType\n , sqsErrorDetail = detail\n , sqsErrorMetadata = Nothing\n }\n\ndata QueueName = QueueName{\n qName :: T.Text,\n qAccountNumber :: T.Text\n} deriving(Show, Read, Eq, Ord)\n\nprintQueueName :: QueueName -> T.Text\nprintQueueName queue = T.concat [\"/\", (qAccountNumber queue), \"/\", (qName queue), \"/\"]\n\ndata QueueAttribute\n = QueueAll\n | ApproximateNumberOfMessages\n | ApproximateNumberOfMessagesNotVisible\n | VisibilityTimeout\n | CreatedTimestamp\n | LastModifiedTimestamp\n | Policy\n | MaximumMessageSize\n | MessageRetentionPeriod\n | QueueArn\n deriving(Show, Enum, Eq)\n\ndata MessageAttribute\n = MessageAll\n -- ^ all values\n | SenderId\n -- ^ the AWS account number (or the IP address, if anonymous access is\n -- allowed) of the sender\n | SentTimestamp\n -- ^ the time when the message was sent (epoch time in milliseconds)\n | ApproximateReceiveCount\n -- ^ the number of times a message has been received but not deleted\n | ApproximateFirstReceiveTimestamp\n -- ^ the time when the message was first received (epoch time in\n -- milliseconds)\n deriving(Show,Read,Eq,Ord,Enum,Bounded)\n\ndata SqsPermission\n = PermissionAll\n | PermissionSendMessage\n | PermissionReceiveMessage\n | PermissionDeleteMessage\n | PermissionChangeMessageVisibility\n | PermissionGetQueueAttributes\n deriving (Show, Enum, Eq)\n\nparseQueueAttribute :: MonadThrow m => T.Text -> m QueueAttribute\nparseQueueAttribute \"ApproximateNumberOfMessages\" = return ApproximateNumberOfMessages \nparseQueueAttribute \"ApproximateNumberOfMessagesNotVisible\" = return ApproximateNumberOfMessagesNotVisible\nparseQueueAttribute \"VisibilityTimeout\" = return VisibilityTimeout\nparseQueueAttribute \"CreatedTimestamp\" = return CreatedTimestamp\nparseQueueAttribute \"LastModifiedTimestamp\" = return LastModifiedTimestamp\nparseQueueAttribute \"Policy\" = return Policy\nparseQueueAttribute \"MaximumMessageSize\" = return MaximumMessageSize\nparseQueueAttribute \"MessageRetentionPeriod\" = return MessageRetentionPeriod\nparseQueueAttribute \"QueueArn\" = return QueueArn\nparseQueueAttribute x = throwM $ XmlException ( \"Invalid Attribute Name. \" ++ show x)\n\nprintQueueAttribute :: QueueAttribute -> T.Text\nprintQueueAttribute QueueAll = \"All\"\nprintQueueAttribute ApproximateNumberOfMessages = \"ApproximateNumberOfMessages\"\nprintQueueAttribute ApproximateNumberOfMessagesNotVisible = \"ApproximateNumberOfMessagesNotVisible\"\nprintQueueAttribute VisibilityTimeout = \"VisibilityTimeout\"\nprintQueueAttribute CreatedTimestamp = \"CreatedTimestamp\"\nprintQueueAttribute LastModifiedTimestamp = \"LastModifiedTimestamp\"\nprintQueueAttribute Policy = \"Policy\"\nprintQueueAttribute MaximumMessageSize = \"MaximumMessageSize\"\nprintQueueAttribute MessageRetentionPeriod = \"MessageRetentionPeriod\"\nprintQueueAttribute QueueArn = \"QueueArn\"\n\nparseMessageAttribute :: MonadThrow m => T.Text -> m MessageAttribute\nparseMessageAttribute \"SenderId\" = return SenderId\nparseMessageAttribute \"SentTimestamp\" = return SentTimestamp\nparseMessageAttribute \"ApproximateReceiveCount\" = return ApproximateReceiveCount\nparseMessageAttribute \"ApproximateFirstReceiveTimestamp\" = return ApproximateFirstReceiveTimestamp\nparseMessageAttribute x = throwM $ XmlException ( \"Invalid Attribute Name. \" ++ show x)\n\nprintMessageAttribute :: MessageAttribute -> T.Text\nprintMessageAttribute MessageAll = \"All\"\nprintMessageAttribute SenderId = \"SenderId\"\nprintMessageAttribute SentTimestamp = \"SentTimestamp\"\nprintMessageAttribute ApproximateReceiveCount = \"ApproximateReceiveCount\"\nprintMessageAttribute ApproximateFirstReceiveTimestamp = \"ApproximateFirstReceiveTimestamp\"\n\nprintPermission :: SqsPermission -> T.Text\nprintPermission PermissionAll = \"*\"\nprintPermission PermissionSendMessage = \"SendMessage\"\nprintPermission PermissionReceiveMessage = \"ReceiveMessage\"\nprintPermission PermissionDeleteMessage = \"DeleteMessage\"\nprintPermission PermissionChangeMessageVisibility = \"ChangeMessageVisibility\"\nprintPermission PermissionGetQueueAttributes = \"GetQueueAttributes\"\n\nnewtype ReceiptHandle = ReceiptHandle T.Text deriving(Show, Read, Eq, Ord)\nnewtype MessageId = MessageId T.Text deriving(Show, Read, Eq, Ord)\n\nprintReceiptHandle :: ReceiptHandle -> T.Text\nprintReceiptHandle (ReceiptHandle handle) = handle \n" }, { "path": "Aws/Sqs.hs", "content": "module Aws.Sqs\n(\n module Aws.Sqs.Commands\n, module Aws.Sqs.Core\n)\nwhere\n\nimport Aws.Sqs.Commands\nimport Aws.Sqs.Core\n" }, { "path": "Aws.hs", "content": "module Aws\n( -- * Logging\n LogLevel(..)\n, Logger\n, defaultLog\n -- * Configuration\n, Configuration(..)\n, baseConfiguration\n, dbgConfiguration\n -- * Transaction runners\n -- ** Safe runners\n, aws\n, awsRef\n, pureAws\n, simpleAws\n -- ** Unsafe runners\n, unsafeAws\n, unsafeAwsRef\n -- ** URI runners\n, awsUri\n -- ** Iterated runners\n--, awsIteratedAll\n, awsIteratedSource\n, awsIteratedList\n -- * Response\n -- ** Full HTTP response\n, HTTPResponseConsumer\n -- ** Metadata in responses\n, Response(..)\n, readResponse\n, readResponseIO\n, ResponseMetadata\n -- ** Memory responses\n, AsMemoryResponse(..)\n -- ** Exception types\n, XmlException(..)\n, HeaderException(..)\n, FormException(..)\n -- * Query\n -- ** Service configuration\n, ServiceConfiguration\n, DefaultServiceConfiguration(..)\n, NormalQuery\n, UriOnlyQuery\n -- ** Expiration\n, TimeInfo(..)\n -- * Transactions\n, Transaction\n, IteratedTransaction\n -- * Credentials\n, Credentials(..)\n, makeCredentials\n, credentialsDefaultFile\n, credentialsDefaultKey\n, loadCredentialsFromFile\n, loadCredentialsFromEnv\n, loadCredentialsFromInstanceMetadata\n, loadCredentialsFromEnvOrFile\n, loadCredentialsFromEnvOrFileOrInstanceMetadata\n, loadCredentialsDefault\n, anonymousCredentials\n)\nwhere\n\nimport Aws.Aws\nimport Aws.Core\n" }, { "path": "CHANGELOG.md", "content": "0.25 series\n-----------\n\nNOTES: 0.25 brings technically breaking changes, which should not affect\nmost users. I recommend using smart constructors and {} matching syntax\nwhenever possible when interacting with aws types.\n\n- 0.25.2\n - S3: Add RestoreObject command\n- 0.25.1\n - S3: Make getBucket support Google Object Storage, which does\n not include StorageClass in its response, by defaulting to Standard.\n- 0.25\n - [breaking change] Added poTagging constructor to PutObject\n - Switch from no longer maintained cryptonite to crypton.\n - Removed support for building with network-2.x, and removed the\n NetworkBSD build flag.\n\n0.24 series\n-----------\n\nNOTES: 0.24 brings technically breaking changes, which should not affect\nmost users. I recommend using smart constructors and {} matching syntax\nwhenever possible when interacting with aws types.\n\n- 0.24.4\n - Support filepath 1.5\n - Support data-default 0.8\n- 0.24.3\n - [breaking change] Added s3UserAgent constructor to S3Configuration\n - S3: Add GetBucketVersioning command\n- 0.24.2\n - Support bytestring 0.12\n - Support building with aeson 2.2, adding dependency on\n attoparsec-json.\n- 0.24.1\n - Support resourcet 1.3\n - Support transformers 0.6\n- 0.24\n - [breaking change] Added s3Region constructor to S3Configuration, to\n support custom S3 regions.\n - Fixed several build warnings.\n - Needs base-4.9 or newer.\n\n0.23 series\n-----------\n\nNOTES: 0.23 brings technically breaking changes, which should not affect\nmost users. I recommend using smart constructors and {} matching syntax\nwhenever possible when interacting with aws types.\n\n- 0.23\n - Support anonymous access of S3 buckets.\n - [breaking change] added isAnonymousCredentials to Credentials.\n - Support bytestring 0.11\n\n0.22 series\n-----------\n\n- 0.22.1\n - Update to aeson-2\n - Support http-client 0.7\n - Support base64-bytestring 1.2\n - Support attoparsec 0.14\n - Support base16-bytestring 1.0\n- 0.22\n - Support GHC 8.8\n - Support network-3\n - Support http-client 0.6+\n - S3: add etag to PutObjectResponse\n - Add IAM group manipulation methods\n\n0.21 series\n-----------\n\n- 0.21.1\n - S3: Add PutBucketVersioning command\n\n- 0.21\n - S3: Make user DisplayName field optional (used in \"GetBucket\"\n among other places)\n - Use HTTP.getGlobalManager from http-client-tls by default (more\n efficient, and we have a transitive dependency on the package\n anyways)\n\n0.20 series\n-----------\n\n- 0.20\n - Update to conduit 1.3 and http-conduit 2.3 (breaking API change\n due to removal of ResumableSource, which was used in public APIs)\n - S3: Fix to V2 string signing\n\n0.19 series\n-----------\n\n- 0.19\n - Experimental support for V4 signing\n - Add \"eu-west-2\" endpoint for some services\n - Loosen http-conduit bounds\n\n0.18 series\n-----------\n\n- 0.18\n - Switch from cryptohash to cryptonite\n - Loosen boundaries for http-types and conduit-extra\n\n0.17 series\n-----------\n\n- 0.17.1\n - Fix testsuite build\n\n- 0.17\n - HTTP proxy support\n - DDB: Support for additional interfaces, bug fixes\n - Relax version bounds\n\n0.16 series\n-----------\n\nNOTES: 0.16 brings technically breaking changes, which should not affect\nmost users. I recommend using smart constructors and {} matching syntax\nwhenever possible when interacting with aws types.\n\n- 0.16\n - S3: Add support for versioning\n - S3: [breaking change] Move version ID from UploadPartResponse to\n CompleteMultipartUpload.\n\n0.15 series\n-----------\n\nNOTES: 0.15 brings technically breaking changes, but should not affect\nmost users.\n\n- 0.15.1\n - Support xml-conduit 1.4\n\n- 0.15\n - Drop support for time <1.5\n - Support http-client 2.2\n - Support directory 1.3\n - Add upper bound on http-client in testsuite\n - DynamoDB: Eliminate orphan instance that conflicted with aeson-1.0\n - S3: Don't URI encode response header override query params when signing\n - Use HTTP.newManager instead of deprecated HTTP.withManager\n - Signing: Change date format from space-padding to zero-padding\n\n0.14 series\n-----------\n\nNOTES: 0.14 brings potentially breaking changes\n\n- 0.14\n - transformers 0.5 support\n - data-default 0.6 support (also in 0.13.1)\n - time < 2.0 support\n - General: Use `AWS_SESSION_TOKEN` if in environment for loading credentials\n - General: loadCredentialsDefault fails gracefully if HOME is not set\n - DDB: Add parseAttr combinator for parsing an attribute into a FromDynItem\n - DDB: Expose the new DynBool type\n - S3: Add ETag fields to get/head object\n\n0.13 series\n-----------\n\nNOTE: 0.13 brings breaking changes compared to 0.12.1!\n\n- 0.13.1\n - data-default 0.6 support\n- 0.13\n - DDB: Add support for scanning an index\n - DDB: Allow deleting an attribute on update\n - DDB: !BREAKING! Add support for native boolean values\n via \"Bool\". Can read old values, and there's a compatibility\n wrapper OldBool that behaves exactly the same way it used to.\n - DDB: Add support for Null, L (list) and M (map) data types.\n - DDB: Support consistent reads in Scan requests\n - IAM: Add list-mfa-devices command\n - S3: Extend StorageClass to support arbitrary classes, and\n StandardInfrequentAccess\n - S3: Add a Sink interface for multipart uploading\n - S3: Performance improvement for chunkedConduit\n - S3: Partial support for Google Nearline\n\n0.12 series\n-----------\n\n- 0.12.1\n - DDB: Fix eu-west-1, add eu-central-1\n - attoparsec 0.13\n - xml-conduit 1.3\n- 0.12\n - S3: Support for \"Expect: 100-continue\" (optional, technically\n API breaking)\n - S3: Properly treat errors with a \"301 Permanent Redirect\" as\n errors and expose endpoint information\n\n0.11 series\n-----------\n\n- 0.11.4\n - Url-encode S3 object names in URLs\n - filepath 1.4\n - tagged 0.8.x\n - limit errors to <2 to avoid compatibility problems\n- 0.11.3\n - Support for blaze-builder 0.4\n - Support for utf8-string 1.0\n - New function: multipartUploadWithInitiator\n - Fix issue in DynamoDB error parsing\n - Ord instance for Aws.Core.Method\n- 0.11.2\n - Support for time 1.5 (we previously forgot to relax the upper\n bound in Cabal)\n- 0.11.1\n - Support time 1.5\n - Fix duplicate sending of query when using PostQuery\n- 0.11\n - New functions for running AWS transactions\n - Performance optimizations for DynamoDB and S3 MultiPartUpload\n - New DynamoDB commands & features\n - S3 endpoint eu-central-1\n\n0.10 series\n-----------\n\n- 0.10.5\n - support for conduit 1.2\n- 0.10.4\n - S3: support for multi-part uploads\n - DynamoDB: fixes for JSON serialization WARNING: This includes\n making some fields in TableDescription Maybe fields, which\n is breaking. But DynamoDB support was and is also marked\n as EXPERIMENTAL.\n - DynamoDB: TCP connection reuse where possible\n (improving performance)\n - DynamoDB: Added test suite\n - SES: support for additional regions\n- 0.10.3\n - fix bug introduced in 0.10.2 that broke SQS and IAM connections\n without STS\n- 0.10.2\n - support STS / IAM temporary credentials in all services\n- 0.10\n - \\[EXPERIMENTAL!\\] DynamoDB: support for\n creating/updating/querying and scanning items\n - SQS: complete overhaul to support 2012-11-05 features\n - SQS: test suite\n - S3: use Maybe for 404 HEAD requests on objects instead of\n throwing a misleading exception\n - S3: support of poAutoMakeBucket for Internet Archive users\n - S3: implement GetBucketLocation\n - S3: add South American region\n - S3: allow specifying the Content-Type when copying objects\n - core: fix typo in NoCredentialsException accessor\n\n0.9 series\n----------\n\n- 0.9.4\n - allow conduit 1.2\n- 0.9.3\n - fix performance regression for loadCredentialsDefault\n - add generic makeCredentials function\n - add S3 DeleteBucket operation\n - add S3 NukeBucket example\n - SES: use security token if enabled (should allow using it with\n IAM roles on EC2 instances)\n- 0.9.2\n - Support for credentials from EC2 instance metadata (only S3\n for now)\n - aeson 0.8 compatibility\n- 0.9.1\n - Support for multi-page S3 GetBucket requests\n - S3 GLACIER support\n - Applicative instance for Response to conform to the\n Applicative-Monad Proposal\n - Compatibility with transformers 0.4\n- 0.9\n - Interface changes:\n - attempt and failure were deprecated, remove\n - switch to new cryptohash interface\n - updated version bounds of conduit and xml-conduit\n\n0.8 series\n----------\n\n- 0.8.6\n - move Instance metadata functions out of ResourceT to remove\n problem with exceptions-0.5 (this makes a fresh install of aws\n on a clean system possible again)\n- 0.8.5\n - compatibility with case-insensitive 1.2\n - support for V4 signatures\n - experimental support for DynamoDB\n- 0.8.4\n - compatibility with http-conduit 2.0\n- 0.8.3\n - compatibility with cryptohash 0.11\n - experimental IAM support\n- 0.8.2\n - compatibility with cereal 0.4.x\n- 0.8.1\n - compatibility with case-insensitive 1.1\n- 0.8.0\n - S3, SQS: support for US-West2 (\\#58)\n - S3: GetObject now has support for Content-Range (\\#22, \\#50)\n - S3: GetBucket now supports the \"IsTruncated\" flag (\\#39)\n - S3: PutObject now supports web page redirects (\\#46)\n - S3: support for (multi-object) DeleteObjects (\\#47, \\#56)\n - S3: HeadObject now uses an actual HEAD request (\\#53)\n - S3: fixed signing issues for GetObject call (\\#54)\n - SES: support for many more operations (\\#65, \\#66, \\#70, \\#71,\n \\#72, \\#74)\n - SES: SendRawEmail now correctly encodes destinations and allows\n multiple destinations (\\#73)\n - EC2: support for Instance metadata (\\#37)\n - Core: queryToHttpRequest allows overriding \"Date\" for the\n benefit of Chris Dornan's Elastic Transcoder bindings (\\#77)\n\n0.7 series\n----------\n\n- 0.7.6.4\n - CryptoHash update\n- 0.7.6.3\n - In addition to supporting http-conduit 1.9, it would seem nice\n to support conduit 1.0. Previously slipped through the radar.\n- 0.7.6.2\n - Support for http-conduit 1.9\n- 0.7.6.1\n - Support for case-insensitive 1.0 and http-types 0.8\n- 0.7.6\n - Parsing of SimpleDB error responses was too strict, fixed\n - Support for cryptohash 0.8\n - Failure 0.1 does not work with aws, stricter lower bound\n- 0.7.5\n - Support for http-conduit 1.7 and 1.8\n- 0.7.1-0.7.4\n - Support for GHC 7.6\n - Wider constraints to support newer versions of various\n dependencies\n - Update maintainer e-mail address and project categories in cabal\n file\n- 0.7.0\n - Change ServiceConfiguration concept so as to indicate in the\n type whether this is for URI-only requests (i.e. awsUri)\n - EXPERIMENTAL: Direct support for iterated transaction, i.e. such\n where multiple HTTP requests might be necessary due to e.g.\n response size limits.\n - Put aws functions in ResourceT to be able to safely return\n Sources and streams.\n - simpleAws\\* does not require ResourceT and converts streams\n into memory values (like ByteStrings) first.\n - Log response metadata (level Info), and do not let all aws\n runners return it.\n - S3:\n - GetObject: No longer require a response consumer in the\n request, return the HTTP response (with the body as\n a stream) instead.\n - Add CopyObject (PUT Object Copy) request type.\n - Add Examples cabal flag for building code examples.\n - Many more, small improvements.\n\n0.6 series\n----------\n\n- 0.6.2\n - Properly parse Last-Modified header in accordance with RFC 2616.\n- 0.6.1\n - Fix for MD5 encoding issue in S3 PutObject requests.\n- 0.6.0\n - API Cleanup\n - General: Use Crypto.Hash.MD5.MD5 when a Content-MD5 hash is\n required, instead of ByteString.\n - S3: Made parameter order to S3.putObject consistent\n with S3.getObject.\n - Updated dependencies:\n - conduit 0.5 (as well as http-conduit 1.5 and\n xml-conduit 1.0).\n - http-types 0.7.\n - Minor changes.\n - Internal changes (notable for people who want to add more\n commands):\n - http-types' new 'QueryLike' interface allows creating query\n lists more conveniently.\n\n0.5 series\n----------\n\n0.5.0\n\n: New configuration system: configuration split into general and\n service-specific parts.\n\n Significantly improved API reference documentation.\n\n Re-organised modules to make library easier to understand.\n\n Smaller improvements.\n\n0.4 series\n----------\n\n0.4.1\n: Documentation improvements.\n\n0.4.0.1\n: Change dependency bounds to allow the transformers 0.3 package.\n\n0.4.0\n: Update conduit to 0.4.0, which is incompatible with\n earlier versions.\n\n0.3 series\n----------\n\n0.3.2\n: Add awsRef / simpleAwsRef request variants for those who prefer an\n `IORef` over a `Data.Attempt.Attempt` value. Also improve README and\n add simple example.\n\n\n" }, { "path": "Examples/DynamoDb.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE FlexibleContexts #-}\n\nmodule Main where\n\n-------------------------------------------------------------------------------\nimport Aws\nimport Aws.DynamoDb.Commands\nimport Aws.DynamoDb.Core\nimport Control.Concurrent\nimport Control.Monad\nimport Control.Monad.Catch\nimport Control.Monad.Trans.Resource\nimport Control.Applicative\nimport Data.Conduit\nimport Data.Maybe\nimport qualified Data.Conduit.List as C\nimport qualified Data.Text as T\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings)\n-------------------------------------------------------------------------------\n\ncreateTableAndWait :: IO ()\ncreateTableAndWait = do\n let req0 = createTable \"devel-1\"\n [AttributeDefinition \"name\" AttrString]\n (HashOnly \"name\")\n (ProvisionedThroughput 1 1)\n resp0 <- runCommand req0\n print resp0\n\n print \"Waiting for table to be created\"\n threadDelay (30 * 1000000)\n\n let req1 = DescribeTable \"devel-1\"\n resp1 <- runCommand req1\n print resp1\n\ndata ExampleItem = ExampleItem {\n name :: T.Text\n , class_ :: T.Text\n , boolAttr :: Bool\n , oldBoolAttr :: Bool\n }\n deriving (Show)\n\ninstance ToDynItem ExampleItem where\n toItem (ExampleItem name class_ boolAttr oldBoolAttr) =\n item [ attr \"name\" name\n , attr \"class\" class_\n , attr \"boolattr\" boolAttr\n , attr \"oldboolattr\" (OldBool oldBoolAttr)\n ]\n\ninstance FromDynItem ExampleItem where\n parseItem x = ExampleItem <$> getAttr \"name\" x <*> getAttr \"class\" x <*> getAttr \"boolattr\" x <*> getAttr \"oldboolattr\" x\n\nmain :: IO ()\nmain = do\n cfg <- Aws.baseConfiguration\n\n createTableAndWait `catch` (\\DdbError{} -> putStrLn \"Table already exists\")\n\n putStrLn \"Putting an item...\"\n\n let x = ExampleItem { name = \"josh\", class_ = \"not-so-awesome\",\n boolAttr = False, oldBoolAttr = True }\n\n let req1 = (putItem \"devel-1\" (toItem x)) { piReturn = URAllOld\n , piRetCons = RCTotal\n , piRetMet = RICMSize\n }\n\n\n resp1 <- runCommand req1\n print resp1\n\n putStrLn \"Getting the item back...\"\n\n let req2 = getItem \"devel-1\" (hk \"name\" \"josh\")\n resp2 <- runCommand req2\n print resp2\n\n let y = fromItem (fromMaybe (item []) $ girItem resp2) :: Either String ExampleItem\n print y\n\n print =<< runCommand\n (updateItem \"devel-1\" (hk \"name\" \"josh\") [au (Attribute \"class\" \"awesome\")])\n\n echo \"Updating with false conditional.\"\n (print =<< runCommand\n (updateItem \"devel-1\" (hk \"name\" \"josh\") [au (Attribute \"class\" \"awesomer\")])\n { uiExpect = Conditions CondAnd [Condition \"name\" (DEq \"john\")] })\n `catch` (\\ (e :: DdbError) -> echo (\"Eating exception: \" ++ show e))\n\n echo \"Getting the item back...\"\n print =<< runCommand req2\n\n\n echo \"Updating with true conditional\"\n print =<< runCommand\n (updateItem \"devel-1\" (hk \"name\" \"josh\") [au (Attribute \"class\" \"awesomer\"), au (attr \"oldboolattr\" False)])\n { uiExpect = Conditions CondAnd [Condition \"name\" (DEq \"josh\")] }\n\n echo \"Getting the item back...\"\n print =<< runCommand req2\n\n echo \"Running a Query command...\"\n print =<< runCommand (query \"devel-1\" (Slice (Attribute \"name\" \"josh\") Nothing))\n\n echo \"Running a Scan command...\"\n print =<< runCommand (scan \"devel-1\")\n\n echo \"Filling table with several items...\"\n forM_ [0..30] $ \\ i -> do\n threadDelay 50000\n runCommand $ putItem \"devel-1\" $\n item [Attribute \"name\" (toValue $ T.pack (\"lots-\" ++ show i)), attrAs int \"val\" i]\n\n echo \"Now paginating in increments of 5...\"\n let q0 = (scan \"devel-1\") { sLimit = Just 5 }\n\n mgr <- newManager tlsManagerSettings\n xs <- runResourceT $ awsIteratedList cfg debugServiceConfig mgr q0 `connect` C.consume\n echo (\"Pagination returned \" ++ show (length xs) ++ \" items\")\n\n\nrunCommand r = do\n cfg <- Aws.baseConfiguration\n Aws.simpleAws cfg debugServiceConfig r\n\necho = putStrLn\n\n\n" }, { "path": "Examples/GetObject.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.S3 as S3\nimport Control.Monad.Trans.Resource\nimport Data.Conduit ((.|), runConduit)\nimport Data.Conduit.Binary (sinkFile)\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)\n\nmain :: IO ()\nmain = do\n {- Set up AWS credentials and the default configuration. -}\n cfg <- Aws.baseConfiguration\n let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery\n\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n {- Create a request object with S3.getObject and run the request with pureAws. -}\n S3.GetObjectResponse { S3.gorResponse = rsp } <-\n Aws.pureAws cfg s3cfg mgr $\n S3.getObject \"haskell-aws\" \"cloud-remote.pdf\"\n\n {- Save the response to a file. -}\n runConduit $ responseBody rsp .| sinkFile \"cloud-remote.pdf\"\n" }, { "path": "Examples/GetObjectGoogle.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.Core as Aws\nimport qualified Aws.S3 as S3\nimport Control.Monad.Trans.Resource\nimport Data.Conduit ((.|), runConduit)\nimport Data.Conduit.Binary (sinkFile)\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)\n\nmain :: IO ()\nmain = do\n Just creds <- Aws.loadCredentialsFromEnv\n let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing\n let s3cfg = S3.s3 Aws.HTTP \"storage.googleapis.com\" False\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n {- Create a request object with S3.getObject and run the request with pureAws. -}\n S3.GetObjectResponse { S3.gorResponse = rsp } <-\n Aws.pureAws cfg s3cfg mgr $\n {- Public bucket from GCP examples -}\n S3.getObject \"uspto-pair\" \"applications/05900016.zip\"\n\n {- Save the response to a file. -}\n runConduit $ responseBody rsp .| sinkFile \"getobject-test.zip\"\n" }, { "path": "Examples/GetObjectV4.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.Core as Aws\nimport qualified Aws.S3 as S3\nimport Control.Monad.Trans.Resource\nimport Data.Conduit ((.|), runConduit)\nimport Data.Conduit.Binary (sinkFile)\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)\n\nmain :: IO ()\nmain = do\n {- Set up AWS credentials and the default configuration. -}\n Just creds <- Aws.loadCredentialsDefault\n let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing\n let s3cfg = S3.s3v4 Aws.HTTP \"s3.amazonaws.com\" False S3.SignWithEffort\n\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n {- Create a request object with S3.getObject and run the request with pureAws. -}\n S3.GetObjectResponse { S3.gorResponse = rsp } <-\n Aws.pureAws cfg s3cfg mgr $\n S3.getObject \"haskell-aws\" \"cloud-remote.pdf\"\n\n {- Save the response to a file. -}\n runConduit $ responseBody rsp .| sinkFile \"cloud-remote.pdf\"\n" }, { "path": "Examples/MultipartTransfer.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\n{- This example demonstrates an ability to stream in constant space content from a remote resource into an S3 object accessible publicly -}\n\n\nimport qualified Aws\nimport Aws.Aws (Configuration (..))\nimport qualified Aws.S3 as S3\nimport Control.Applicative ((<$>))\nimport Control.Monad.Trans.Resource\nimport qualified Data.Text as T\nimport Network.HTTP.Conduit (http, parseUrl, responseBody,\n newManager, tlsManagerSettings)\nimport System.Environment (getArgs)\n\nmain :: IO ()\nmain = do\n maybeCreds <- Aws.loadCredentialsFromEnv\n case maybeCreds of\n Nothing -> do\n putStrLn \"Please set the environment variables AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET\"\n Just creds -> do\n args <- getArgs\n cfg <- Aws.dbgConfiguration\n let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery\n\n case args of\n [sourceUrl,destBucket,destObj] -> do\n request <- parseUrl sourceUrl\n\t mgr <- newManager tlsManagerSettings\n runResourceT $ do\n source <- responseBody <$> http request mgr\n let initiator b o = (S3.postInitiateMultipartUpload b o){S3.imuAcl = Just S3.AclPublicRead}\n S3.multipartUploadWithInitiator cfg{credentials = creds} s3cfg initiator mgr (T.pack destBucket) (T.pack destObj) source (10*1024*1024)\n _ -> do\n putStrLn \"Usage: MultipartTransfer sourceUrl destinationBucket destinationObjectname\"\n\n" }, { "path": "Examples/MultipartUpload.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.Core as Aws\nimport qualified Aws.S3 as S3\nimport qualified Data.ByteString.Char8 as B\nimport Data.Conduit (connect)\nimport Data.Conduit.Binary (sourceFile)\nimport qualified Data.Text as T\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)\nimport Control.Monad.Trans.Resource (runResourceT)\nimport System.Environment (getArgs)\n\nmain :: IO ()\nmain = do\n args <- getArgs\n case args of\n [endpoint, bucket, obj, file] -> doUpload endpoint bucket obj file 10\n [endpoint, bucket, obj, file, chunkSize] -> doUpload endpoint bucket obj file (read chunkSize)\n _ -> mapM_ putStrLn\n [ \"Usage: MultipartUpload endpoint bucket dstobject srcfile [chunksize(MB)]\"\n , \"Example: MultipartUpload s3.us-east-2.amazonaws.com your-bucket tmp/test.bin test.bin\"\n ]\n where\n doUpload endpoint bucket obj file chunkSize = do\n cfg <- Aws.dbgConfiguration\n let s3cfg = S3.s3v4 Aws.HTTPS (B.pack endpoint) False S3.SignWithEffort\n mgr <- newManager tlsManagerSettings\n runResourceT $\n sourceFile file `connect` S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)\n" }, { "path": "Examples/NukeBucket.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.S3 as S3\nimport qualified Data.Conduit as C\nimport qualified Data.Conduit.List as CL\nimport Data.Text (pack)\nimport Control.Monad ((<=<))\nimport Control.Monad.IO.Class (liftIO)\nimport Control.Monad.Trans.Resource\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)\nimport System.Environment (getArgs)\n\nmain :: IO ()\nmain = do\n [bucket] <- fmap (map pack) getArgs\n\n {- Set up AWS credentials and the default configuration. -}\n cfg <- Aws.baseConfiguration\n let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery\n\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n let src = Aws.awsIteratedSource cfg s3cfg mgr (S3.getBucket bucket)\n let deleteObjects [] = return ()\n deleteObjects os =\n do\n let keys = map S3.objectKey os\n liftIO $ putStrLn (\"Deleting objects: \" ++ show keys)\n _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os))\n return ()\n src `C.connect` CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO)\n liftIO $ putStrLn (\"Deleting bucket: \" ++ show bucket)\n _ <- Aws.pureAws cfg s3cfg mgr (S3.DeleteBucket bucket)\n return ()\n" }, { "path": "Examples/PutBucketNearLine.hs", "content": "-- | Example of creating a Nearline bucket on Google Cloud Storage.\n\n{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.Core as Aws\nimport qualified Aws.S3 as S3\nimport Data.Conduit.Binary (sinkFile)\nimport Control.Monad.Trans.Resource\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..))\nimport Control.Monad.IO.Class\nimport Control.Concurrent\nimport System.IO\nimport Control.Applicative\nimport qualified Data.Text as T\nimport System.Environment\n\nsc :: S3.StorageClass\nsc = S3.OtherStorageClass (T.pack \"NEARLINE\")\n\nmain :: IO ()\nmain = do\n [bucket] <- fmap (map T.pack) getArgs\n\n {- Set up AWS credentials and S3 configuration using the Google Cloud\n - Storage endpoint. -}\n Just creds <- Aws.loadCredentialsFromEnv\n let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing\n let s3cfg = S3.s3 Aws.HTTP \"storage.googleapis.com\" False\n\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n {- Create a request object with S3.PutBucket and run the request with pureAws. -}\n rsp <-\n Aws.pureAws cfg s3cfg mgr $\n S3.PutBucket bucket Nothing \"US\" (Just sc)\n liftIO $ print rsp\n" }, { "path": "Examples/PutObjectIA.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.Core as Aws\nimport qualified Aws.S3 as S3\nimport Data.Conduit (($$+-))\nimport Data.Conduit.Binary (sinkFile)\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..))\nimport qualified Data.ByteString.Lazy as L\nimport qualified Data.ByteString as S\nimport Control.Monad.Trans.Resource\nimport Control.Monad.IO.Class\nimport Control.Concurrent\nimport System.Posix.Files\nimport System.IO\nimport Control.Applicative\nimport qualified Data.Text as T\n\nmain :: IO ()\nmain = do\n {- Set up AWS credentials and S3 configuration using the IA endpoint. -}\n Just creds <- Aws.loadCredentialsFromEnv\n let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing\n let s3cfg = S3.s3 Aws.HTTP \"s3.us.archive.org\" False\n\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n let file =\"test\"\n -- streams large file content, without buffering more than 10k in memory\n let streamer sink = withFile file ReadMode $ \\h -> sink $ S.hGet h 10240\n b <- liftIO $ L.readFile file\n size <- liftIO $ (fromIntegral . fileSize <$> getFileStatus file :: IO Integer)\n let body = RequestBodyStream (fromInteger size) streamer\n rsp <- Aws.pureAws cfg s3cfg mgr $\n (S3.putObject \"joeyh-test-item\" (T.pack file) body)\n\t\t{ S3.poMetadata =\n\t\t\t[ (\"mediatype\", \"texts\")\n\t\t\t, (\"meta-description\", \"test Internet Archive item made via haskell aws library\")\n\t\t\t]\n\t\t-- Automatically creates bucket on IA if it does not exist,\n\t\t-- and uses the above metadata as the bucket's metadata.\n\t\t, S3.poAutoMakeBucket = True\n\t\t}\n liftIO $ print rsp\n" }, { "path": "Examples/SimpleDb.hs", "content": "import qualified Aws\nimport qualified Aws.SimpleDb as Sdb\nimport qualified Data.Text as T\nimport qualified Data.Text.IO as T\n\nmain :: IO ()\nmain = do\n {- Load configuration -}\n cfg <- Aws.baseConfiguration\n let sdbCfg = Aws.defServiceConfig\n\n putStrLn \"Making request...\"\n\n {- Make request -}\n let req = Sdb.listDomains { Sdb.ldMaxNumberOfDomains = Just 10 }\n Sdb.ListDomainsResponse names _token <- Aws.simpleAws cfg sdbCfg req\n \n {- Analyze response -}\n putStrLn \"First 10 domains:\"\n mapM_ (T.putStrLn . T.cons '\\t') names\n" }, { "path": "Examples/Sqs.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.Core\nimport qualified Aws.Sqs as Sqs\nimport Control.Concurrent\nimport Control.Error\nimport Control.Monad.IO.Class\nimport Data.Monoid\nimport Data.String\nimport qualified Data.Text.IO as T\nimport qualified Data.Text as T\nimport qualified Data.Text.Read as TR\nimport Control.Monad (forM_, forM, replicateM)\n\n{-| Created by Tim Perry on September 18, 2013\n |\n | All code relies on a correctly configured ~/.aws-keys and will access that account which\n | may incur charges for the user!\n |\n | This code will demonstrate:\n | - Listing all queue's attached to the current AWS account.\n | - Creating a queue\n | - Adding messages to the queue\n | - Retrieving messages from the queue\n | - Deleting messages from the queue\n | and finally\n | - Deleting the queue.\n | -}\nmain :: IO ()\nmain = do\n {- Set up AWS credentials and the default configuration. -}\n cfg <- Aws.baseConfiguration\n let sqscfg = Sqs.sqs Aws.Core.HTTP Sqs.sqsEndpointUsWest2 False :: Sqs.SqsConfiguration Aws.NormalQuery\n\n {- List any Queues you have already created in your SQS account -}\n Sqs.ListQueuesResponse qUrls <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing\n let origQUrlCount = length qUrls\n putStrLn $ \"originally had \" ++ show origQUrlCount ++ \" queue urls\"\n mapM_ print qUrls\n\n {- Create a request object to create a queue and then print out the Queue URL -}\n let qName = \"scaledsoftwaretest1\"\n let createQReq = Sqs.CreateQueue (Just 8400) qName\n Sqs.CreateQueueResponse qUrl <- Aws.simpleAws cfg sqscfg createQReq\n T.putStrLn $ T.concat [\"queue was created with Url: \", qUrl]\n\n {- Create a QueueName object, sqsQName, to hold the name of this queue for the duration -}\n let awsAccountNum = T.split (== '/') qUrl !! 3\n let sqsQName = Sqs.QueueName qName awsAccountNum\n\n {- list queue attributes -- for this example we will only list the approximateNumberOfMessages in this queue. -}\n let qAttReq = Sqs.GetQueueAttributes sqsQName [Sqs.ApproximateNumberOfMessages]\n Sqs.GetQueueAttributesResponse attPairs <- Aws.simpleAws cfg sqscfg qAttReq\n mapM_ (\\(attName, attText) -> T.putStrLn $ T.concat [\" \", Sqs.printQueueAttribute attName, \" \", attText]) attPairs\n\n {- Here we add some messages to the queue -}\n let messages = map (\\n -> T.pack $ \"msg\" ++ show n) [1 .. 10]\n {- Add messages to the queue -}\n forM_ messages $ \\mText -> do\n T.putStrLn $ \" Adding: \" <> mText\n let sqsSendMessage = Sqs.SendMessage mText sqsQName [] (Just 0)\n Sqs.SendMessageResponse _ mid _ <- Aws.simpleAws cfg sqscfg sqsSendMessage\n T.putStrLn $ \" message id: \" <> sshow mid\n\n {- Here we remove messages from the queue one at a time. -}\n let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) [] sqsQName (Just 20)\n let numMessages = length messages\n removedMsgs <- replicateM numMessages $ do\n msgs <- exceptT (const $ return []) return . retryT 2 $ do\n Sqs.ReceiveMessageResponse r <- liftIO $ Aws.simpleAws cfg sqscfg receiveMessageReq\n case r of\n [] -> throwE \"no message received\"\n _ -> return r\n putStrLn $ \"number of messages received: \" ++ show (length msgs)\n forM msgs (\\msg -> do\n -- here we remove a message, delete it from the queue, and then return the\n -- text sent in the body of the message\n putStrLn $ \" Received \" ++ show (Sqs.mBody msg)\n Aws.simpleAws cfg sqscfg $ Sqs.DeleteMessage (Sqs.mReceiptHandle msg) sqsQName\n return $ Sqs.mBody msg)\n\n {- Now we'll delete the queue we created at the start of this program -}\n putStrLn $ \"Deleting the queue: \" ++ show (Sqs.qName sqsQName)\n let dQReq = Sqs.DeleteQueue sqsQName\n _ <- Aws.simpleAws cfg sqscfg dQReq\n\n {- | Let's make sure the queue was actually deleted and that the same number of queues exist at when\n | the program ends as when it started.\n -}\n exceptT T.putStrLn T.putStrLn . retryT 4 $ do\n qUrls <- liftIO $ do\n putStrLn $ \"Listing all queues to check to see if \" ++ show (Sqs.qName sqsQName) ++ \" is gone\"\n Sqs.ListQueuesResponse qUrls_ <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing\n mapM_ T.putStrLn qUrls_\n return qUrls_\n\n if qUrl `elem` qUrls\n then throwE $ \" *\\n *\\n * Warning, '\" <> sshow qName <> \"' was not deleted\\n\"\n <> \" * This is probably just a race condition.\"\n else return $ \" The queue '\" <> sshow qName <> \"' was correctly deleted\"\n\nretryT :: MonadIO m => Int -> ExceptT T.Text m a -> ExceptT T.Text m a\nretryT i f = go 1\n where\n go x\n | x >= i = fmapLT (\\e -> \"error after \" <> sshow x <> \" retries: \" <> e) f\n | otherwise = f `catchE` \\_ -> do\n liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))\n go (succ x)\n\nsshow :: (Show a, IsString b) => a -> b\nsshow = fromString . show\n\n" }, { "path": "LICENSE", "content": "Copyright (c) 2010, 2011, 2012, Aristid Breitkreuz\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n * Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n\n * Redistributions in binary form must reproduce the above\n copyright notice, this list of conditions and the following\n disclaimer in the documentation and/or other materials provided\n with the distribution.\n\n * Neither the name of Aristid Breitkreuz nor the names of other\n contributors may be used to endorse or promote products derived\n from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\nLIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\nA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\nOWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\nLIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\nDATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\nTHEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "README.md", "content": "Introduction\n============\n\nThe `aws` package attempts to provide support for using Amazon Web\nServices like S3 (storage), SQS (queuing) and others to Haskell\nprogrammers. The ultimate goal is to support all Amazon Web Services.\n\nInstallation\n============\n\nMake sure you have a recent GHC installed, as well as cabal-install, and\ninstallation should be as easy as:\n\n``` {.bash}\n$ cabal install aws\n```\n\nIf you prefer to install from source yourself, you should first get a\nclone of the `aws` repository, and install it from inside the source\ndirectory:\n\n``` {.bash}\n$ git clone https://github.com/aristidb/aws.git\n$ cd aws\n$ cabal install\n```\n\nUsing aws\n=========\n\nConcepts and organisation\n-------------------------\n\nThe aws package is organised into the general `Aws` module namespace,\nand subnamespaces like `Aws.S3` for each Amazon Web Service. Under each\nservice namespace in turn, there are general support modules and and\n`Aws..Commands.` module for each command. For easier\nusage, there are the \"bundling\" modules `Aws` (general support), and\n`Aws.`.\n\nThe primary concept in aws is the *Transaction*, which corresponds to a\nsingle HTTP request to the Amazon Web Services. A transaction consists\nof a request and a response, which are associated together via the\n`Transaction` typeclass. Requests and responses are simple Haskell\nrecords, but for some requests there are convenience functions to fill\nin default values for many parameters.\n\nExample usage\n-------------\n\nTo be able to access AWS resources, you should put your into a\nconfiguration file. (You don't have to store it in a file, but that's\nhow we do it in this example.) Save the following in `$HOME/.aws-keys`.\n\n``` {.example}\ndefault AccessKeyID SecretKey\n```\n\nYou do have to replace AccessKeyID and SecretKey with the Access Key ID\nand the Secret Key respectively, of course.\n\nThen, copy this example into a Haskell file, and run it with `runghc`\n(after installing aws):\n\n``` {.haskell}\n{-# LANGUAGE OverloadedStrings #-}\n\nimport qualified Aws\nimport qualified Aws.S3 as S3\nimport Control.Monad.Trans.Resource\nimport Data.Conduit ((.|), runConduit)\nimport Data.Conduit.Binary (sinkFile)\nimport Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)\n\nmain :: IO ()\nmain = do\n {- Set up AWS credentials and the default configuration. -}\n cfg <- Aws.baseConfiguration\n let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery\n\n {- Set up a ResourceT region with an available HTTP manager. -}\n mgr <- newManager tlsManagerSettings\n runResourceT $ do\n {- Create a request object with S3.getObject and run the request with pureAws. -}\n S3.GetObjectResponse { S3.gorResponse = rsp } <-\n Aws.pureAws cfg s3cfg mgr $\n S3.getObject \"haskell-aws\" \"cloud-remote.pdf\"\n\n {- Save the response to a file. -}\n runConduit $ responseBody rsp .| sinkFile \"cloud-remote.pdf\"\n```\n\nYou can also find this example in the source distribution in the\n`Examples/` folder.\n\nFrequently Asked Questions\n==========================\n\nS3 questions\n------------\n\n- I get an error when I try to access my bucket with upper-case\n characters / a very long name.\n\n Those names are not compliant with DNS. You need to use path-style\n requests, by setting `s3RequestStyle` in the configuration to\n `PathStyle`. Note that such bucket names are only allowed in the US\n standard region, so your endpoint needs to be US standard.\n\nRelease Notes\n=============\n\nSee CHANGELOG\n\nResources\n=========\n\n- [aws on Github](https://github.com/aristidb/aws)\n- [aws on Hackage](http://hackage.haskell.org/package/aws) (includes\n reference documentation)\n- [Official Amazon Web Services website](http://aws.amazon.com/)\n\nContributors\n============\n\n Name |Github |E-Mail |Company |Components\n --------------------|-------------------------------------------------|--------------------------------|-----------------------------------------------------|--------------------\n Abhinav Gupta |[abhinav](https://github.com/abhinav) |mail@abhinavg.net |- |IAM, SES\n Aristid Breitkreuz |[aristidb](https://github.com/aristidb) |aristidb@gmail.com |- |Co-Maintainer\n Bas van Dijk |[basvandijk](https://github.com/basvandijk) |v.dijk.bas@gmail.com |[Erudify AG](http://erudify.ch) |S3\n David Vollbracht |[qxjit](https://github.com/qxjit) | | |\n Felipe Lessa |[meteficha](https://github.com/meteficha) |felipe.lessa@gmail.com |currently secret |Core, S3, SES\n Nathan Howell |[NathanHowell](https://github.com/NathanHowell) |nhowell@alphaheavy.com |[Alpha Heavy Industries](http://www.alphaheavy.com) |S3\n Ozgun Ataman |[ozataman](https://github.com/ozataman) |ozgun.ataman@soostone.com |[Soostone Inc](http://soostone.com) |Core, S3, DynamoDb\n Steve Severance |[sseveran](https://github.com/sseveran) |sseverance@alphaheavy.com |[Alpha Heavy Industries](http://www.alphaheavy.com) |S3, SQS\n John Wiegley |[jwiegley](https://github.com/jwiegley) |johnw@fpcomplete.com |[FP Complete](http://fpcomplete.com) |S3\n Chris Dornan |[cdornan](https://github.com/cdornan) |chris.dornan@irisconnect.co.uk |[Iris Connect](http://irisconnect.co.uk) |Core\n John Lenz |[wuzzeb](https://github/com/wuzzeb) | | |DynamoDB, Core\n Joey Hess |[joeyh](https://github.com/joeyh) |id@joeyh.name |- |Co-Maintainer, S3\n\n\n" }, { "path": "Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain\n" }, { "path": "VERSIONING", "content": "The AWS package is, starting with the 0.4 release, following the following versioning scheme:\n\n- Releases follow the Major.minor.tiny scheme. Numbering starts from 0, no numbers are special.\n- Minor changes that do not change any APIs, including APIs from other packages that are used by this package (e.g. by raising the lower version bound of a dependency), change the \"tiny\" level only.\n- Medium changes that change the API, or minor changes that raise the lower version bound of a dependency, change the \"minor\" level.\n- Major changes that change the API, change the \"major\" level.\n\nThis means that the next major release after 0.4.0 will be 1.0.0, where the 1.x does NOT denote a \"stable\" release.\n" }, { "path": "aws.cabal", "content": "Name: aws\nVersion: 0.25.2\nSynopsis: Amazon Web Services (AWS) for Haskell\nDescription: 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 .\nHomepage: http://github.com/aristidb/aws\nLicense: BSD3\nLicense-file: LICENSE\nAuthor: Aristid Breitkreuz, contributors see README\nMaintainer: aristidb@gmail.com\nCopyright: See contributors list in README and LICENSE file\nCategory: Network, Web, AWS, Cloud, Distributed Computing\nBuild-type: Simple\n\nExtra-source-files: README.md\n CHANGELOG.md\n\nCabal-version: >=1.10\n\nSource-repository this\n type: git\n location: https://github.com/aristidb/aws.git\n tag: 0.25.2\n\nSource-repository head\n type: git\n location: https://github.com/aristidb/aws.git\n\nFlag Examples\n Description: Build the examples.\n Default: False\n\nLibrary\n Exposed-modules:\n Aws\n Aws.Aws\n Aws.Core\n Aws.DynamoDb\n Aws.DynamoDb.Commands\n Aws.DynamoDb.Commands.BatchGetItem\n Aws.DynamoDb.Commands.BatchWriteItem\n Aws.DynamoDb.Commands.DeleteItem\n Aws.DynamoDb.Commands.GetItem\n Aws.DynamoDb.Commands.PutItem\n Aws.DynamoDb.Commands.Query\n Aws.DynamoDb.Commands.Scan\n Aws.DynamoDb.Commands.Table\n Aws.DynamoDb.Commands.UpdateItem\n Aws.DynamoDb.Core\n Aws.Ec2.InstanceMetadata\n Aws.Iam\n Aws.Iam.Commands\n Aws.Iam.Commands.AddUserToGroup\n Aws.Iam.Commands.CreateAccessKey\n Aws.Iam.Commands.CreateGroup\n Aws.Iam.Commands.CreateUser\n Aws.Iam.Commands.DeleteAccessKey\n Aws.Iam.Commands.DeleteGroup\n Aws.Iam.Commands.DeleteGroupPolicy\n Aws.Iam.Commands.DeleteUser\n Aws.Iam.Commands.DeleteUserPolicy\n Aws.Iam.Commands.GetGroupPolicy\n Aws.Iam.Commands.GetUser\n Aws.Iam.Commands.GetUserPolicy\n Aws.Iam.Commands.ListAccessKeys\n Aws.Iam.Commands.ListMfaDevices\n Aws.Iam.Commands.ListGroupPolicies\n Aws.Iam.Commands.ListGroups\n Aws.Iam.Commands.ListUserPolicies\n Aws.Iam.Commands.ListUsers\n Aws.Iam.Commands.PutGroupPolicy\n Aws.Iam.Commands.PutUserPolicy\n Aws.Iam.Commands.RemoveUserFromGroup\n Aws.Iam.Commands.UpdateAccessKey\n Aws.Iam.Commands.UpdateGroup\n Aws.Iam.Commands.UpdateUser\n Aws.Iam.Core\n Aws.Iam.Internal\n Aws.Network\n Aws.S3\n Aws.S3.Commands\n Aws.S3.Commands.CopyObject\n Aws.S3.Commands.DeleteBucket\n Aws.S3.Commands.DeleteObject\n Aws.S3.Commands.DeleteObjectVersion\n Aws.S3.Commands.DeleteObjects\n Aws.S3.Commands.GetBucket\n Aws.S3.Commands.GetBucketLocation\n Aws.S3.Commands.GetBucketObjectVersions\n Aws.S3.Commands.GetBucketVersioning\n Aws.S3.Commands.GetObject\n Aws.S3.Commands.GetService\n Aws.S3.Commands.HeadObject\n Aws.S3.Commands.PutBucket\n Aws.S3.Commands.PutBucketVersioning\n Aws.S3.Commands.PutObject\n Aws.S3.Commands.RestoreObject\n Aws.S3.Commands.Multipart\n Aws.S3.Core\n Aws.Ses\n Aws.Ses.Commands\n Aws.Ses.Commands.DeleteIdentity\n Aws.Ses.Commands.GetIdentityDkimAttributes\n Aws.Ses.Commands.GetIdentityNotificationAttributes\n Aws.Ses.Commands.GetIdentityVerificationAttributes\n Aws.Ses.Commands.ListIdentities\n Aws.Ses.Commands.SendRawEmail\n Aws.Ses.Commands.SetIdentityDkimEnabled\n Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled\n Aws.Ses.Commands.SetIdentityNotificationTopic\n Aws.Ses.Commands.VerifyDomainDkim\n Aws.Ses.Commands.VerifyDomainIdentity\n Aws.Ses.Commands.VerifyEmailIdentity\n Aws.Ses.Core\n Aws.SimpleDb\n Aws.SimpleDb.Commands\n Aws.SimpleDb.Commands.Attributes\n Aws.SimpleDb.Commands.Domain\n Aws.SimpleDb.Commands.Select\n Aws.SimpleDb.Core\n Aws.Sqs\n Aws.Sqs.Commands\n Aws.Sqs.Commands.Message\n Aws.Sqs.Commands.Permission\n Aws.Sqs.Commands.Queue\n Aws.Sqs.Commands.QueueAttributes\n Aws.Sqs.Core\n\n Build-depends:\n aeson >= 2.2.0.0,\n attoparsec >= 0.11 && < 0.15,\n attoparsec-aeson >= 2.1.0.0,\n base >= 4.9 && < 5,\n base16-bytestring >= 0.1 && < 1.1,\n base64-bytestring >= 1.0 && < 1.3,\n blaze-builder >= 0.2.1.4 && < 0.5,\n byteable == 0.1.*,\n bytestring >= 0.9 && < 0.13,\n case-insensitive >= 0.2 && < 1.3,\n cereal >= 0.3 && < 0.6,\n conduit >= 1.3 && < 1.4,\n conduit-extra >= 1.3 && < 1.4,\n containers >= 0.4,\n crypton >= 0.34,\n data-default >= 0.5.3 && < 0.9,\n directory >= 1.0 && < 2.0,\n filepath >= 1.1 && < 1.6,\n http-conduit >= 2.3 && < 2.4,\n http-client-tls >= 0.3 && < 0.4,\n http-types >= 0.7 && < 1.0,\n lifted-base >= 0.1 && < 0.3,\n memory,\n monad-control >= 0.3,\n exceptions >= 0.8 && < 0.11,\n mtl == 2.*,\n old-locale == 1.*,\n resourcet >= 1.2 && < 1.4,\n safe >= 0.3 && < 0.4,\n scientific >= 0.3,\n tagged >= 0.7 && < 0.9,\n text >= 0.11,\n time >= 1.4.0 && < 2.0,\n transformers >= 0.2.2 && < 0.7,\n unordered-containers >= 0.2,\n utf8-string >= 0.3 && < 1.1,\n vector >= 0.10,\n xml-conduit >= 1.8 && <2.0,\n network == 3.*,\n network-bsd == 2.8.*\n\n GHC-Options: -Wall\n\n Default-Language: Haskell2010\n Default-Extensions:\n RecordWildCards,\n TypeFamilies,\n MultiParamTypeClasses,\n FlexibleContexts,\n FlexibleInstances,\n FunctionalDependencies,\n DeriveFunctor,\n DeriveDataTypeable,\n OverloadedStrings,\n TupleSections,\n ScopedTypeVariables,\n EmptyDataDecls,\n Rank2Types\n\nExecutable GetObjectV4\n Main-is: GetObjectV4.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n http-conduit,\n conduit,\n conduit-extra,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable GetObject\n Main-is: GetObject.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n http-conduit,\n conduit,\n conduit-extra,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable GetObjectGoogle\n Main-is: GetObjectGoogle.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n http-conduit,\n conduit,\n conduit-extra,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable MultipartUpload\n Main-is: MultipartUpload.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n bytestring,\n http-conduit,\n conduit,\n conduit-extra,\n text,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable MultipartTransfer\n Main-is: MultipartTransfer.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n http-conduit,\n conduit,\n conduit-extra,\n text,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable NukeBucket\n Main-is: NukeBucket.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n http-conduit,\n conduit,\n conduit-extra,\n text >=0.1,\n transformers,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable PutBucketNearLine\n Main-is: PutBucketNearLine.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n http-conduit,\n conduit,\n conduit-extra,\n text >=0.1,\n transformers,\n resourcet\n\n Default-Language: Haskell2010\n\nExecutable SimpleDb\n Main-is: SimpleDb.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n text >=0.11\n\n Default-Language: Haskell2010\n\nExecutable DynamoDb\n Main-is: DynamoDb.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n aws,\n base == 4.*,\n data-default,\n exceptions,\n http-conduit,\n resourcet,\n text,\n conduit\n\n Default-Language: Haskell2010\n\n\nExecutable Sqs\n Main-is: Sqs.hs\n Hs-source-dirs: Examples\n\n if !flag(Examples)\n Buildable: False\n else\n Buildable: True\n Build-depends:\n base == 4.*,\n aws,\n errors >= 2.0,\n text >=0.11,\n transformers >= 0.3\n\n Default-Language: Haskell2010\n\ntest-suite sqs-tests\n type: exitcode-stdio-1.0\n default-language: Haskell2010\n hs-source-dirs: tests\n main-is: Sqs/Main.hs\n\n other-modules:\n Utils\n\n build-depends:\n QuickCheck >= 2.7,\n aeson >= 0.7,\n aws,\n base == 4.*,\n bytestring >= 0.10,\n errors >= 2.0,\n http-client >= 0.3 && < 0.8,\n lifted-base >= 0.2,\n monad-control >= 0.3,\n mtl >= 2.1,\n quickcheck-instances >= 0.3,\n resourcet >= 1.1,\n tagged >= 0.7,\n tasty >= 0.8,\n tasty-quickcheck >= 0.8,\n text >= 1.1,\n time,\n transformers >= 0.3,\n transformers-base >= 0.4\n\n ghc-options: -Wall -threaded\n\ntest-suite dynamodb-tests\n type: exitcode-stdio-1.0\n default-language: Haskell2010\n hs-source-dirs: tests\n main-is: DynamoDb/Main.hs\n\n other-modules:\n Utils\n DynamoDb.Utils\n\n build-depends:\n QuickCheck >= 2.7,\n aeson >= 0.7,\n aws,\n base == 4.*,\n bytestring >= 0.10,\n errors >= 2.0,\n http-client >= 0.3,\n lifted-base >= 0.2,\n monad-control >= 0.3,\n mtl >= 2.1,\n quickcheck-instances >= 0.3,\n resourcet >= 1.1,\n tagged >= 0.7,\n tasty >= 0.8,\n tasty-quickcheck >= 0.8,\n text >= 1.1,\n time,\n transformers >= 0.3,\n transformers-base >= 0.4\n\n\ntest-suite s3-tests\n type: exitcode-stdio-1.0\n default-language: Haskell2010\n hs-source-dirs: tests\n main-is: S3/Main.hs\n\n other-modules:\n Utils\n\n build-depends:\n aws,\n base == 4.*,\n QuickCheck >= 2.7,\n aeson >= 0.7,\n bytestring,\n conduit,\n errors >= 2.0,\n lifted-base >= 0.2,\n monad-control >= 0.3,\n mtl >= 2.1,\n http-client < 0.8,\n http-client-tls < 0.5,\n http-types,\n resourcet,\n tasty >= 0.8,\n tasty-hunit >= 0.8,\n tasty-quickcheck >= 0.8,\n text,\n time,\n tagged >= 0.7,\n transformers >= 0.3,\n transformers-base >= 0.4\n" }, { "path": "default.nix", "content": "{ mkDerivation, aeson, attoparsec, base, base16-bytestring\n, base64-bytestring, blaze-builder, byteable, bytestring\n, case-insensitive, cereal, conduit, conduit-combinators\n, conduit-extra, containers, cryptohash, data-default, directory\n, errors, filepath, http-client, http-client-tls, http-conduit\n, http-types, lifted-base, monad-control, mtl, network, network-bsd, old-locale\n, QuickCheck, quickcheck-instances, resourcet, safe, scientific\n, stdenv, tagged, tasty, tasty-hunit, tasty-quickcheck, text, time\n, transformers, transformers-base, unordered-containers\n, utf8-string, vector, xml-conduit\n}:\nmkDerivation {\n pname = \"aws\";\n version = \"0.17\";\n src = ./.;\n isLibrary = true;\n isExecutable = true;\n libraryHaskellDepends = [\n aeson attoparsec base base16-bytestring base64-bytestring\n blaze-builder byteable bytestring case-insensitive cereal conduit\n conduit-extra containers cryptohash data-default directory filepath\n http-conduit http-types lifted-base monad-control mtl network network-bsd\n old-locale resourcet safe scientific tagged text time transformers\n unordered-containers utf8-string vector xml-conduit\n ];\n testHaskellDepends = [\n aeson base bytestring conduit-combinators errors http-client\n http-client-tls http-types lifted-base monad-control mtl QuickCheck\n quickcheck-instances resourcet tagged tasty tasty-hunit\n tasty-quickcheck text time transformers transformers-base\n ];\n homepage = \"http://github.com/aristidb/aws\";\n description = \"Amazon Web Services (AWS) for Haskell\";\n license = stdenv.lib.licenses.bsd3;\n}\n" }, { "path": "ghci.hs", "content": "-- GHCI convenience code\n\nimport Aws\nimport Aws.Ec2.InstanceMetadata\nimport qualified Aws.S3 as S3\nimport qualified Aws.Ses as Ses\nimport qualified Aws.SimpleDb as Sdb\nimport qualified Aws.Sqs as Sqs\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Resource\nimport qualified Data.ByteString as S\nimport qualified Data.ByteString.Lazy as L\nimport qualified Data.Conduit as C\nimport qualified Data.Conduit.List as CL\nimport Data.Default\nimport qualified Network.HTTP.Conduit as HTTP\nimport qualified Network.HTTP.Types as HTTP\n\nimport System.IO.Unsafe -- only for the initialisation Please\n\nbcfg = unsafePerformIO baseConfiguration\ndcfg = unsafePerformIO dbgConfiguration\nmgr = unsafePerformIO (HTTP.newManager def)" }, { "path": "shell.nix", "content": "with (import {}).pkgs;\nlet\n pkg = haskellPackages.callPackage ./. {};\nin\n pkg.env\n" }, { "path": "stack.yaml", "content": "# This file was automatically generated by 'stack init'\n#\n# Some commonly used options have been documented as comments in this file.\n# For advanced use and comprehensive documentation of the format, please see:\n# http://docs.haskellstack.org/en/stable/yaml_configuration/\n\n# Resolver to choose a 'specific' stackage snapshot or a compiler version.\n# A snapshot resolver dictates the compiler version and the set of packages\n# to be used for project dependencies. For example:\n#\n# resolver: lts-3.5\n# resolver: nightly-2015-09-21\n# resolver: ghc-7.10.2\n# resolver: ghcjs-0.1.0_ghc-7.10.2\n# resolver:\n# name: custom-snapshot\n# location: \"./custom-snapshot.yaml\"\nresolver: lts-19.16\n\n# User packages to be built.\n# Various formats can be used as shown in the example below.\n#\n# packages:\n# - some-directory\n# - https://example.com/foo/bar/baz-0.0.2.tar.gz\n# - location:\n# git: https://github.com/commercialhaskell/stack.git\n# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a\n# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a\n# extra-dep: true\n# subdirs:\n# - auto-update\n# - wai\n#\n# A package marked 'extra-dep: true' will only be built if demanded by a\n# non-dependency (i.e. a user package), and its test suites and benchmarks\n# will not be run. This is useful for tweaking upstream packages.\npackages:\n- '.'\n# Dependency packages to be pulled from upstream that are not in the resolver\n# (e.g., acme-missiles-0.3)\nextra-deps: []\n\n# Override default flag values for local packages and extra-deps\nflags: {}\n\n# Extra package databases containing global packages\nextra-package-dbs: []\n\n# Control whether we use the GHC we find on the path\n# system-ghc: true\n#\n# Require a specific version of stack, using version ranges\n# require-stack-version: -any # Default\n# require-stack-version: \">=1.3\"\n#\n# Override the architecture used by stack, especially useful on Windows\n# arch: i386\n# arch: x86_64\n#\n# Extra directories used by stack for building\n# extra-include-dirs: [/path/to/dir]\n# extra-lib-dirs: [/path/to/dir]\n#\n# Allow a newer minor version of GHC than the snapshot specifies\n# compiler-check: newer-minor\n" }, { "path": "tests/DynamoDb/Main.hs", "content": "-- ------------------------------------------------------ --\n-- Copyright © 2014 AlephCloud Systems, Inc.\n-- ------------------------------------------------------ --\n\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE FlexibleContexts #-}\n\n-- |\n-- Module: Main\n-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.\n-- License: BSD3\n-- Maintainer: Lars Kuhtz \n-- Stability: experimental\n--\n-- Tests for Haskell AWS DynamoDb bindings\n--\n\nmodule Main\n( main\n) where\n\nimport Aws\nimport qualified Aws.DynamoDb as DY\n\nimport Control.Arrow (second)\nimport Control.Error\nimport Control.Monad\nimport Control.Monad.IO.Class\n\nimport Data.IORef\nimport qualified Data.List as L\nimport qualified Data.Text as T\n\nimport qualified Network.HTTP.Client as HTTP\n\nimport Test.Tasty\nimport Test.QuickCheck.Instances ()\n\nimport System.Environment\nimport System.Exit\n\nimport Utils\nimport DynamoDb.Utils\n\n-- -------------------------------------------------------------------------- --\n-- Main\n\nmain :: IO ()\nmain = do\n args <- getArgs\n runMain args $ map (second tail . span (/= '=')) args\n where\n runMain :: [String] -> [(String,String)] -> IO ()\n runMain args _argsMap\n | any (`elem` helpArgs) args = defaultMain tests\n | \"--run-with-aws-credentials\" `elem` args =\n withArgs (tastyArgs args) . defaultMain $ tests\n | otherwise = putStrLn help >> exitFailure\n\n helpArgs = [\"--help\", \"-h\"]\n mainArgs =\n [ \"--run-with-aws-credentials\"\n ]\n tastyArgs args = flip filter args $ \\x -> not\n $ any (`L.isPrefixOf` x) mainArgs\n\n\nhelp :: String\nhelp = L.intercalate \"\\n\"\n [ \"\"\n , \"NOTE\"\n , \"\"\n , \"This test suite accesses the AWS account that is associated with\"\n , \"the default credentials from the credential file ~/.aws-keys.\"\n , \"\"\n , \"By running the tests in this test-suite costs for usage of AWS\"\n , \"services may incur.\"\n , \"\"\n , \"In order to actually execute the tests in this test-suite you must\"\n , \"provide the command line options:\"\n , \"\"\n , \" --run-with-aws-credentials\"\n , \"\"\n , \"When running this test-suite through cabal you may use the following\"\n , \"command:\"\n , \"\"\n , \" cabal test --test-option=--run-with-aws-credentials dynamodb-tests\"\n , \"\"\n ]\n\ntests :: TestTree\ntests = testGroup \"DynamoDb Tests\"\n [ test_table\n -- , test_message\n , test_core\n ]\n\n-- -------------------------------------------------------------------------- --\n-- Table Tests\n\ntest_table :: TestTree\ntest_table = testGroup \"Table Tests\"\n [ eitherTOnceTest1 \"CreateDescribeDeleteTable\" (prop_createDescribeDeleteTable 10 10)\n ]\n\n-- |\n--\nprop_createDescribeDeleteTable\n :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)\n -> Int -- ^ write capacity (#writes * itemsize/1KB)\n -> T.Text -- ^ table name\n -> ExceptT T.Text IO ()\nprop_createDescribeDeleteTable readCapacity writeCapacity tableName = do\n tTableName <- testData tableName\n tryT $ createTestTable tTableName readCapacity writeCapacity\n let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName)\n flip catchE (\\e -> deleteTable >> throwE e) $ do\n retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName\n deleteTable\n\n-- -------------------------------------------------------------------------- --\n-- Test core functionality\n\ntest_core :: TestTree\ntest_core = testGroup \"Core Tests\"\n [ eitherTOnceTest0 \"connectionReuse\" prop_connectionReuse\n ]\n\nprop_connectionReuse\n :: ExceptT T.Text IO ()\nprop_connectionReuse = do\n c <- liftIO $ do\n cfg <- baseConfiguration\n\n -- counts the number of TCP connections\n ref <- newIORef (0 :: Int)\n\n manager <- HTTP.newManager (managerSettings ref)\n void $ runExceptT $\n flip catchE (error . T.unpack) . replicateM_ 3 $ do\n void $ dyT cfg manager DY.ListTables\n mustFail . dyT cfg manager $ DY.DescribeTable \"____\"\n\n readIORef ref\n unless (c == 1) $\n throwE \"The TCP connection has not been reused\"\n where\n managerSettings ref = HTTP.defaultManagerSettings\n { HTTP.managerRawConnection = do\n mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings\n return $ \\a b c -> do\n atomicModifyIORef ref $ \\i -> (succ i, ())\n mkConn a b c\n }\n\n" }, { "path": "tests/DynamoDb/Utils.hs", "content": "-- ------------------------------------------------------ --\n-- Copyright © 2014 AlephCloud Systems, Inc.\n-- ------------------------------------------------------ --\n\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE TypeOperators #-}\n\n-- |\n-- Module: DynamoDb.Utils\n-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.\n-- License: BSD3\n-- Maintainer: Lars Kuhtz \n-- Stability: experimental\n--\n-- Tests for Haskell SQS bindings\n--\n\nmodule DynamoDb.Utils\n(\n-- * Static Parameters\n testProtocol\n, testRegion\n, defaultTableName\n\n-- * Static Configuration\n, dyConfiguration\n\n-- * DynamoDb Utils\n, simpleDy\n, simpleDyT\n, dyT\n, withTable\n, withTable_\n, createTestTable\n) where\n\nimport Aws\nimport Aws.Core\nimport qualified Aws.DynamoDb as DY\n\nimport Control.Error\nimport Control.Exception\nimport Control.Monad\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Control\nimport Control.Monad.Trans.Resource\n\nimport Data.Monoid\nimport qualified Data.Text as T\nimport qualified Data.Text.IO as T\n\nimport qualified Network.HTTP.Client as HTTP\n\nimport Test.Tasty\nimport Test.QuickCheck.Instances ()\n\nimport System.IO\n\nimport Utils\n\n-- -------------------------------------------------------------------------- --\n-- Static Test parameters\n--\n-- TODO make these configurable\n\ntestProtocol :: Protocol\ntestProtocol = HTTP\n\ntestRegion :: DY.Region\ntestRegion = DY.ddbUsWest2\n\ndefaultTableName :: T.Text\ndefaultTableName = \"test-table\"\n\n-- -------------------------------------------------------------------------- --\n-- Dynamo Utils\n\ndyConfiguration :: DY.DdbConfiguration qt\ndyConfiguration = DY.DdbConfiguration\n { DY.ddbcRegion = testRegion\n , DY.ddbcProtocol = testProtocol\n , DY.ddbcPort = Nothing\n }\n\nsimpleDy\n :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadIO m)\n => r\n -> m (MemoryResponse a)\nsimpleDy command = do\n c <- dbgConfiguration\n simpleAws c dyConfiguration command\n\nsimpleDyT\n :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m)\n => r\n -> ExceptT T.Text m (MemoryResponse a)\nsimpleDyT = tryT . simpleDy\n\ndyT\n :: (Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration)\n => Configuration\n -> HTTP.Manager\n -> r\n -> ExceptT T.Text IO a\ndyT cfg manager req = do\n Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req\n hoistEither $ fmapL sshow r\n\nwithTable\n :: T.Text -- ^ table Name\n -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)\n -> Int -- ^ write capacity (#writes * itemsize/1KB)\n -> (T.Text -> IO a) -- ^ test tree\n -> IO a\nwithTable = withTable_ True\n\nwithTable_\n :: Bool -- ^ whether to prefix the table name\n -> T.Text -- ^ table Name\n -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)\n -> Int -- ^ write capacity (#writes * itemsize/1KB)\n -> (T.Text -> IO a) -- ^ test tree\n -> IO a\nwithTable_ prefix tableName readCapacity writeCapacity f =\n do\n tTableName <- if prefix then testData tableName else return tableName\n\n let deleteTable = do\n r <- runExceptT . retryT 6 $\n void (simpleDyT $ DY.DeleteTable tTableName) `catchE` \\e ->\n liftIO . T.hPutStrLn stderr $ \"attempt to delete table failed: \" <> e\n either (error . T.unpack) (const $ return ()) r\n\n let createTable = do\n r <- runExceptT $ do\n retryT 3 $ tryT $ createTestTable tTableName readCapacity writeCapacity\n retryT 6 $ do\n tableDesc <- simpleDyT $ DY.DescribeTable tTableName\n when (DY.rTableStatus tableDesc == \"CREATING\") $ throwE \"Table not ready: status CREATING\"\n either (error . T.unpack) return r\n\n bracket_ createTable deleteTable $ f tTableName\n\ncreateTestTable\n :: T.Text -- ^ table Name\n -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)\n -> Int -- ^ write capacity (#writes * itemsize/1KB)\n -> IO ()\ncreateTestTable tableName readCapacity writeCapacity = void . simpleDy $\n DY.createTable\n tableName\n attrs\n (DY.HashOnly keyName)\n throughPut\n where\n keyName = \"Id\"\n keyType = DY.AttrString\n attrs = [DY.AttributeDefinition keyName keyType]\n throughPut = DY.ProvisionedThroughput\n { DY.readCapacityUnits = readCapacity\n , DY.writeCapacityUnits = writeCapacity\n }\n\n\n" }, { "path": "tests/S3/Main.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n{-# LANGUAGE OverloadedStrings #-}\n-- |\n-- Module: Main\n-- Copyright: Copyright © 2016 Soostone, Inc.\n-- License: BSD3\n-- Maintainer: Michael Xavier \n-- Stability: experimental\n--\n-- Tests for Haskell AWS S3 bindings\n--\nmodule Main\n ( main\n ) where\n\nimport Control.Applicative\nimport qualified Data.ByteString as BS\nimport qualified Data.ByteString.Lazy as BL\nimport Conduit\nimport Control.Arrow (second)\nimport Control.Exception\nimport Control.Monad\nimport Control.Monad.Trans.Resource\nimport qualified Data.List as L\nimport Data.Monoid\nimport qualified Data.Text as T\nimport Data.Typeable\nimport Data.Proxy\nimport Network.HTTP.Client (HttpException (..),\n RequestBody (..), newManager,\n responseBody)\n#if MIN_VERSION_http_client(0, 5, 0)\nimport Network.HTTP.Client (HttpExceptionContent (..),\n responseStatus)\n#endif\nimport Network.HTTP.Client.TLS (tlsManagerSettings)\nimport Network.HTTP.Types.Status\nimport System.Environment\nimport System.Exit\nimport Test.Tasty\nimport Test.Tasty.HUnit\nimport Test.Tasty.Options\n\nimport Aws\nimport Aws.S3\n\n\nnewtype BucketOption = BucketOption Bucket\n deriving (Show, Eq, Ord, Typeable)\n\ninstance IsOption BucketOption where\n defaultValue = error \"The --bucket flag is required\"\n parseValue = Just . BucketOption . T.pack\n optionName = return \"bucket\"\n optionHelp = return \"Bucket to use for performing S3 operations. Tests will write to the 's3-test-object' key.\"\n\n\nmain :: IO ()\nmain = do\n args <- getArgs\n runMain args $ map (second tail . span (/= '=')) args\n where\n runMain :: [String] -> [(String,String)] -> IO ()\n runMain args _argsMap\n | any (`elem` helpArgs) args = defaultMainWithIngredients ings tests\n | \"--run-with-aws-credentials\" `elem` args =\n withArgs (tastyArgs args) . defaultMainWithIngredients ings $ tests\n | otherwise = putStrLn help >> exitFailure\n helpArgs = [\"--help\", \"-h\"]\n mainArgs =\n [ \"--run-with-aws-credentials\"\n ]\n tastyArgs args = flip filter args $ \\x -> not\n $ any (`L.isPrefixOf` x) mainArgs\n ings = includingOptions [Option (Proxy :: Proxy BucketOption)]:defaultIngredients\n\n\nhelp :: String\nhelp = L.intercalate \"\\n\"\n [ \"\"\n , \"NOTE\"\n , \"\"\n , \"This test suite accesses the AWS account that is associated with\"\n , \"the default credentials from the credential file ~/.aws-keys.\"\n , \"\"\n , \"By running the tests in this test-suite costs for usage of AWS\"\n , \"services may incur.\"\n , \"\"\n , \"In order to actually execute the tests in this test-suite you must\"\n , \"provide the command line options:\"\n , \"\"\n , \" --run-with-aws-credentials\"\n , \"\"\n , \"When running this test-suite through cabal you may use the following\"\n , \"command:\"\n , \"\"\n , \" cabal test --test-option=--run-with-aws-credentials s3-tests\"\n , \"\"\n ]\n\n\ntests :: TestTree\ntests = testGroup \"S3 Tests\"\n [ test_head\n , test_get\n , test_versioning\n ]\n\n\n-------------------------------------------------------------------------------\n-- HeadObject Tests\n-------------------------------------------------------------------------------\n\n\ntest_head :: TestTree\ntest_head = askOption $ \\(BucketOption bucket) -> testGroup \"HeadObject\"\n [ test_head_caching bucket\n ]\n\n\ntest_head_caching :: Bucket -> TestTree\ntest_head_caching bucket = withResource mkSetup teardown $ \\setup -> testGroup \"Caches\"\n [ testCase \"If-Matches match succeeds\" $ do\n (cfg, s3cfg, mgr) <- setup\n void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just payloadMD5 }))\n , testCase \"If-Matches mismatch fails with 412\" $ do\n (cfg, s3cfg, mgr) <- setup\n assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just (T.reverse payloadMD5) }))\n , testCase \"If-None-Match mismatch succeeds\" $ do\n (cfg, s3cfg, mgr) <- setup\n void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just (T.reverse payloadMD5) }))\n , testCase \"If-None-Match match fails with 304\" $ do\n (cfg, s3cfg, mgr) <- setup\n assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just payloadMD5 }))\n ]\n where\n k = \"s3-test-object\"\n content = \"example\"\n payloadMD5 = \"1a79a4d60de6718e8e5b326e338ae533\"\n mkSetup = do\n cfg <- baseConfiguration\n let s3cfg = defServiceConfig\n mgr <- newManager tlsManagerSettings\n void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))\n return (cfg, s3cfg, mgr)\n teardown (cfg, s3cfg, mgr) =\n void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))\n\n\n-------------------------------------------------------------------------------\n-- GetObject Tests\n-------------------------------------------------------------------------------\n\n\ntest_get :: TestTree\ntest_get = askOption $ \\(BucketOption bucket) -> testGroup \"GetObject\"\n [ test_get_caching bucket\n ]\n\n\ntest_get_caching :: Bucket -> TestTree\ntest_get_caching bucket = withResource mkSetup teardown $ \\setup -> testGroup \"Caches\"\n [ testCase \"If-Matches match succeeds\" $ do\n (cfg, s3cfg, mgr) <- setup\n void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just payloadMD5 }))\n , testCase \"If-Matches mismatch fails with 412\" $ do\n (cfg, s3cfg, mgr) <- setup\n assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just (T.reverse payloadMD5) }))\n , testCase \"If-None-Match mismatch succeeds\" $ do\n (cfg, s3cfg, mgr) <- setup\n void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just (T.reverse payloadMD5) }))\n , testCase \"If-None-Match match fails with 304\" $ do\n (cfg, s3cfg, mgr) <- setup\n assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just payloadMD5 }))\n ]\n where\n k = \"s3-test-object\"\n content = \"example\"\n payloadMD5 = \"1a79a4d60de6718e8e5b326e338ae533\"\n mkSetup = do\n cfg <- baseConfiguration\n let s3cfg = defServiceConfig\n mgr <- newManager tlsManagerSettings\n void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))\n return (cfg, s3cfg, mgr)\n teardown (cfg, s3cfg, mgr) =\n void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))\n\n\n-------------------------------------------------------------------------------\n-- GetBucketObjectVersions Tests\n-------------------------------------------------------------------------------\n\n\ntest_versioning :: TestTree\ntest_versioning = askOption $ \\(BucketOption bucket) ->\n withResource (mkSetup bucket) (teardown bucket) $ \\setup -> testGroup \"Versioning\"\n [ testCase \"GetBucketObjectVersions succeeds\" $ do\n (cfg, s3cfg, mgr) <- setup\n resp <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)\n { gbovPrefix = Just k\n }\n let [o1, o2, o3, o4] = take 4 $ gbovrContents resp\n checkObject True o1\n checkDeleteMarker False o2\n checkObject False o3\n checkObject False o4\n , testCase \"DeleteObjectVersion succeeds\" $ do\n -- Note: this test requires bucket with versioning enabled\n (cfg, s3cfg, mgr) <- setup\n resp <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)\n { gbovPrefix = Just k\n }\n let [v1, v2, v3, v4] = map oviVersionId $ take 4 $ gbovrContents resp\n void (runResourceT (pureAws cfg s3cfg mgr (deleteObjectVersion bucket k v2)))\n void (runResourceT (pureAws cfg s3cfg mgr (deleteObjectVersion bucket k v3)))\n\n resp' <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)\n { gbovPrefix = Just k\n }\n let [v1', v4'] = map oviVersionId $ take 2 $ gbovrContents resp'\n assertEqual \"invalid v1 version\" v1 v1'\n assertEqual \"invalid v4 version\" v4 v4'\n , testCase \"Multipart upload succeeds\" $ do\n -- Note: this test requires bucket with versioning enabled\n (cfg, s3cfg, mgr) <- setup\n resp <- runResourceT $ do\n uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket k\n etags <- (sourceLazy testStr\n .| chunkedConduit 65536\n .| putConduit cfg s3cfg mgr bucket k uploadId\n ) `connect` sinkList\n liftIO $ sendEtag cfg s3cfg mgr bucket k uploadId etags\n let Just vid = cmurVersionId resp\n bs <- runResourceT $ do\n gor <- pureAws cfg s3cfg mgr (getObject bucket k) { goVersionId = Just vid }\n sealConduitT (responseBody (gorResponse gor)) $$+- sinkLazy\n\n assertEqual \"data do not match\" testStr bs\n ]\n where\n testStr = \"foobar\" :: BL.ByteString\n k = \"s3-test-object\"\n content = \"example\"\n payloadMD5 = \"1a79a4d60de6718e8e5b326e338ae533\"\n checkObject marker obj@ObjectVersion{} = do\n assertEqual \"invalid object key\" k (oviKey obj)\n assertEqual \"invalid isLatest flag\" marker (oviIsLatest obj)\n assertEqual \"invalid object size\" (fromIntegral $ BS.length content) (oviSize obj)\n checkObject _ obj = assertFailure $ \"Invalid object type \" <> show obj\n checkDeleteMarker marker obj@DeleteMarker{} = do\n assertEqual \"invalid object key\" k (oviKey obj)\n assertEqual \"invalid isLatest flag\" marker (oviIsLatest obj)\n checkDeleteMarker _ obj = assertFailure $ \"Invalid object type \" <> show obj\n mkSetup bucket = do\n cfg <- baseConfiguration\n let s3cfg = defServiceConfig\n mgr <- newManager tlsManagerSettings\n void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))\n void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))\n void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))\n void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))\n return (cfg, s3cfg, mgr)\n teardown bucket (cfg, s3cfg, mgr) =\n void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))\n\n\nassertStatus :: Int -> IO a -> Assertion\nassertStatus expectedStatus f = do\n res <- catchJust selector\n (Right <$> f)\n (return . Left)\n case res of\n Right _ -> assertFailure (\"Expected error with status \" <> show expectedStatus <> \", but got success.\")\n Left _ -> return ()\n where\n#if MIN_VERSION_http_client(0, 5, 0)\n selector (HttpExceptionRequest _ (StatusCodeException res _))\n | statusCode (responseStatus res) == expectedStatus = Just ()\n selector _ = Nothing\n#else\n selector (StatusCodeException s _ _)\n | statusCode s == expectedStatus = Just ()\n | otherwise = Nothing\n selector _ = Nothing\n#endif\n" }, { "path": "tests/Sqs/Main.hs", "content": "-- ------------------------------------------------------ --\n-- Copyright © 2014 AlephCloud Systems, Inc.\n-- ------------------------------------------------------ --\n\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE TypeOperators #-}\n\n-- |\n-- Module: Main\n-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.\n-- License: BSD3\n-- Maintainer: Lars Kuhtz \n-- Stability: experimental\n--\n-- Tests for Haskell SQS bindings\n--\n\nmodule Main\n( main\n) where\n\nimport Aws\nimport Aws.Core\nimport qualified Aws.Sqs as SQS\n\nimport Control.Arrow (second)\nimport Control.Error\nimport Control.Monad\nimport Control.Monad.IO.Class\nimport Control.Monad.Trans.Control\nimport Control.Monad.Trans.Resource\n\nimport Data.IORef\nimport qualified Data.List as L\nimport qualified Data.Text as T\nimport Data.Monoid\nimport Prelude\n\nimport qualified Network.HTTP.Client as HTTP\n\nimport Test.Tasty\nimport Test.QuickCheck.Instances ()\n\nimport System.Environment\nimport System.Exit\n\nimport Utils\n\n-- -------------------------------------------------------------------------- --\n-- Main\n\nmain :: IO ()\nmain = do\n args <- getArgs\n runMain args $ map (second tail . span (/= '=')) args\n where\n runMain :: [String] -> [(String,String)] -> IO ()\n runMain args _argsMap\n | any (`elem` helpArgs) args = defaultMain tests\n | \"--run-with-aws-credentials\" `elem` args =\n withArgs (tastyArgs args) . defaultMain $ tests\n | otherwise = putStrLn help >> exitFailure\n\n helpArgs = [\"--help\", \"-h\"]\n mainArgs =\n [ \"--run-with-aws-credentials\"\n ]\n tastyArgs args = flip filter args $ \\x -> not\n $ any (`L.isPrefixOf` x) mainArgs\n\n\nhelp :: String\nhelp = L.intercalate \"\\n\"\n [ \"\"\n , \"NOTE\"\n , \"\"\n , \"This test suite accesses the AWS account that is associated with\"\n , \"the default credentials from the credential file ~/.aws-keys.\"\n , \"\"\n , \"By running the tests in this test-suite costs for usage of AWS\"\n , \"services may incur.\"\n , \"\"\n , \"In order to actually execute the tests in this test-suite you must\"\n , \"provide the command line options:\"\n , \"\"\n , \" --run-with-aws-credentials\"\n , \"\"\n , \"When running this test-suite through cabal you may use the following\"\n , \"command:\"\n , \"\"\n , \" cabal test --test-option=--run-with-aws-credentials sqs-tests\"\n , \"\"\n ]\n\ntests :: TestTree\ntests = withQueueTest defaultQueueName $ \\getQueueParams -> testGroup \"SQS Tests\"\n [ test_queue\n , test_message getQueueParams\n , test_core getQueueParams\n ]\n\n-- -------------------------------------------------------------------------- --\n-- Static Test parameters\n--\n-- TODO make these configurable\n\ntestProtocol :: Protocol\ntestProtocol = HTTP\n\ntestSqsEndpoint :: SQS.Endpoint\ntestSqsEndpoint = SQS.sqsEndpointUsWest2\n\ndefaultQueueName :: T.Text\ndefaultQueueName = \"test-queue\"\n\n-- -------------------------------------------------------------------------- --\n-- SQS Utils\n\nsqsQueueName :: T.Text -> SQS.QueueName\nsqsQueueName url = SQS.QueueName (sqsQueueNameText url) (sqsAccountIdText url)\n\nsqsQueueNameText :: T.Text -> T.Text\nsqsQueueNameText url = T.split (== '/') url !! 4\n\nsqsAccountIdText :: T.Text -> T.Text\nsqsAccountIdText url = T.split (== '/') url !! 3\n\nsqsConfiguration :: SQS.SqsConfiguration qt\nsqsConfiguration = SQS.SqsConfiguration\n { SQS.sqsProtocol = testProtocol\n , SQS.sqsEndpoint = testSqsEndpoint\n , SQS.sqsPort = 80\n , SQS.sqsUseUri = False\n , SQS.sqsDefaultExpiry = 180\n }\n\nsqsT\n :: (Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration)\n => Configuration\n -> HTTP.Manager\n -> r\n -> ExceptT T.Text IO a\nsqsT cfg manager req = do\n Response _ r <- liftIO . runResourceT $ aws cfg sqsConfiguration manager req\n hoistEither $ fmapL sshow r\n\nsimpleSqs\n :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)\n => r\n -> m (MemoryResponse a)\nsimpleSqs command = do\n c <- baseConfiguration\n simpleAws c sqsConfiguration command\n\nsimpleSqsT\n :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadBaseControl IO m, MonadIO m)\n => r\n -> ExceptT T.Text m (MemoryResponse a)\nsimpleSqsT = tryT . simpleSqs\n\nwithQueueTest\n :: T.Text -- ^ Queue name\n -> (IO (T.Text, SQS.QueueName) -> TestTree) -- ^ test tree\n -> TestTree\nwithQueueTest queueName f = withResource createQueue deleteQueue $ \\getQueueUrl ->\n f $ do\n url <- getQueueUrl\n return (url, sqsQueueName url)\n where\n createQueue = do\n SQS.CreateQueueResponse url <- simpleSqs $ SQS.CreateQueue Nothing queueName\n return url\n deleteQueue url = void $ simpleSqs (SQS.DeleteQueue (sqsQueueName url))\n\n-- -------------------------------------------------------------------------- --\n-- Queue Tests\n\ntest_queue :: TestTree\ntest_queue = testGroup \"Queue Tests\"\n [ eitherTOnceTest1 \"CreateListDeleteQueue\" prop_createListDeleteQueue\n ]\n\n-- |\n--\nprop_createListDeleteQueue\n :: T.Text -- ^ queue name\n -> ExceptT T.Text IO ()\nprop_createListDeleteQueue queueName = do\n tQueueName <- testData queueName\n SQS.CreateQueueResponse queueUrl <- simpleSqsT $ SQS.CreateQueue Nothing tQueueName\n let queue = sqsQueueName queueUrl\n flip catchE (\\e -> deleteQueue queue >> throwE e) $ do\n retryT 6 $ do\n SQS.ListQueuesResponse allQueueUrls <- simpleSqsT (SQS.ListQueues Nothing)\n unless (queueUrl `elem` allQueueUrls)\n . throwE $ \"queue \" <> sshow queueUrl <> \" not listed\"\n deleteQueue queue\n where\n deleteQueue queueUrl = void $ simpleSqsT (SQS.DeleteQueue queueUrl)\n\n-- -------------------------------------------------------------------------- --\n-- Message Tests\n\ntest_message :: IO (T.Text, SQS.QueueName) -> TestTree\ntest_message getQueueParams = testGroup \"Queue Tests\"\n [ eitherTOnceTest0 \"SendReceiveDeleteMessage\" $ do\n (_, queue) <- liftIO getQueueParams\n prop_sendReceiveDeleteMessage queue\n , eitherTOnceTest0 \"SendReceiveDeleteMessageLongPolling\" $ do\n (_, queue) <- liftIO getQueueParams\n prop_sendReceiveDeleteMessageLongPolling queue\n , eitherTOnceTest0 \"SendReceiveDeleteMessageLongPolling1\" $ do\n (_, queue) <- liftIO getQueueParams\n prop_sendReceiveDeleteMessageLongPolling1 queue\n ]\n\n-- | Simple send and short-polling receive. First sends all messages\n-- and receives messages thereafter one by one.\n--\nprop_sendReceiveDeleteMessage\n :: SQS.QueueName\n -> ExceptT T.Text IO ()\nprop_sendReceiveDeleteMessage queue = do\n\n -- a visibility timeout should be used only if either @receiveBatch == 1@\n -- or no retry is used so that all received messages are handled.\n let visTimeout = Just 60\n let delay = Just 0\n let poll = Nothing -- no consistent receive (any number of messages up to the requested number can be returned)\n let receiveBatch = 1\n let msgNum = 10\n\n let messages = map (\\i -> \"message\" <> sshow i) [1 .. msgNum]\n\n -- send messages\n forM_ messages $ \\msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay\n\n recMsgs <- fmap concat . replicateM msgNum $ do\n msgs <- retryT 5 $ do\n r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll\n case r of\n SQS.ReceiveMessageResponse [] -> throwE \"no message received\"\n SQS.ReceiveMessageResponse t\n | length t <= receiveBatch -> return t\n | otherwise -> throwE $ \"unexpected number of messages received: \" <> sshow (length t)\n forM_ msgs $ \\msg -> retryT 5 $\n simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue\n return (map SQS.mBody msgs)\n\n let recv = L.sort recMsgs\n let sent = L.sort messages\n unless (sent == recv)\n $ throwE $ \"received messages don't match send messages; sent: \"\n <> sshow sent <> \"; got: \" <> sshow recv\n\n-- | Checks for consistent receive: There is no message delay, so all messages\n-- are available when the first receive is requested. By enabling long-polling\n-- (with value 0) we force SQS to do a consistent receive.\n--\nprop_sendReceiveDeleteMessageLongPolling\n :: SQS.QueueName\n -> ExceptT T.Text IO ()\nprop_sendReceiveDeleteMessageLongPolling queue = do\n\n let delay = Nothing\n let visTimeout = Just 60\n let poll = Just 1 -- consistent receive (maximum available number of requested messages is returned)\n let receiveBatch = 10\n let msgNum = 40 -- this must be a multiple of 'receiveBatch'\n\n let messages = map (\\i -> \"message\" <> sshow i) [1 .. msgNum]\n\n -- send messages\n forM_ messages $ \\msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay\n\n recMsgs <- fmap concat . replicateM (msgNum `div` receiveBatch) $ do\n msgs <- do\n r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll\n case r of\n SQS.ReceiveMessageResponse [] -> throwE \"no messages received\"\n SQS.ReceiveMessageResponse t\n | length t == receiveBatch -> return t\n | otherwise -> throwE $ \"unexpected number of messages received: \" <> sshow (length t)\n forM_ msgs $ \\msg -> retryT 5 $\n simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue\n return (map SQS.mBody msgs)\n\n let recv = L.sort recMsgs\n let sent = L.sort messages\n unless (sent == recv)\n $ throwE $ \"received messages don't match send messages; sent: \"\n <> sshow sent <> \"; got: \" <> sshow recv\n\n-- | Checks that long polling is actually enabled. We add a delay to the messages\n-- and immediately make a receive request with a polling wait time that is larger\n-- than the delay. Note that even though polling forces consistent reads, messages\n-- will become available with some (small) offset. Therefore we request only a single\n-- message at a time.\n--\nprop_sendReceiveDeleteMessageLongPolling1\n :: SQS.QueueName\n -> ExceptT T.Text IO ()\nprop_sendReceiveDeleteMessageLongPolling1 queue = do\n\n let delay = Just 2\n let visTimeout = Just 60\n let poll = Just 5 -- consistent receive (maximum available number of requested messages is returned)\n let receiveBatch = 1\n let msgNum = 10 -- this must be a multiple of 'receiveBatch'\n\n let messages = map (\\i -> \"message\" <> sshow i) [1 :: Int .. msgNum]\n\n recMsgs <- fmap concat . forM messages $ \\msg -> do\n void . simpleSqsT $ SQS.SendMessage msg queue [] delay\n msgs <- do\n r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll\n case r of\n SQS.ReceiveMessageResponse [] -> throwE \"no messages received\"\n SQS.ReceiveMessageResponse t\n | length t == receiveBatch -> return t\n | otherwise -> throwE $ \"unexpected number of messages received: \" <> sshow (length t)\n forM_ msgs $ \\m -> retryT 5 $\n simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle m) queue\n return (map SQS.mBody msgs)\n\n let recv = L.sort recMsgs\n let sent = L.sort messages\n unless (sent == recv)\n $ throwE $ \"received messages don't match send messages; sent: \"\n <> sshow sent <> \"; got: \" <> sshow recv\n\n\n-- -------------------------------------------------------------------------- --\n-- Test core functionality\n\ntest_core :: IO (T.Text, SQS.QueueName) -> TestTree\ntest_core getQueueParams = testGroup \"Core Tests\"\n [ eitherTOnceTest0 \"connectionReuse\" $ do\n (_, queue) <- liftIO getQueueParams\n prop_connectionReuse queue\n ]\n\nprop_connectionReuse\n :: SQS.QueueName\n -> ExceptT T.Text IO ()\nprop_connectionReuse queue = do\n c <- liftIO $ do\n cfg <- baseConfiguration\n\n -- used for counting the number of TCP connections\n ref <- newIORef (0 :: Int)\n\n -- Use a single manager for all HTTP requests\n manager <- HTTP.newManager (managerSettings ref)\n void $ runExceptT $\n flip catchE (error . T.unpack) . replicateM_ 3 $ do\n void . sqsT cfg manager $ SQS.ListQueues Nothing\n mustFail . sqsT cfg manager $\n SQS.SendMessage \"\" (SQS.QueueName \"\" \"\") [] Nothing\n void . sqsT cfg manager $\n SQS.SendMessage \"test-message\" queue [] Nothing\n void . sqsT cfg manager $\n SQS.ReceiveMessage Nothing [] Nothing [] queue (Just 20)\n\n readIORef ref\n unless (c == 1) $\n throwE \"The TCP connection has not been reused\"\n where\n\n managerSettings ref = HTTP.defaultManagerSettings\n { HTTP.managerRawConnection = do\n mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings\n return $ \\a b c -> do\n atomicModifyIORef ref $ \\i -> (succ i, ())\n mkConn a b c\n }\n\n" }, { "path": "tests/Utils.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE GADTs #-}\n{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE TupleSections #-}\n\n-- |\n-- Module: Utils\n-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.\n-- License: BSD3\n-- Maintainer: Lars Kuhtz \n-- Stability: experimental\n--\n-- Utils for Tests for Haskell AWS bindints\n--\nmodule Utils\n(\n-- * Parameters\n testDataPrefix\n\n-- * General Utils\n, sshow\n, mustFail\n, tryT\n, retryT\n, retryT_\n, testData\n\n, evalTestT\n, evalTestTM\n, eitherTOnceTest0\n, eitherTOnceTest1\n, eitherTOnceTest2\n\n-- * Generic Tests\n, test_jsonRoundtrip\n, prop_jsonRoundtrip\n) where\n\nimport Control.Concurrent (threadDelay)\nimport qualified Control.Exception.Lifted as LE\nimport Control.Error hiding (syncIO)\nimport Control.Monad\nimport Control.Monad.Identity\nimport Control.Monad.IO.Class\nimport Control.Monad.Base\nimport Control.Monad.Trans.Control\nimport Control.Applicative\nimport Data.Monoid\nimport Prelude\n\nimport Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)\nimport Data.Dynamic (Dynamic)\nimport Data.Proxy\nimport Data.String\nimport qualified Data.Text as T\nimport qualified Data.Text.IO as T\nimport Data.Typeable\n\nimport Test.QuickCheck.Property\nimport Test.QuickCheck.Monadic\nimport Test.Tasty\nimport Test.Tasty.QuickCheck\n\nimport System.Exit (ExitCode)\nimport System.IO (stderr)\n\nimport Data.Time.Clock.POSIX (getPOSIXTime)\n\n-- -------------------------------------------------------------------------- --\n-- Static Test parameters\n--\n\n-- | This prefix is used for the IDs and names of all entities that are\n-- created in the AWS account.\n--\ntestDataPrefix :: IsString a => MonadBase IO m => m a\ntestDataPrefix = do\n t <- liftBase $ getPOSIXTime\n let t' :: Int\n t' = floor (t * 1000)\n return . fromString $ \"__TEST_AWSHASKELLBINDINGS__\" ++ show t'\n\n-- -------------------------------------------------------------------------- --\n-- General Utils\n\n-- | Catches all exceptions except for asynchronous exceptions found in base.\n--\ntryT :: MonadBaseControl IO m => m a -> ExceptT T.Text m a\ntryT = fmapLT (T.pack . show) . syncIO\n\n-- | Lifted Version of 'syncIO' form \"Control.Error.Util\".\n--\nsyncIO :: MonadBaseControl IO m => m a -> ExceptT LE.SomeException m a\nsyncIO a = ExceptT $ LE.catches (Right <$> a)\n [ LE.Handler $ \\e -> LE.throw (e :: LE.ArithException)\n , LE.Handler $ \\e -> LE.throw (e :: LE.ArrayException)\n , LE.Handler $ \\e -> LE.throw (e :: LE.AssertionFailed)\n , LE.Handler $ \\e -> LE.throw (e :: LE.AsyncException)\n , LE.Handler $ \\e -> LE.throw (e :: LE.BlockedIndefinitelyOnMVar)\n , LE.Handler $ \\e -> LE.throw (e :: LE.BlockedIndefinitelyOnSTM)\n , LE.Handler $ \\e -> LE.throw (e :: LE.Deadlock)\n , LE.Handler $ \\e -> LE.throw (e :: Dynamic)\n , LE.Handler $ \\e -> LE.throw (e :: LE.ErrorCall)\n , LE.Handler $ \\e -> LE.throw (e :: ExitCode)\n , LE.Handler $ \\e -> LE.throw (e :: LE.NestedAtomically)\n , LE.Handler $ \\e -> LE.throw (e :: LE.NoMethodError)\n , LE.Handler $ \\e -> LE.throw (e :: LE.NonTermination)\n , LE.Handler $ \\e -> LE.throw (e :: LE.PatternMatchFail)\n , LE.Handler $ \\e -> LE.throw (e :: LE.RecConError)\n , LE.Handler $ \\e -> LE.throw (e :: LE.RecSelError)\n , LE.Handler $ \\e -> LE.throw (e :: LE.RecUpdError)\n , LE.Handler $ return . Left\n ]\n\ntestData :: (IsString a, Monoid a, MonadBaseControl IO m) => a -> m a\ntestData a = fmap (<> a) testDataPrefix\n\nretryT :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m a\nretryT n f = snd <$> retryT_ n f\n\nretryT_ :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m (Int, a)\nretryT_ n f = go 1\n where\n go x\n | x >= n = fmapLT (\\e -> \"error after \" <> sshow x <> \" retries: \" <> e) ((x,) <$> f)\n | otherwise = ((x,) <$> f) `catchE` \\e -> do\n liftIO $ T.hPutStrLn stderr $ \"Retrying after error: \" <> e\n liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))\n go (succ x)\n\nsshow :: (Show a, IsString b) => a -> b\nsshow = fromString . show\n\nmustFail :: Monad m => ExceptT e m a -> ExceptT T.Text m ()\nmustFail = ExceptT . exceptT\n (const . return $ Right ())\n (const . return $ Left \"operation succeeded when a failure was expected\")\n\nevalTestTM\n :: Functor f\n => String -- ^ test name\n -> f (ExceptT T.Text IO a) -- ^ test\n -> f (PropertyM IO Bool)\nevalTestTM name = fmap $\n (liftIO . runExceptT) >=> \\r -> case r of\n Left e ->\n fail $ \"failed to run test \\\"\" <> name <> \"\\\": \" <> show e\n Right _ -> return True\n\nevalTestT\n :: String -- ^ test name\n -> ExceptT T.Text IO a -- ^ test\n -> PropertyM IO Bool\nevalTestT name = runIdentity . evalTestTM name . Identity\n\neitherTOnceTest0\n :: String -- ^ test name\n -> ExceptT T.Text IO a -- ^ test\n -> TestTree\neitherTOnceTest0 name test = testProperty name . once . monadicIO\n $ evalTestT name test\n\neitherTOnceTest1\n :: (Arbitrary a, Show a)\n => String -- ^ test name\n -> (a -> ExceptT T.Text IO b)\n -> TestTree\neitherTOnceTest1 name test = testProperty name . once $ monadicIO\n . evalTestTM name test\n\neitherTOnceTest2\n :: (Arbitrary a, Show a, Arbitrary b, Show b)\n => String -- ^ test name\n -> (a -> b -> ExceptT T.Text IO c)\n -> TestTree\neitherTOnceTest2 name test = testProperty name . once $ \\a b -> monadicIO\n $ (evalTestTM name $ uncurry test) (a, b)\n\n-- -------------------------------------------------------------------------- --\n-- Generic Tests\n\ntest_jsonRoundtrip\n :: forall a . (Eq a, Show a, FromJSON a, ToJSON a, Typeable a, Arbitrary a)\n => Proxy a\n -> TestTree\ntest_jsonRoundtrip proxy = testProperty msg (prop_jsonRoundtrip :: a -> Property)\n where\n msg = \"JSON roundtrip for \" <> show typ\n#if MIN_VERSION_base(4,7,0)\n typ = typeRep proxy\n#else\n typ = typeOf (undefined :: a)\n#endif\n\nprop_jsonRoundtrip :: forall a . (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property\nprop_jsonRoundtrip a = either (const $ property False) (\\(b :: [a]) -> [a] === b) $\n eitherDecode $ encode [a]\n\n" } ]