{-# LANGUAGE CPP #-} module Aws.Core ( -- * Logging Loggable(..) -- * Response -- ** Metadata in responses , Response(..) , readResponse , readResponseIO , tellMetadata , tellMetadataRef , mapMetadata -- ** Response data consumers , HTTPResponseConsumer , ResponseConsumer(..) -- ** Memory response , AsMemoryResponse(..) -- ** List response , ListResponse(..) -- ** Exception types , XmlException(..) , HeaderException(..) , FormException(..) , NoCredentialsException(..) , throwStatusCodeException -- ** Response deconstruction helpers , readHex2 -- *** XML , elContent , elCont , force , forceM , textReadBool , textReadInt , readInt , xmlCursorConsumer -- * Query , SignedQuery(..) , NormalQuery , UriOnlyQuery , queryToHttpRequest , queryToUri -- ** Expiration , TimeInfo(..) , AbsoluteTimeInfo(..) , fromAbsoluteTimeInfo , makeAbsoluteTimeInfo -- ** Signature , SignatureData(..) , signatureData , SignQuery(..) , AuthorizationHash(..) , amzHash , signature , credentialV4 , authorizationV4 , authorizationV4' , signatureV4 -- ** Query construction helpers , queryList , awsBool , awsTrue , awsFalse , fmtTime , fmtRfc822Time , rfc822Time , fmtAmzTime , fmtTimeEpochSeconds , parseHttpDate , httpDate1 , textHttpDate , iso8601UtcDate -- * Transactions , Transaction , IteratedTransaction(..) -- * Credentials , Credentials(..) , makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv , loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault , anonymousCredentials -- * Service configuration , DefaultServiceConfiguration(..) -- * HTTP types , Protocol(..) , defaultPort , Method(..) , httpMethod ) where import Aws.Ec2.InstanceMetadata import Aws.Network import qualified Blaze.ByteString.Builder as Blaze import Control.Applicative import Control.Arrow import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM)) import qualified Crypto.Hash as CH import qualified Crypto.MAC.HMAC as CMH import qualified Data.Aeson as A import qualified Data.ByteArray as ByteArray import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as BU import Data.Char import Data.Conduit ((.|)) import qualified Data.Conduit as C #if MIN_VERSION_http_conduit(2,2,0) import qualified Data.Conduit.Binary as CB #endif import qualified Data.Conduit.List as CL import Data.IORef import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time import qualified Data.Traversable as Traversable import Data.Typeable import Data.Word import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Client.TLS as HTTP import qualified Network.HTTP.Types as HTTP import System.Directory import System.Environment import System.FilePath (()) #if !MIN_VERSION_time(1,5,0) import System.Locale #endif import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu import Text.XML.Cursor hiding (force, forceM) import Prelude ------------------------------------------------------------------------------- -- | Types that can be logged (textually). class Loggable a where toLogText :: a -> T.Text -- | A response with metadata. Can also contain an error response, or -- an internal error, via 'Attempt'. -- -- Response forms a Writer-like monad. data Response m a = Response { responseMetadata :: m , responseResult :: Either E.SomeException a } deriving (Show, Functor) -- | Read a response result (if it's a success response, fail otherwise). readResponse :: MonadThrow n => Response m a -> n a readResponse = either throwM return . responseResult -- | Read a response result (if it's a success response, fail otherwise). In MonadIO. readResponseIO :: MonadIO io => Response m a -> io a readResponseIO = liftIO . readResponse -- | An empty response with some metadata. tellMetadata :: m -> Response m () tellMetadata m = Response m (return ()) -- | Apply a function to the metadata. mapMetadata :: (m -> n) -> Response m a -> Response n a mapMetadata f (Response m a) = Response (f m) a --multiResponse :: Monoid m => Response m a -> Response [m] a -> instance Monoid m => Applicative (Response m) where pure x = Response mempty (Right x) (<*>) = ap instance Monoid m => Monad (Response m) where return x = Response mempty (Right x) Response m1 (Left e) >>= _ = Response m1 (Left e) Response m1 (Right x) >>= f = let Response m2 y = f x in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too instance Monoid m => MonadThrow (Response m) where throwM e = Response mempty (throwM e) -- | Add metadata to an 'IORef' (using 'mappend'). tellMetadataRef :: Monoid m => IORef m -> m -> IO () tellMetadataRef r m = modifyIORef r (`mappend` m) -- | A full HTTP response parser. Takes HTTP status, response headers, and response body. type HTTPResponseConsumer a = HTTP.Response (C.ConduitM () ByteString (ResourceT IO) ()) -> ResourceT IO a -- | Class for types that AWS HTTP responses can be parsed into. -- -- The request is also passed for possibly required additional metadata. -- -- Note that for debugging, there is an instance for 'L.ByteString'. class Monoid (ResponseMetadata resp) => ResponseConsumer req resp where -- | Metadata associated with a response. Typically there is one -- metadata type for each AWS service. type ResponseMetadata resp -- | Response parser. Takes the corresponding AWS request, the derived -- @http-client@ request (for error reporting), an 'IORef' for metadata, and -- HTTP response data. responseConsumer :: HTTP.Request -> req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp -- | Does not parse response. For debugging. instance ResponseConsumer r (HTTP.Response L.ByteString) where type ResponseMetadata (HTTP.Response L.ByteString) = () responseConsumer _ _ _ resp = do bss <- C.runConduit $ HTTP.responseBody resp .| CL.consume return resp { HTTP.responseBody = L.fromChunks bss } -- | Class for responses that are fully loaded into memory class AsMemoryResponse resp where type MemoryResponse resp :: * loadToMemory :: resp -> ResourceT IO (MemoryResponse resp) -- | Responses that have one main list in them, and perhaps some decoration. class ListResponse resp item | resp -> item where listResponse :: resp -> [item] -- | Associates a request type and a response type in a bi-directional way. -- -- This allows the type-checker to infer the response type when given -- the request type and vice versa. -- -- Note that the actual request generation and response parsing -- resides in 'SignQuery' and 'ResponseConsumer' respectively. class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a)) => Transaction r a | r -> a -- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits. class Transaction r a => IteratedTransaction r a | r -> a where nextIteratedRequest :: r -> a -> Maybe r -- | Signature version 4: ((region, service),(date,key)) type V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString)) -- | AWS access credentials. data Credentials = Credentials { -- | AWS Access Key ID. accessKeyID :: B.ByteString -- | AWS Secret Access Key. , secretAccessKey :: B.ByteString -- | Signing keys for signature version 4 , v4SigningKeys :: IORef [V4Key] -- | Signed IAM token , iamToken :: Maybe B.ByteString -- | Set when the credentials are intended for anonymous access. , isAnonymousCredentials :: Bool } instance Show Credentials where show c@(Credentials {}) = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" makeCredentials :: MonadIO io => B.ByteString -- ^ AWS Access Key ID -> B.ByteString -- ^ AWS Secret Access Key -> io Credentials makeCredentials accessKeyID secretAccessKey = liftIO $ do v4SigningKeys <- newIORef [] let iamToken = Nothing let isAnonymousCredentials = False return Credentials { .. } -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. -- May return 'Nothing' if @HOME@ is unset. -- -- Value: //@/.aws-keys@ credentialsDefaultFile :: MonadIO io => io (Maybe FilePath) credentialsDefaultFile = liftIO $ tryMaybe (( ".aws-keys") <$> getHomeDirectory) tryMaybe :: IO a -> IO (Maybe a) tryMaybe action = E.catch (Just <$> action) f where f :: E.SomeException -> IO (Maybe a) f _ = return Nothing -- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'. -- -- Value: @default@ credentialsDefaultKey :: T.Text credentialsDefaultKey = "default" -- | Load credentials from a (text) file given a key name. -- -- The file consists of a sequence of lines, each in the following format: -- -- @keyName awsKeyID awsKeySecret@ loadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromFile file key = liftIO $ do exists <- doesFileExist file if exists then do contents <- map T.words . T.lines <$> T.readFile file Traversable.sequence $ do [_key, keyID, secret] <- find (hasKey key) contents return (makeCredentials (T.encodeUtf8 keyID) (T.encodeUtf8 secret)) else return Nothing where hasKey _ [] = False hasKey k (k2 : _) = k == k2 -- | Load credentials from the environment variables @AWS_ACCESS_KEY_ID@ and @AWS_ACCESS_KEY_SECRET@ -- (or @AWS_SECRET_ACCESS_KEY@), if possible. loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment let lk = fmap (T.encodeUtf8 . T.pack) . flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY" setSession creds = creds { iamToken = lk "AWS_SESSION_TOKEN" } makeCredentials' k s = setSession <$> makeCredentials k s Traversable.sequence $ makeCredentials' <$> keyID <*> secret loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) loadCredentialsFromInstanceMetadata = do mgr <- liftIO HTTP.getGlobalManager -- check if the path is routable avail <- liftIO $ hostAvailable "169.254.169.254" if not avail then return Nothing else do info <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam" "info" >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) let infodict = info >>= A.decode :: Maybe (M.Map String String) info' = infodict >>= M.lookup "InstanceProfileArn" case info' of Just name -> do let name' = drop 1 $ dropWhile (/= '/') $ name creds <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam/security-credentials" name' >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) -- this token lasts ~6 hours let dict = creds >>= A.decode :: Maybe (M.Map String String) keyID = dict >>= M.lookup "AccessKeyId" secret = dict >>= M.lookup "SecretAccessKey" token = dict >>= M.lookup "Token" ref <- liftIO $ newIORef [] return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret) <*> return ref <*> (Just . T.encodeUtf8 . T.pack <$> token) <*> return False) Nothing -> return Nothing -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsFromEnvOrFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromEnvOrFile file key = do envcr <- loadCredentialsFromEnv case envcr of Just cr -> return (Just cr) Nothing -> loadCredentialsFromFile file key -- | Load credentials from environment variables if possible, or alternatively from the instance metadata store, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv', 'loadCredentialsFromFile' and 'loadCredentialsFromInstanceMetadata' for details. loadCredentialsFromEnvOrFileOrInstanceMetadata :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromEnvOrFileOrInstanceMetadata file key = do envcr <- loadCredentialsFromEnv case envcr of Just cr -> return (Just cr) Nothing -> do filecr <- loadCredentialsFromFile file key case filecr of Just cr -> return (Just cr) Nothing -> loadCredentialsFromInstanceMetadata -- | Load credentials from environment variables if possible, or alternative from the default file with the default -- key name. -- -- Default file: //@/.aws-keys@ -- Default key name: @default@ -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do mfile <- credentialsDefaultFile case mfile of Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey Nothing -> loadCredentialsFromEnv -- | Make a dummy Credentials that can be used to access some AWS services -- anonymously. anonymousCredentials :: MonadIO io => io Credentials anonymousCredentials = do cr <- makeCredentials mempty mempty return (cr { isAnonymousCredentials = True }) -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol = HTTP | HTTPS deriving (Eq,Read,Show,Ord,Typeable) -- | The default port to be used for a protocol if no specific port is specified. defaultPort :: Protocol -> Int defaultPort HTTP = 80 defaultPort HTTPS = 443 -- | Request method. Not all request methods are supported by all services. data Method = Head -- ^ HEAD method. Put all request parameters in a query string and HTTP headers. | Get -- ^ GET method. Put all request parameters in a query string and HTTP headers. | PostQuery -- ^ POST method. Put all request parameters in a query string and HTTP headers, but send the query string -- as a POST payload | Post -- ^ POST method. Sends a service- and request-specific request body. | Put -- ^ PUT method. | Delete -- ^ DELETE method. deriving (Show, Eq, Ord) -- | HTTP method associated with a request method. httpMethod :: Method -> HTTP.Method httpMethod Head = "HEAD" httpMethod Get = "GET" httpMethod PostQuery = "POST" httpMethod Post = "POST" httpMethod Put = "PUT" httpMethod Delete = "DELETE" -- | A pre-signed medium-level request object. data SignedQuery = SignedQuery { -- | Request method. sqMethod :: !Method -- | Protocol to be used. , sqProtocol :: !Protocol -- | HTTP host. , sqHost :: !B.ByteString -- | IP port. , sqPort :: !Int -- | HTTP path. , sqPath :: !B.ByteString -- | Query string list (used with 'Get' and 'PostQuery'). , sqQuery :: !HTTP.Query -- | Request date/time. , sqDate :: !(Maybe UTCTime) -- | Authorization string (if applicable), for @Authorization@ header. See 'authorizationV4' , sqAuthorization :: !(Maybe (IO B.ByteString)) -- | Request body content type. , sqContentType :: !(Maybe B.ByteString) -- | Request body content MD5. , sqContentMd5 :: !(Maybe (CH.Digest CH.MD5)) -- | Additional Amazon "amz" headers. , sqAmzHeaders :: !HTTP.RequestHeaders -- | Additional non-"amz" headers. , sqOtherHeaders :: !HTTP.RequestHeaders -- | Request body (used with 'Post' and 'Put'). , sqBody :: !(Maybe HTTP.RequestBody) -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes. , sqStringToSign :: !B.ByteString } --deriving (Show) -- | Create a HTTP request from a 'SignedQuery' object. queryToHttpRequest :: SignedQuery -> IO HTTP.Request queryToHttpRequest SignedQuery{..} = do mauth <- maybe (return Nothing) (Just<$>) sqAuthorization return $ HTTP.defaultRequest { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False HTTPS -> True , HTTP.host = sqHost , HTTP.port = sqPort , HTTP.path = sqPath , HTTP.queryString = if sqMethod == PostQuery then "" else HTTP.renderQuery False sqQuery , HTTP.requestHeaders = catMaybes [ checkDate (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType , fmap (\md5 -> ("Content-MD5", Base64.encode $ ByteArray.convert md5)) sqContentMd5 , fmap (\auth -> ("Authorization", auth)) mauth] ++ sqAmzHeaders ++ sqOtherHeaders , HTTP.requestBody = -- An explicityly defined body parameter should overwrite everything else. case sqBody of Just x -> x Nothing -> -- a POST query should convert its query string into the body case sqMethod of PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery _ -> HTTP.RequestBodyBuilder 0 mempty , HTTP.decompress = HTTP.alwaysDecompress #if MIN_VERSION_http_conduit(2,2,0) , HTTP.checkResponse = \_ _ -> return () #else , HTTP.checkStatus = \_ _ _-> Nothing #endif , HTTP.redirectCount = 10 } where checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup "date" sqOtherHeaders -- An explicitly defined content-type should override everything else. contentType = sqContentType `mplus` defContentType defContentType = case sqMethod of PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8" _ -> Nothing -- | Create a URI fro a 'SignedQuery' object. -- -- Unused / incompatible fields will be silently ignored. queryToUri :: SignedQuery -> B.ByteString queryToUri SignedQuery{..} = B.concat [ case sqProtocol of HTTP -> "http://" HTTPS -> "https://" , sqHost , if sqPort == defaultPort sqProtocol then "" else T.encodeUtf8 . T.pack $ ':' : show sqPort , sqPath , HTTP.renderQuery True sqQuery ] -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration -- (absolute or relative). data TimeInfo = Timestamp -- ^ Use a simple timestamp to let AWS check the request validity. | ExpiresAt { fromExpiresAt :: UTCTime } -- ^ Let requests expire at a specific fixed time. | ExpiresIn { fromExpiresIn :: NominalDiffTime } -- ^ Let requests expire a specific number of seconds after they -- were generated. deriving (Show) -- | Like 'TimeInfo', but with all relative times replaced by absolute UTC. data AbsoluteTimeInfo = AbsoluteTimestamp { fromAbsoluteTimestamp :: UTCTime } | AbsoluteExpires { fromAbsoluteExpires :: UTCTime } deriving (Show) -- | Just the UTC time value. fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime fromAbsoluteTimeInfo (AbsoluteTimestamp time) = time fromAbsoluteTimeInfo (AbsoluteExpires time) = time -- | Convert 'TimeInfo' to 'AbsoluteTimeInfo' given the current UTC time. makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo makeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now makeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t makeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now -- | Data that is always required for signing requests. data SignatureData = SignatureData { -- | Expiration or timestamp. signatureTimeInfo :: AbsoluteTimeInfo -- | Current time. , signatureTime :: UTCTime -- | Access credentials. , signatureCredentials :: Credentials } -- | Create signature data using the current system time. signatureData :: TimeInfo -> Credentials -> IO SignatureData signatureData rti cr = do now <- getCurrentTime let ti = makeAbsoluteTimeInfo rti now return SignatureData { signatureTimeInfo = ti, signatureTime = now, signatureCredentials = cr } -- | Tag type for normal queries. data NormalQuery -- | Tag type for URI-only queries. data UriOnlyQuery -- | A "signable" request object. Assembles together the Query, and signs it in one go. class SignQuery request where -- | Additional information, like API endpoints and service-specific preferences. type ServiceConfiguration request :: * {- Query Type -} -> * -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'. signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery -- | Supported crypto hashes for the signature. data AuthorizationHash = HmacSHA1 | HmacSHA256 deriving (Show) -- | Authorization hash identifier as expected by Amazon. amzHash :: AuthorizationHash -> B.ByteString amzHash HmacSHA1 = "HmacSHA1" amzHash HmacSHA256 = "HmacSHA256" -- | Create a signature. Usually, AWS wants a specifically constructed string to be signed. -- -- The signature is a HMAC-based hash of the string and the secret access key. signature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString signature cr ah input = Base64.encode sig where sig = case ah of HmacSHA1 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA1) HmacSHA256 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA256) -- | Generates the Credential string, required for V4 signatures. credentialV4 :: SignatureData -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString credentialV4 sd region service = B.concat [ accessKeyID (signatureCredentials sd) , "/" , date , "/" , region , "/" , service , "/aws4_request" ] where date = fmtTime "%Y%m%d" $ signatureTime sd -- | Use this to create the Authorization header to set into 'sqAuthorization'. -- See : you must create the -- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3. authorizationV4 :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target -> B.ByteString -- ^ canonicalRequest (before hashing) -> IO B.ByteString authorizationV4 sd ah region service headers canonicalRequest = do let ref = v4SigningKeys $ signatureCredentials sd date = fmtTime "%Y%m%d" $ signatureTime sd -- Lookup existing signing key allkeys <- readIORef ref let mkey = case lookup (region,service) allkeys of Just (d,k) | d /= date -> Nothing | otherwise -> Just k Nothing -> Nothing -- possibly create a new signing key let createNewKey = atomicModifyIORef ref $ \keylist -> let kSigning = signingKeyV4 sd ah region service lstK = (region,service) keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist in (keylist', kSigning) -- finally, return the header constructAuthorizationV4Header sd ah region service headers . signatureV4WithKey sd ah region service canonicalRequest <$> maybe createNewKey return mkey -- | IO free version of @authorizationV4@, use this if you need -- to compute the signature outside of IO. authorizationV4' :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target -> B.ByteString -- ^ canonicalRequest (before hashing) -> B.ByteString authorizationV4' sd ah region service headers canonicalRequest = constructAuthorizationV4Header sd ah region service headers $ signatureV4 sd ah region service canonicalRequest constructAuthorizationV4Header :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target -> B.ByteString -- ^ signature -> B.ByteString constructAuthorizationV4Header sd ah region service headers sig = B.concat [ alg , " Credential=" , credentialV4 sd region service , ",SignedHeaders=" , headers , ",Signature=" , sig ] where alg = case ah of HmacSHA1 -> "AWS4-HMAC-SHA1" HmacSHA256 -> "AWS4-HMAC-SHA256" -- | Compute the signature for V4 signatureV4WithKey :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ canonicalRequest (before hashing) -> B.ByteString -- ^ signing key -> B.ByteString signatureV4WithKey sd ah region service canonicalRequest key = Base16.encode $ mkHmac key stringToSign where date = fmtTime "%Y%m%d" $ signatureTime sd mkHmac k i = case ah of HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1) HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256) mkHash i = case ah of HmacSHA1 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA1) HmacSHA256 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA256) alg = case ah of HmacSHA1 -> "AWS4-HMAC-SHA1" HmacSHA256 -> "AWS4-HMAC-SHA256" -- now do the signature canonicalRequestHash = Base16.encode $ mkHash canonicalRequest stringToSign = B.concat [ alg , "\n" , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd , "\n" , date , "/" , region , "/" , service , "/aws4_request\n" , canonicalRequestHash ] signingKeyV4 :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString signingKeyV4 sd ah region service = kSigning where mkHmac k i = case ah of HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1) HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256) date = fmtTime "%Y%m%d" $ signatureTime sd secretKey = secretAccessKey $ signatureCredentials sd kDate = mkHmac ("AWS4" <> secretKey) date kRegion = mkHmac kDate region kService = mkHmac kRegion service kSigning = mkHmac kService "aws4_request" signatureV4 :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ canonicalRequest (before hashing) -> B.ByteString signatureV4 sd ah region service canonicalRequest = signatureV4WithKey sd ah region service canonicalRequest $ signingKeyV4 sd ah region service -- | Default configuration for a specific service. class DefaultServiceConfiguration config where -- | Default service configuration. defServiceConfig :: config -- | Default debugging-only configuration. (Normally using HTTP instead of HTTPS for easier debugging.) debugServiceConfig :: config debugServiceConfig = defServiceConfig -- | @queryList f prefix xs@ constructs a query list from a list of -- elements @xs@, using a common prefix @prefix@, and a transformer -- function @f@. -- -- A dot (@.@) is interspersed between prefix and generated key. -- -- Example: -- -- @queryList swap \"pfx\" [(\"a\", \"b\"), (\"c\", \"d\")]@ evaluates to @[(\"pfx.b\", \"a\"), (\"pfx.d\", \"c\")]@ -- (except with ByteString instead of String, of course). queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)] queryList f prefix xs = concat $ zipWith combine prefixList (map f xs) where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..] combine pf = map $ first (pf `dot`) dot x y = B.concat [x, BU.fromString ".", y] -- | A \"true\"/\"false\" boolean as requested by some services. awsBool :: Bool -> B.ByteString awsBool True = "true" awsBool False = "false" -- | \"true\" awsTrue :: B.ByteString awsTrue = awsBool True -- | \"false\" awsFalse :: B.ByteString awsFalse = awsBool False -- | Format time according to a format string, as a ByteString. fmtTime :: String -> UTCTime -> B.ByteString fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t rfc822Time :: String rfc822Time = "%a, %0d %b %Y %H:%M:%S GMT" -- | Format time in RFC 822 format. fmtRfc822Time :: UTCTime -> B.ByteString fmtRfc822Time = fmtTime rfc822Time -- | Format time in yyyy-mm-ddThh-mm-ss format. fmtAmzTime :: UTCTime -> B.ByteString fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S" -- | Format time as seconds since the Unix epoch. fmtTimeEpochSeconds :: UTCTime -> B.ByteString fmtTimeEpochSeconds = fmtTime "%s" -- | Parse HTTP-date (section 3.3.1 of RFC 2616) parseHttpDate :: String -> Maybe UTCTime parseHttpDate s = p "%a, %d %b %Y %H:%M:%S GMT" s -- rfc1123-date <|> p "%A, %d-%b-%y %H:%M:%S GMT" s -- rfc850-date <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date <|> p "%Y-%m-%dT%H:%M:%S%QZ" s -- iso 8601 <|> p "%Y-%m-%dT%H:%M:%S%Q%Z" s -- iso 8601 where p = parseTimeM True defaultTimeLocale -- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) httpDate1 :: String httpDate1 = "%a, %d %b %Y %H:%M:%S GMT" -- rfc1123-date -- | Format (as Text) HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) textHttpDate :: UTCTime -> T.Text textHttpDate = T.pack . formatTime defaultTimeLocale httpDate1 iso8601UtcDate :: String iso8601UtcDate = "%Y-%m-%dT%H:%M:%S%QZ" -- | Parse a two-digit hex number. readHex2 :: [Char] -> Maybe Word8 readHex2 [c1,c2] = do n1 <- readHex1 c1 n2 <- readHex1 c2 return . fromIntegral $ n1 * 16 + n2 where readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0' | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10 | c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10 readHex1 _ = Nothing readHex2 _ = Nothing -- XML -- | An error that occurred during XML parsing / validation. newtype XmlException = XmlException { xmlErrorMessage :: String } deriving (Show, Typeable) instance E.Exception XmlException -- | An error that occurred during header parsing / validation. newtype HeaderException = HeaderException { headerErrorMessage :: String } deriving (Show, Typeable) instance E.Exception HeaderException -- | An error that occurred during form parsing / validation. newtype FormException = FormException { formErrorMesage :: String } deriving (Show, Typeable) instance E.Exception FormException -- | No credentials were found and an invariant was violated. newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMessage :: String } deriving (Show, Typeable) instance E.Exception NoCredentialsException -- | A helper to throw an 'HTTP.StatusCodeException'. throwStatusCodeException :: MonadThrow m => HTTP.Request -> HTTP.Response (C.ConduitM () ByteString m ()) -> m a throwStatusCodeException req resp = do let resp' = fmap (const ()) resp -- only take first 10kB of error response body <- C.runConduit $ HTTP.responseBody resp .| CB.take (10*1024) let sce = HTTP.StatusCodeException resp' (L.toStrict body) throwM $ HTTP.HttpExceptionRequest req sce -- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents. elContent :: T.Text -> Cursor -> [T.Text] elContent name = laxElement name &/ content -- | Like 'elContent', but extracts 'String's instead of 'T.Text'. elCont :: T.Text -> Cursor -> [String] elCont name = laxElement name &/ content &| T.unpack -- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty. force :: MonadThrow m => String -> [a] -> m a force = Cu.force . XmlException -- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty. forceM :: MonadThrow m => String -> [m a] -> m a forceM = Cu.forceM . XmlException -- | Read a boolean from a 'T.Text', throwing an 'XmlException' on failure. textReadBool :: MonadThrow m => T.Text -> m Bool textReadBool s = case T.unpack s of "true" -> return True "false" -> return False _ -> throwM $ XmlException "Invalid Bool" -- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure. textReadInt :: (MonadThrow m, Num a) => T.Text -> m a textReadInt s = case reads $ T.unpack s of [(n,"")] -> return $ fromInteger n _ -> throwM $ XmlException "Invalid Integer" -- | Read an integer from a 'String', throwing an 'XmlException' on failure. readInt :: (MonadThrow m, Num a) => String -> m a readInt s = case reads s of [(n,"")] -> return $ fromInteger n _ -> throwM $ XmlException "Invalid Integer" -- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response -- body. -- -- This function is highly recommended for any services that parse relatively short XML responses. (If status and response -- headers are required, simply take them as function parameters, and pass them through to this function.) xmlCursorConsumer :: (Monoid m) => (Cu.Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a xmlCursorConsumer parse metadataRef res = do doc <- C.runConduit $ HTTP.responseBody res .| XML.sinkDoc XML.def let cursor = Cu.fromDocument doc let Response metadata x = parse cursor liftIO $ tellMetadataRef metadataRef metadata case x of Left err -> liftIO $ throwM err Right v -> return v