aws-0.18: Aws/Core.hs
{-# 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
, authorizationV4
-- ** 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
-- * 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.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.ResumableSource (ResourceT IO) ByteString)
-> 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 <- 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
}
instance Show Credentials where
show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}"
makeCredentials :: MonadIO io
=> B.ByteString -- ^ AWS Access Key ID
-> B.ByteString -- ^ AWS Secret Access Key
-> io Credentials
makeCredentials accessKeyID secretAccessKey = liftIO $ do
v4SigningKeys <- newIORef []
let iamToken = Nothing
return Credentials { .. }
-- | The file where access credentials are loaded, when using 'loadCredentialsDefault'.
-- May return 'Nothing' if @HOME@ is unset.
--
-- Value: /<user directory>/@/.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.newManager HTTP.tlsManagerSettings
-- 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))
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: /<user directory>/@/.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
-- | 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').
#if MIN_VERSION_http_conduit(2, 0, 0)
, sqBody :: !(Maybe HTTP.RequestBody)
#else
, sqBody :: !(Maybe (HTTP.RequestBody (C.ResourceT IO)))
#endif
-- | 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.
#if MIN_VERSION_http_conduit(2, 0, 0)
queryToHttpRequest :: SignedQuery -> IO HTTP.Request
#else
queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO))
#endif
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)
-- | Use this to create the Authorization header to set into 'sqAuthorization'.
-- See <http://docs.aws.amazon.com/general/latest/gr/signature-version-4.html>: 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
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"
-- 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
key <- case mkey of
Just k -> return k
Nothing -> atomicModifyIORef ref $ \keylist ->
let secretKey = secretAccessKey $ signatureCredentials sd
kDate = mkHmac ("AWS4" <> secretKey) date
kRegion = mkHmac kDate region
kService = mkHmac kRegion service
kSigning = mkHmac kService "aws4_request"
lstK = (region,service)
keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist
in (keylist', kSigning)
-- now do the signature
let 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
]
sig = Base16.encode $ mkHmac key stringToSign
-- finally, return the header
return $ B.concat [ alg
, " Credential="
, accessKeyID (signatureCredentials sd)
, "/"
, date
, "/"
, region
, "/"
, service
, "/aws4_request,"
, "SignedHeaders="
, headers
, ",Signature="
, sig
]
-- | 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 = parseTime 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 :: HTTP.Request
-> HTTP.Response (C.ResumableSource (ResourceT IO) ByteString)
-> ResourceT IO a
#if MIN_VERSION_http_conduit(2,2,0)
throwStatusCodeException req resp = do
let resp' = fmap (const ()) resp
-- only take first 10kB of error response
body <- HTTP.responseBody resp C.$$+- CB.take (10*1024)
let sce = HTTP.StatusCodeException resp' (L.toStrict body)
throwM $ HTTP.HttpExceptionRequest req sce
#else
throwStatusCodeException _req resp = do
let cookies = HTTP.responseCookieJar resp
headers = HTTP.responseHeaders resp
status = HTTP.responseStatus resp
throwM $ HTTP.StatusCodeException status headers cookies
#endif
-- | 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 <- 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