{-# 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.Kind
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 :: Type
    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: /<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.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: /<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

-- | 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 :: Type {- Query Type -} -> 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 <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

    -- 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