{-# 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 { forall m a. Response m a -> m
responseMetadata :: m
                             , forall m a. Response m a -> Either SomeException a
responseResult :: Either E.SomeException a }
    deriving (Int -> Response m a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall m a. (Show m, Show a) => Int -> Response m a -> ShowS
forall m a. (Show m, Show a) => [Response m a] -> ShowS
forall m a. (Show m, Show a) => Response m a -> String
showList :: [Response m a] -> ShowS
$cshowList :: forall m a. (Show m, Show a) => [Response m a] -> ShowS
show :: Response m a -> String
$cshow :: forall m a. (Show m, Show a) => Response m a -> String
showsPrec :: Int -> Response m a -> ShowS
$cshowsPrec :: forall m a. (Show m, Show a) => Int -> Response m a -> ShowS
Show, forall a b. a -> Response m b -> Response m a
forall a b. (a -> b) -> Response m a -> Response m b
forall m a b. a -> Response m b -> Response m a
forall m a b. (a -> b) -> Response m a -> Response m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Response m b -> Response m a
$c<$ :: forall m a b. a -> Response m b -> Response m a
fmap :: forall a b. (a -> b) -> Response m a -> Response m b
$cfmap :: forall m a b. (a -> b) -> Response m a -> Response m b
Functor)

-- | Read a response result (if it's a success response, fail otherwise).
readResponse :: MonadThrow n => Response m a -> n a
readResponse :: forall (n :: * -> *) m a. MonadThrow n => Response m a -> n a
readResponse = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m a. Response m a -> Either SomeException a
responseResult

-- | Read a response result (if it's a success response, fail otherwise). In MonadIO.
readResponseIO :: MonadIO io => Response m a -> io a
readResponseIO :: forall (io :: * -> *) m a. MonadIO io => Response m a -> io a
readResponseIO = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: * -> *) m a. MonadThrow n => Response m a -> n a
readResponse

-- | An empty response with some metadata.
tellMetadata :: m -> Response m ()
tellMetadata :: forall m. m -> Response m ()
tellMetadata m
m = forall m a. m -> Either SomeException a -> Response m a
Response m
m (forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Apply a function to the metadata.
mapMetadata :: (m -> n) -> Response m a -> Response n a
mapMetadata :: forall m n a. (m -> n) -> Response m a -> Response n a
mapMetadata m -> n
f (Response m
m Either SomeException a
a) = forall m a. m -> Either SomeException a -> Response m a
Response (m -> n
f m
m) Either SomeException a
a

--multiResponse :: Monoid m => Response m a -> Response [m] a ->

instance Monoid m => Applicative (Response m) where
    pure :: forall a. a -> Response m a
pure a
x = forall m a. m -> Either SomeException a -> Response m a
Response forall a. Monoid a => a
mempty (forall a b. b -> Either a b
Right a
x)
    <*> :: forall a b. Response m (a -> b) -> Response m a -> Response m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monoid m => Monad (Response m) where
    return :: forall a. a -> Response m a
return a
x = forall m a. m -> Either SomeException a -> Response m a
Response forall a. Monoid a => a
mempty (forall a b. b -> Either a b
Right a
x)
    Response m
m1 (Left SomeException
e) >>= :: forall a b. Response m a -> (a -> Response m b) -> Response m b
>>= a -> Response m b
_ = forall m a. m -> Either SomeException a -> Response m a
Response m
m1 (forall a b. a -> Either a b
Left SomeException
e)
    Response m
m1 (Right a
x) >>= a -> Response m b
f = let Response m
m2 Either SomeException b
y = a -> Response m b
f a
x
                                  in forall m a. m -> Either SomeException a -> Response m a
Response (m
m1 forall a. Monoid a => a -> a -> a
`mappend` m
m2) Either SomeException b
y -- currently using First-semantics, Last SHOULD work too

instance Monoid m => MonadThrow (Response m) where
    throwM :: forall e a. Exception e => e -> Response m a
throwM e
e = forall m a. m -> Either SomeException a -> Response m a
Response forall a. Monoid a => a
mempty (forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e)

-- | Add metadata to an 'IORef' (using 'mappend').
tellMetadataRef :: Monoid m => IORef m -> m -> IO ()
tellMetadataRef :: forall m. Monoid m => IORef m -> m -> IO ()
tellMetadataRef IORef m
r m
m = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef m
r (forall a. Monoid a => a -> a -> a
`mappend` m
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 :: Request
-> r
-> IORef (ResponseMetadata (Response ByteString))
-> HTTPResponseConsumer (Response ByteString)
responseConsumer Request
_ r
_ IORef (ResponseMetadata (Response ByteString))
_ Response (ConduitM () ByteString (ResourceT IO) ())
resp = do
        [ByteString]
bss <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString (ResourceT IO) ())
resp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
        forall (m :: * -> *) a. Monad m => a -> m a
return Response (ConduitM () ByteString (ResourceT IO) ())
resp
            { responseBody :: ByteString
HTTP.responseBody = [ByteString] -> ByteString
L.fromChunks [ByteString]
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.
        Credentials -> ByteString
accessKeyID :: B.ByteString
        -- | AWS Secret Access Key.
      , Credentials -> ByteString
secretAccessKey :: B.ByteString
        -- | Signing keys for signature version 4
      , Credentials -> IORef [V4Key]
v4SigningKeys :: IORef [V4Key]
        -- | Signed IAM token
      , Credentials -> Maybe ByteString
iamToken :: Maybe B.ByteString
        -- | Set when the credentials are intended for anonymous access.
      , Credentials -> Bool
isAnonymousCredentials :: Bool
      }
instance Show Credentials where
    show :: Credentials -> String
show c :: Credentials
c@(Credentials {}) = String
"Credentials{accessKeyID=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Credentials -> ByteString
accessKeyID Credentials
c) forall a. [a] -> [a] -> [a]
++ String
",secretAccessKey=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Credentials -> ByteString
secretAccessKey Credentials
c) forall a. [a] -> [a] -> [a]
++ String
",iamToken=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Credentials -> Maybe ByteString
iamToken Credentials
c) forall a. [a] -> [a] -> [a]
++ String
"}"

makeCredentials :: MonadIO io
                => B.ByteString -- ^ AWS Access Key ID
                -> B.ByteString -- ^ AWS Secret Access Key
                -> io Credentials
makeCredentials :: forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials ByteString
accessKeyID ByteString
secretAccessKey = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    IORef [V4Key]
v4SigningKeys <- forall a. a -> IO (IORef a)
newIORef []
    let iamToken :: Maybe a
iamToken = forall a. Maybe a
Nothing
    let isAnonymousCredentials :: Bool
isAnonymousCredentials = Bool
False
    forall (m :: * -> *) a. Monad m => a -> m a
return Credentials { Bool
ByteString
IORef [V4Key]
forall a. Maybe a
isAnonymousCredentials :: Bool
iamToken :: forall a. Maybe a
v4SigningKeys :: IORef [V4Key]
secretAccessKey :: ByteString
accessKeyID :: ByteString
isAnonymousCredentials :: Bool
iamToken :: Maybe ByteString
v4SigningKeys :: IORef [V4Key]
secretAccessKey :: ByteString
accessKeyID :: ByteString
.. }

-- | 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 :: forall (io :: * -> *). MonadIO io => io (Maybe String)
credentialsDefaultFile = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Maybe a)
tryMaybe ((String -> ShowS
</> String
".aws-keys") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory)

tryMaybe :: IO a -> IO (Maybe a)
tryMaybe :: forall a. IO a -> IO (Maybe a)
tryMaybe IO a
action = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) forall a. SomeException -> IO (Maybe a)
f
  where
    f :: E.SomeException -> IO (Maybe a)
    f :: forall a. SomeException -> IO (Maybe a)
f SomeException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'.
--
-- Value: @default@
credentialsDefaultKey :: T.Text
credentialsDefaultKey :: Text
credentialsDefaultKey = Text
"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 :: forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromFile String
file Text
key = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Bool
exists <- String -> IO Bool
doesFileExist String
file
  if Bool
exists
    then do
      [[Text]]
contents <- forall a b. (a -> b) -> [a] -> [b]
map Text -> [Text]
T.words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
file
      forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
Traversable.sequence forall a b. (a -> b) -> a -> b
$ do
        [Text
_key, Text
keyID, Text
secret] <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall {a}. Eq a => a -> [a] -> Bool
hasKey Text
key) [[Text]]
contents
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials (Text -> ByteString
T.encodeUtf8 Text
keyID) (Text -> ByteString
T.encodeUtf8 Text
secret))
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    hasKey :: a -> [a] -> Bool
hasKey a
_ [] = Bool
False
    hasKey a
k (a
k2 : [a]
_) = a
k forall a. Eq a => a -> a -> Bool
== a
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 :: forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  let lk :: String -> Maybe ByteString
lk = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(String, String)]
env
      keyID :: Maybe ByteString
keyID = String -> Maybe ByteString
lk String
"AWS_ACCESS_KEY_ID"
      secret :: Maybe ByteString
secret = String -> Maybe ByteString
lk String
"AWS_ACCESS_KEY_SECRET" forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe ByteString
lk String
"AWS_SECRET_ACCESS_KEY"
      setSession :: Credentials -> Credentials
setSession Credentials
creds = Credentials
creds { iamToken :: Maybe ByteString
iamToken = String -> Maybe ByteString
lk String
"AWS_SESSION_TOKEN" }
      makeCredentials' :: ByteString -> ByteString -> IO Credentials
makeCredentials' ByteString
k ByteString
s = Credentials -> Credentials
setSession forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials ByteString
k ByteString
s
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
Traversable.sequence forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> IO Credentials
makeCredentials' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
keyID forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ByteString
secret

loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials)
loadCredentialsFromInstanceMetadata :: forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromInstanceMetadata = do
    Manager
mgr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
HTTP.getGlobalManager
    -- check if the path is routable
    Bool
avail <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
hostAvailable String
"169.254.169.254"
    if Bool -> Bool
not Bool
avail
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else do
        Maybe ByteString
info <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Manager -> String -> String -> IO ByteString
getInstanceMetadata Manager
mgr String
"latest/meta-data/iam" String
"info" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) (\(HttpException
_ :: HTTP.HttpException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
        let infodict :: Maybe (Map String String)
infodict = Maybe ByteString
info forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FromJSON a => ByteString -> Maybe a
A.decode :: Maybe (M.Map String String)
            info' :: Maybe String
info'    = Maybe (Map String String)
infodict forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"InstanceProfileArn"
        case Maybe String
info' of
          Just String
name ->
            do
              let name' :: String
name' = forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall a b. (a -> b) -> a -> b
$ String
name
              Maybe ByteString
creds <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Manager -> String -> String -> IO ByteString
getInstanceMetadata Manager
mgr String
"latest/meta-data/iam/security-credentials" String
name' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) (\(HttpException
_ :: HTTP.HttpException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
              -- this token lasts ~6 hours
              let dict :: Maybe (Map String String)
dict   = Maybe ByteString
creds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FromJSON a => ByteString -> Maybe a
A.decode :: Maybe (M.Map String String)
                  keyID :: Maybe String
keyID  = Maybe (Map String String)
dict  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"AccessKeyId"
                  secret :: Maybe String
secret = Maybe (Map String String)
dict  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"SecretAccessKey"
                  token :: Maybe String
token  = Maybe (Map String String)
dict  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"Token"
              IORef [V4Key]
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
              forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
-> ByteString
-> IORef [V4Key]
-> Maybe ByteString
-> Bool
-> Credentials
Credentials forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
keyID)
                                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
secret)
                                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return IORef [V4Key]
ref
                                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
token)
                                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
          Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
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 :: forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFile String
file Text
key =
  do
    Maybe Credentials
envcr <- forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv
    case Maybe Credentials
envcr of
      Just Credentials
cr -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Credentials
cr)
      Maybe Credentials
Nothing -> forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromFile String
file Text
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 :: forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFileOrInstanceMetadata String
file Text
key =
  do
    Maybe Credentials
envcr <- forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv
    case Maybe Credentials
envcr of
      Just Credentials
cr -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Credentials
cr)
      Maybe Credentials
Nothing ->
        do
          Maybe Credentials
filecr <- forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromFile String
file Text
key
          case Maybe Credentials
filecr of
            Just Credentials
cr -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Credentials
cr)
            Maybe Credentials
Nothing -> forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
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 :: forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsDefault = do
  Maybe String
mfile <- forall (io :: * -> *). MonadIO io => io (Maybe String)
credentialsDefaultFile
  case Maybe String
mfile of
      Just String
file -> forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFileOrInstanceMetadata String
file Text
credentialsDefaultKey
      Maybe String
Nothing   -> forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv

-- | Make a dummy Credentials that can be used to access some AWS services
-- anonymously.
anonymousCredentials :: MonadIO io => io Credentials
anonymousCredentials :: forall (io :: * -> *). MonadIO io => io Credentials
anonymousCredentials = do
  Credentials
cr <- forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials
cr { isAnonymousCredentials :: Bool
isAnonymousCredentials = Bool
True })

-- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols.
data Protocol
    = HTTP
    | HTTPS
    deriving (Protocol -> Protocol -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Protocol -> Protocol -> Bool
$c/= :: Protocol -> Protocol -> Bool
== :: Protocol -> Protocol -> Bool
$c== :: Protocol -> Protocol -> Bool
Eq,ReadPrec [Protocol]
ReadPrec Protocol
Int -> ReadS Protocol
ReadS [Protocol]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Protocol]
$creadListPrec :: ReadPrec [Protocol]
readPrec :: ReadPrec Protocol
$creadPrec :: ReadPrec Protocol
readList :: ReadS [Protocol]
$creadList :: ReadS [Protocol]
readsPrec :: Int -> ReadS Protocol
$creadsPrec :: Int -> ReadS Protocol
Read,Int -> Protocol -> ShowS
[Protocol] -> ShowS
Protocol -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Protocol] -> ShowS
$cshowList :: [Protocol] -> ShowS
show :: Protocol -> String
$cshow :: Protocol -> String
showsPrec :: Int -> Protocol -> ShowS
$cshowsPrec :: Int -> Protocol -> ShowS
Show,Eq Protocol
Protocol -> Protocol -> Bool
Protocol -> Protocol -> Ordering
Protocol -> Protocol -> Protocol
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Protocol -> Protocol -> Protocol
$cmin :: Protocol -> Protocol -> Protocol
max :: Protocol -> Protocol -> Protocol
$cmax :: Protocol -> Protocol -> Protocol
>= :: Protocol -> Protocol -> Bool
$c>= :: Protocol -> Protocol -> Bool
> :: Protocol -> Protocol -> Bool
$c> :: Protocol -> Protocol -> Bool
<= :: Protocol -> Protocol -> Bool
$c<= :: Protocol -> Protocol -> Bool
< :: Protocol -> Protocol -> Bool
$c< :: Protocol -> Protocol -> Bool
compare :: Protocol -> Protocol -> Ordering
$ccompare :: Protocol -> Protocol -> Ordering
Ord,Typeable)

-- | The default port to be used for a protocol if no specific port is specified.
defaultPort :: Protocol -> Int
defaultPort :: Protocol -> Int
defaultPort Protocol
HTTP = Int
80
defaultPort Protocol
HTTPS = Int
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 (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show, Method -> Method -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq, Eq Method
Method -> Method -> Bool
Method -> Method -> Ordering
Method -> Method -> Method
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Method -> Method -> Method
$cmin :: Method -> Method -> Method
max :: Method -> Method -> Method
$cmax :: Method -> Method -> Method
>= :: Method -> Method -> Bool
$c>= :: Method -> Method -> Bool
> :: Method -> Method -> Bool
$c> :: Method -> Method -> Bool
<= :: Method -> Method -> Bool
$c<= :: Method -> Method -> Bool
< :: Method -> Method -> Bool
$c< :: Method -> Method -> Bool
compare :: Method -> Method -> Ordering
$ccompare :: Method -> Method -> Ordering
Ord)

-- | HTTP method associated with a request method.
httpMethod :: Method -> HTTP.Method
httpMethod :: Method -> ByteString
httpMethod Method
Head      = ByteString
"HEAD"
httpMethod Method
Get       = ByteString
"GET"
httpMethod Method
PostQuery = ByteString
"POST"
httpMethod Method
Post      = ByteString
"POST"
httpMethod Method
Put       = ByteString
"PUT"
httpMethod Method
Delete    = ByteString
"DELETE"

-- | A pre-signed medium-level request object.
data SignedQuery
    = SignedQuery {
        -- | Request method.
        SignedQuery -> Method
sqMethod :: !Method
        -- | Protocol to be used.
      , SignedQuery -> Protocol
sqProtocol :: !Protocol
        -- | HTTP host.
      , SignedQuery -> ByteString
sqHost :: !B.ByteString
        -- | IP port.
      , SignedQuery -> Int
sqPort :: !Int
        -- | HTTP path.
      , SignedQuery -> ByteString
sqPath :: !B.ByteString
        -- | Query string list (used with 'Get' and 'PostQuery').
      , SignedQuery -> Query
sqQuery :: !HTTP.Query
        -- | Request date/time.
      , SignedQuery -> Maybe UTCTime
sqDate :: !(Maybe UTCTime)
        -- | Authorization string (if applicable), for @Authorization@ header.  See 'authorizationV4'
      , SignedQuery -> Maybe (IO ByteString)
sqAuthorization :: !(Maybe (IO B.ByteString))
        -- | Request body content type.
      , SignedQuery -> Maybe ByteString
sqContentType :: !(Maybe B.ByteString)
        -- | Request body content MD5.
      , SignedQuery -> Maybe (Digest MD5)
sqContentMd5 :: !(Maybe (CH.Digest CH.MD5))
        -- | Additional Amazon "amz" headers.
      , SignedQuery -> RequestHeaders
sqAmzHeaders :: !HTTP.RequestHeaders
        -- | Additional non-"amz" headers.
      , SignedQuery -> RequestHeaders
sqOtherHeaders :: !HTTP.RequestHeaders
        -- | Request body (used with 'Post' and 'Put').
      , SignedQuery -> Maybe RequestBody
sqBody :: !(Maybe HTTP.RequestBody)
        -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes.
      , SignedQuery -> ByteString
sqStringToSign :: !B.ByteString
      }
    --deriving (Show)

-- | Create a HTTP request from a 'SignedQuery' object.
queryToHttpRequest :: SignedQuery -> IO HTTP.Request
queryToHttpRequest :: SignedQuery -> IO Request
queryToHttpRequest SignedQuery{Int
Query
RequestHeaders
Maybe (IO ByteString)
Maybe ByteString
Maybe UTCTime
Maybe (Digest MD5)
Maybe RequestBody
ByteString
Method
Protocol
sqStringToSign :: ByteString
sqBody :: Maybe RequestBody
sqOtherHeaders :: RequestHeaders
sqAmzHeaders :: RequestHeaders
sqContentMd5 :: Maybe (Digest MD5)
sqContentType :: Maybe ByteString
sqAuthorization :: Maybe (IO ByteString)
sqDate :: Maybe UTCTime
sqQuery :: Query
sqPath :: ByteString
sqPort :: Int
sqHost :: ByteString
sqProtocol :: Protocol
sqMethod :: Method
sqStringToSign :: SignedQuery -> ByteString
sqBody :: SignedQuery -> Maybe RequestBody
sqOtherHeaders :: SignedQuery -> RequestHeaders
sqAmzHeaders :: SignedQuery -> RequestHeaders
sqContentMd5 :: SignedQuery -> Maybe (Digest MD5)
sqContentType :: SignedQuery -> Maybe ByteString
sqAuthorization :: SignedQuery -> Maybe (IO ByteString)
sqDate :: SignedQuery -> Maybe UTCTime
sqQuery :: SignedQuery -> Query
sqPath :: SignedQuery -> ByteString
sqPort :: SignedQuery -> Int
sqHost :: SignedQuery -> ByteString
sqProtocol :: SignedQuery -> Protocol
sqMethod :: SignedQuery -> Method
..} =  do
    Maybe ByteString
mauth <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Justforall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) Maybe (IO ByteString)
sqAuthorization
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest {
        method :: ByteString
HTTP.method = Method -> ByteString
httpMethod Method
sqMethod
      , secure :: Bool
HTTP.secure = case Protocol
sqProtocol of
                        Protocol
HTTP -> Bool
False
                        Protocol
HTTPS -> Bool
True
      , host :: ByteString
HTTP.host = ByteString
sqHost
      , port :: Int
HTTP.port = Int
sqPort
      , path :: ByteString
HTTP.path = ByteString
sqPath
      , queryString :: ByteString
HTTP.queryString =
          if Method
sqMethod forall a. Eq a => a -> a -> Bool
== Method
PostQuery
            then ByteString
""
            else Bool -> Query -> ByteString
HTTP.renderQuery Bool
False Query
sqQuery

      , requestHeaders :: RequestHeaders
HTTP.requestHeaders = forall a. [Maybe a] -> [a]
catMaybes [ (UTCTime -> Header) -> Maybe UTCTime -> Maybe Header
checkDate (\UTCTime
d -> (HeaderName
"Date", UTCTime -> ByteString
fmtRfc822Time UTCTime
d)) Maybe UTCTime
sqDate
                                        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
c -> (HeaderName
"Content-Type", ByteString
c)) Maybe ByteString
contentType
                                        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Digest MD5
md5 -> (HeaderName
"Content-MD5", ByteString -> ByteString
Base64.encode forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert Digest MD5
md5)) Maybe (Digest MD5)
sqContentMd5
                                        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ByteString
auth -> (HeaderName
"Authorization", ByteString
auth)) Maybe ByteString
mauth]
                              forall a. [a] -> [a] -> [a]
++ RequestHeaders
sqAmzHeaders
                              forall a. [a] -> [a] -> [a]
++ RequestHeaders
sqOtherHeaders
      , requestBody :: RequestBody
HTTP.requestBody =

        -- An explicityly defined body parameter should overwrite everything else.
        case Maybe RequestBody
sqBody of
          Just RequestBody
x -> RequestBody
x
          Maybe RequestBody
Nothing ->
            -- a POST query should convert its query string into the body
            case Method
sqMethod of
              Method
PostQuery -> ByteString -> RequestBody
HTTP.RequestBodyLBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString forall a b. (a -> b) -> a -> b
$
                           Bool -> Query -> Builder
HTTP.renderQueryBuilder Bool
False Query
sqQuery
              Method
_         -> Int64 -> Builder -> RequestBody
HTTP.RequestBodyBuilder Int64
0 forall a. Monoid a => a
mempty

      , decompress :: ByteString -> Bool
HTTP.decompress = ByteString -> Bool
HTTP.alwaysDecompress
#if MIN_VERSION_http_conduit(2,2,0)
      , checkResponse :: Request -> Response (IO ByteString) -> IO ()
HTTP.checkResponse = \Request
_ Response (IO ByteString)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
      , HTTP.checkStatus = \_ _ _-> Nothing
#endif

      , redirectCount :: Int
HTTP.redirectCount = Int
10
      }
    where
      checkDate :: (UTCTime -> Header) -> Maybe UTCTime -> Maybe Header
checkDate UTCTime -> Header
f Maybe UTCTime
mb = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UTCTime -> Header
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"date" RequestHeaders
sqOtherHeaders
      -- An explicitly defined content-type should override everything else.
      contentType :: Maybe ByteString
contentType = Maybe ByteString
sqContentType forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ByteString
defContentType
      defContentType :: Maybe ByteString
defContentType = case Method
sqMethod of
                         Method
PostQuery -> forall a. a -> Maybe a
Just ByteString
"application/x-www-form-urlencoded; charset=utf-8"
                         Method
_ -> forall a. Maybe a
Nothing

-- | Create a URI fro a 'SignedQuery' object.
--
-- Unused / incompatible fields will be silently ignored.
queryToUri :: SignedQuery -> B.ByteString
queryToUri :: SignedQuery -> ByteString
queryToUri SignedQuery{Int
Query
RequestHeaders
Maybe (IO ByteString)
Maybe ByteString
Maybe UTCTime
Maybe (Digest MD5)
Maybe RequestBody
ByteString
Method
Protocol
sqStringToSign :: ByteString
sqBody :: Maybe RequestBody
sqOtherHeaders :: RequestHeaders
sqAmzHeaders :: RequestHeaders
sqContentMd5 :: Maybe (Digest MD5)
sqContentType :: Maybe ByteString
sqAuthorization :: Maybe (IO ByteString)
sqDate :: Maybe UTCTime
sqQuery :: Query
sqPath :: ByteString
sqPort :: Int
sqHost :: ByteString
sqProtocol :: Protocol
sqMethod :: Method
sqStringToSign :: SignedQuery -> ByteString
sqBody :: SignedQuery -> Maybe RequestBody
sqOtherHeaders :: SignedQuery -> RequestHeaders
sqAmzHeaders :: SignedQuery -> RequestHeaders
sqContentMd5 :: SignedQuery -> Maybe (Digest MD5)
sqContentType :: SignedQuery -> Maybe ByteString
sqAuthorization :: SignedQuery -> Maybe (IO ByteString)
sqDate :: SignedQuery -> Maybe UTCTime
sqQuery :: SignedQuery -> Query
sqPath :: SignedQuery -> ByteString
sqPort :: SignedQuery -> Int
sqHost :: SignedQuery -> ByteString
sqProtocol :: SignedQuery -> Protocol
sqMethod :: SignedQuery -> Method
..}
    = [ByteString] -> ByteString
B.concat [
       case Protocol
sqProtocol of
         Protocol
HTTP -> ByteString
"http://"
         Protocol
HTTPS -> ByteString
"https://"
      , ByteString
sqHost
      , if Int
sqPort forall a. Eq a => a -> a -> Bool
== Protocol -> Int
defaultPort Protocol
sqProtocol then ByteString
"" else Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
sqPort
      , ByteString
sqPath
      , Bool -> Query -> ByteString
HTTP.renderQuery Bool
True Query
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 { TimeInfo -> UTCTime
fromExpiresAt :: UTCTime }         -- ^ Let requests expire at a specific fixed time.
    | ExpiresIn { TimeInfo -> NominalDiffTime
fromExpiresIn :: NominalDiffTime } -- ^ Let requests expire a specific number of seconds after they
                                                     -- were generated.
    deriving (Int -> TimeInfo -> ShowS
[TimeInfo] -> ShowS
TimeInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeInfo] -> ShowS
$cshowList :: [TimeInfo] -> ShowS
show :: TimeInfo -> String
$cshow :: TimeInfo -> String
showsPrec :: Int -> TimeInfo -> ShowS
$cshowsPrec :: Int -> TimeInfo -> ShowS
Show)

-- | Like 'TimeInfo', but with all relative times replaced by absolute UTC.
data AbsoluteTimeInfo
    = AbsoluteTimestamp { AbsoluteTimeInfo -> UTCTime
fromAbsoluteTimestamp :: UTCTime }
    | AbsoluteExpires { AbsoluteTimeInfo -> UTCTime
fromAbsoluteExpires :: UTCTime }
    deriving (Int -> AbsoluteTimeInfo -> ShowS
[AbsoluteTimeInfo] -> ShowS
AbsoluteTimeInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbsoluteTimeInfo] -> ShowS
$cshowList :: [AbsoluteTimeInfo] -> ShowS
show :: AbsoluteTimeInfo -> String
$cshow :: AbsoluteTimeInfo -> String
showsPrec :: Int -> AbsoluteTimeInfo -> ShowS
$cshowsPrec :: Int -> AbsoluteTimeInfo -> ShowS
Show)

-- | Just the UTC time value.
fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime
fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime
fromAbsoluteTimeInfo (AbsoluteTimestamp UTCTime
time) = UTCTime
time
fromAbsoluteTimeInfo (AbsoluteExpires UTCTime
time) = UTCTime
time

-- | Convert 'TimeInfo' to 'AbsoluteTimeInfo' given the current UTC time.
makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo
makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo
makeAbsoluteTimeInfo TimeInfo
Timestamp     UTCTime
now = UTCTime -> AbsoluteTimeInfo
AbsoluteTimestamp UTCTime
now
makeAbsoluteTimeInfo (ExpiresAt UTCTime
t) UTCTime
_   = UTCTime -> AbsoluteTimeInfo
AbsoluteExpires UTCTime
t
makeAbsoluteTimeInfo (ExpiresIn NominalDiffTime
s) UTCTime
now = UTCTime -> AbsoluteTimeInfo
AbsoluteExpires forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
s UTCTime
now

-- | Data that is always required for signing requests.
data SignatureData
    = SignatureData {
        -- | Expiration or timestamp.
        SignatureData -> AbsoluteTimeInfo
signatureTimeInfo :: AbsoluteTimeInfo
        -- | Current time.
      , SignatureData -> UTCTime
signatureTime :: UTCTime
        -- | Access credentials.
      , SignatureData -> Credentials
signatureCredentials :: Credentials
      }

-- | Create signature data using the current system time.
signatureData :: TimeInfo -> Credentials -> IO SignatureData
signatureData :: TimeInfo -> Credentials -> IO SignatureData
signatureData TimeInfo
rti Credentials
cr = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let ti :: AbsoluteTimeInfo
ti = TimeInfo -> UTCTime -> AbsoluteTimeInfo
makeAbsoluteTimeInfo TimeInfo
rti UTCTime
now
  forall (m :: * -> *) a. Monad m => a -> m a
return SignatureData { signatureTimeInfo :: AbsoluteTimeInfo
signatureTimeInfo = AbsoluteTimeInfo
ti, signatureTime :: UTCTime
signatureTime = UTCTime
now, signatureCredentials :: Credentials
signatureCredentials = Credentials
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 (Int -> AuthorizationHash -> ShowS
[AuthorizationHash] -> ShowS
AuthorizationHash -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthorizationHash] -> ShowS
$cshowList :: [AuthorizationHash] -> ShowS
show :: AuthorizationHash -> String
$cshow :: AuthorizationHash -> String
showsPrec :: Int -> AuthorizationHash -> ShowS
$cshowsPrec :: Int -> AuthorizationHash -> ShowS
Show)

-- | Authorization hash identifier as expected by Amazon.
amzHash :: AuthorizationHash -> B.ByteString
amzHash :: AuthorizationHash -> ByteString
amzHash AuthorizationHash
HmacSHA1 = ByteString
"HmacSHA1"
amzHash AuthorizationHash
HmacSHA256 = ByteString
"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 :: Credentials -> AuthorizationHash -> ByteString -> ByteString
signature Credentials
cr AuthorizationHash
ah ByteString
input = ByteString -> ByteString
Base64.encode ByteString
sig
    where
      sig :: ByteString
sig = case AuthorizationHash
ah of
              AuthorizationHash
HmacSHA1 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
CMH.hmac (Credentials -> ByteString
secretAccessKey Credentials
cr) ByteString
input :: CMH.HMAC CH.SHA1)
              AuthorizationHash
HmacSHA256 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
CMH.hmac (Credentials -> ByteString
secretAccessKey Credentials
cr) ByteString
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 :: SignatureData -> ByteString -> ByteString -> ByteString
credentialV4 SignatureData
sd ByteString
region ByteString
service = [ByteString] -> ByteString
B.concat
    [ Credentials -> ByteString
accessKeyID (SignatureData -> Credentials
signatureCredentials SignatureData
sd)
    , ByteString
"/"
    , ByteString
date
    , ByteString
"/"
    , ByteString
region
    , ByteString
"/"
    , ByteString
service
    , ByteString
"/aws4_request"
    ]
    where
        date :: ByteString
date = String -> UTCTime -> ByteString
fmtTime String
"%Y%m%d" forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
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 :: SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> IO ByteString
authorizationV4 SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
headers ByteString
canonicalRequest = do
    let ref :: IORef [V4Key]
ref = Credentials -> IORef [V4Key]
v4SigningKeys forall a b. (a -> b) -> a -> b
$ SignatureData -> Credentials
signatureCredentials SignatureData
sd
        date :: ByteString
date = String -> UTCTime -> ByteString
fmtTime String
"%Y%m%d" forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd

    -- Lookup existing signing key
    [V4Key]
allkeys <- forall a. IORef a -> IO a
readIORef IORef [V4Key]
ref
    let mkey :: Maybe ByteString
mkey = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString
region,ByteString
service) [V4Key]
allkeys of
            Just (ByteString
d,ByteString
k) | ByteString
d forall a. Eq a => a -> a -> Bool
/= ByteString
date -> forall a. Maybe a
Nothing
                       | Bool
otherwise -> forall a. a -> Maybe a
Just ByteString
k
            Maybe (ByteString, ByteString)
Nothing -> forall a. Maybe a
Nothing

    -- possibly create a new signing key
    let createNewKey :: IO ByteString
createNewKey = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [V4Key]
ref forall a b. (a -> b) -> a -> b
$ \[V4Key]
keylist ->
            let kSigning :: ByteString
kSigning = SignatureData
-> AuthorizationHash -> ByteString -> ByteString -> ByteString
signingKeyV4 SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service
                lstK :: (ByteString, ByteString)
lstK     = (ByteString
region,ByteString
service)
                keylist' :: [V4Key]
keylist' = ((ByteString, ByteString)
lstK,(ByteString
date,ByteString
kSigning)) forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (((ByteString, ByteString)
lstKforall a. Eq a => a -> a -> Bool
/=)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) [V4Key]
keylist
             in ([V4Key]
keylist', ByteString
kSigning)

    -- finally, return the header
    SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
constructAuthorizationV4Header SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
headers
         forall b c a. (b -> c) -> (a -> b) -> a -> c
.  SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4WithKey SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
canonicalRequest
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
createNewKey forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
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' :: SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
authorizationV4' SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
headers ByteString
canonicalRequest
    = SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
constructAuthorizationV4Header SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
headers
        forall a b. (a -> b) -> a -> b
$ SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4 SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
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 :: SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
constructAuthorizationV4Header SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
headers ByteString
sig = [ByteString] -> ByteString
B.concat
    [ ByteString
alg
    , ByteString
" Credential="
    , SignatureData -> ByteString -> ByteString -> ByteString
credentialV4 SignatureData
sd ByteString
region ByteString
service
    , ByteString
",SignedHeaders="
    , ByteString
headers
    , ByteString
",Signature="
    , ByteString
sig
    ]
    where
        alg :: ByteString
alg = case AuthorizationHash
ah of
            AuthorizationHash
HmacSHA1 -> ByteString
"AWS4-HMAC-SHA1"
            AuthorizationHash
HmacSHA256 -> ByteString
"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 :: SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4WithKey SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
canonicalRequest ByteString
key = ByteString -> ByteString
Base16.encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
mkHmac ByteString
key ByteString
stringToSign
    where
        date :: ByteString
date = String -> UTCTime -> ByteString
fmtTime String
"%Y%m%d" forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
        mkHmac :: ByteString -> ByteString -> ByteString
mkHmac ByteString
k ByteString
i = case AuthorizationHash
ah of
            AuthorizationHash
HmacSHA1 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
CMH.hmac ByteString
k ByteString
i :: CMH.HMAC CH.SHA1)
            AuthorizationHash
HmacSHA256 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
CMH.hmac ByteString
k ByteString
i :: CMH.HMAC CH.SHA256)
        mkHash :: ByteString -> ByteString
mkHash ByteString
i = case AuthorizationHash
ah of
            AuthorizationHash
HmacSHA1 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash ByteString
i :: CH.Digest CH.SHA1)
            AuthorizationHash
HmacSHA256 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash ByteString
i :: CH.Digest CH.SHA256)
        alg :: ByteString
alg = case AuthorizationHash
ah of
            AuthorizationHash
HmacSHA1 -> ByteString
"AWS4-HMAC-SHA1"
            AuthorizationHash
HmacSHA256 -> ByteString
"AWS4-HMAC-SHA256"

        -- now do the signature
        canonicalRequestHash :: ByteString
canonicalRequestHash = ByteString -> ByteString
Base16.encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
mkHash ByteString
canonicalRequest
        stringToSign :: ByteString
stringToSign = [ByteString] -> ByteString
B.concat
            [ ByteString
alg
            , ByteString
"\n"
            , String -> UTCTime -> ByteString
fmtTime String
"%Y%m%dT%H%M%SZ" forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
            , ByteString
"\n"
            , ByteString
date
            , ByteString
"/"
            , ByteString
region
            , ByteString
"/"
            , ByteString
service
            , ByteString
"/aws4_request\n"
            , ByteString
canonicalRequestHash
            ]

signingKeyV4
    :: SignatureData
    -> AuthorizationHash
    -> B.ByteString -- ^ region, e.g. us-east-1
    -> B.ByteString -- ^ service, e.g. dynamodb
    -> B.ByteString
signingKeyV4 :: SignatureData
-> AuthorizationHash -> ByteString -> ByteString -> ByteString
signingKeyV4 SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service = ByteString
kSigning
    where
        mkHmac :: ByteString -> ByteString -> ByteString
mkHmac ByteString
k ByteString
i = case AuthorizationHash
ah of
            AuthorizationHash
HmacSHA1 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
CMH.hmac ByteString
k ByteString
i :: CMH.HMAC CH.SHA1)
            AuthorizationHash
HmacSHA256 -> forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
CMH.hmac ByteString
k ByteString
i :: CMH.HMAC CH.SHA256)
        date :: ByteString
date = String -> UTCTime -> ByteString
fmtTime String
"%Y%m%d" forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
        secretKey :: ByteString
secretKey = Credentials -> ByteString
secretAccessKey forall a b. (a -> b) -> a -> b
$ SignatureData -> Credentials
signatureCredentials SignatureData
sd
        kDate :: ByteString
kDate = ByteString -> ByteString -> ByteString
mkHmac (ByteString
"AWS4" forall a. Semigroup a => a -> a -> a
<> ByteString
secretKey) ByteString
date
        kRegion :: ByteString
kRegion = ByteString -> ByteString -> ByteString
mkHmac ByteString
kDate ByteString
region
        kService :: ByteString
kService = ByteString -> ByteString -> ByteString
mkHmac ByteString
kRegion ByteString
service
        kSigning :: ByteString
kSigning = ByteString -> ByteString -> ByteString
mkHmac ByteString
kService ByteString
"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 :: SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4 SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
canonicalRequest
    = SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4WithKey SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
service ByteString
canonicalRequest
        forall a b. (a -> b) -> a -> b
$ SignatureData
-> AuthorizationHash -> ByteString -> ByteString -> ByteString
signingKeyV4 SignatureData
sd AuthorizationHash
ah ByteString
region ByteString
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 = forall config. DefaultServiceConfiguration config => config
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 :: forall a.
(a -> [(ByteString, ByteString)])
-> ByteString -> [a] -> [(ByteString, ByteString)]
queryList a -> [(ByteString, ByteString)]
f ByteString
prefix [a]
xs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {d}. ByteString -> [(ByteString, d)] -> [(ByteString, d)]
combine [ByteString]
prefixList (forall a b. (a -> b) -> [a] -> [b]
map a -> [(ByteString, ByteString)]
f [a]
xs)
    where prefixList :: [ByteString]
prefixList = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
dot ByteString
prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BU.fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [(Int
1 :: Int) ..]
          combine :: ByteString -> [(ByteString, d)] -> [(ByteString, d)]
combine ByteString
pf = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (ByteString
pf ByteString -> ByteString -> ByteString
`dot`)
          dot :: ByteString -> ByteString -> ByteString
dot ByteString
x ByteString
y = [ByteString] -> ByteString
B.concat [ByteString
x, String -> ByteString
BU.fromString String
".", ByteString
y]

-- | A \"true\"/\"false\" boolean as requested by some services.
awsBool :: Bool -> B.ByteString
awsBool :: Bool -> ByteString
awsBool Bool
True = ByteString
"true"
awsBool Bool
False = ByteString
"false"

-- | \"true\"
awsTrue :: B.ByteString
awsTrue :: ByteString
awsTrue = Bool -> ByteString
awsBool Bool
True

-- | \"false\"
awsFalse :: B.ByteString
awsFalse :: ByteString
awsFalse = Bool -> ByteString
awsBool Bool
False

-- | Format time according to a format string, as a ByteString.
fmtTime :: String -> UTCTime -> B.ByteString
fmtTime :: String -> UTCTime -> ByteString
fmtTime String
s UTCTime
t = String -> ByteString
BU.fromString forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
s UTCTime
t

rfc822Time :: String
rfc822Time :: String
rfc822Time = String
"%a, %0d %b %Y %H:%M:%S GMT"

-- | Format time in RFC 822 format.
fmtRfc822Time :: UTCTime -> B.ByteString
fmtRfc822Time :: UTCTime -> ByteString
fmtRfc822Time = String -> UTCTime -> ByteString
fmtTime String
rfc822Time

-- | Format time in yyyy-mm-ddThh-mm-ss format.
fmtAmzTime :: UTCTime -> B.ByteString
fmtAmzTime :: UTCTime -> ByteString
fmtAmzTime = String -> UTCTime -> ByteString
fmtTime String
"%Y-%m-%dT%H:%M:%S"

-- | Format time as seconds since the Unix epoch.
fmtTimeEpochSeconds :: UTCTime -> B.ByteString
fmtTimeEpochSeconds :: UTCTime -> ByteString
fmtTimeEpochSeconds = String -> UTCTime -> ByteString
fmtTime String
"%s"

-- | Parse HTTP-date (section 3.3.1 of RFC 2616)
parseHttpDate :: String -> Maybe UTCTime
parseHttpDate :: String -> Maybe UTCTime
parseHttpDate String
s =     String -> String -> Maybe UTCTime
p String
"%a, %d %b %Y %H:%M:%S GMT" String
s -- rfc1123-date
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p String
"%A, %d-%b-%y %H:%M:%S GMT" String
s -- rfc850-date
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p String
"%a %b %_d %H:%M:%S %Y" String
s     -- asctime-date
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p String
"%Y-%m-%dT%H:%M:%S%QZ" String
s      -- iso 8601
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p String
"%Y-%m-%dT%H:%M:%S%Q%Z" String
s     -- iso 8601
  where p :: String -> String -> Maybe UTCTime
p = forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale

-- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style)
httpDate1 :: String
httpDate1 :: String
httpDate1 = String
"%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 :: UTCTime -> Text
textHttpDate = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
httpDate1

iso8601UtcDate :: String
iso8601UtcDate :: String
iso8601UtcDate = String
"%Y-%m-%dT%H:%M:%S%QZ"

-- | Parse a two-digit hex number.
readHex2 :: [Char] -> Maybe Word8
readHex2 :: String -> Maybe Word8
readHex2 [Char
c1,Char
c2] = do Int
n1 <- Char -> Maybe Int
readHex1 Char
c1
                      Int
n2 <- Char -> Maybe Int
readHex1 Char
c2
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
n1 forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ Int
n2
    where
      readHex1 :: Char -> Maybe Int
readHex1 Char
c | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'
                 | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'F' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' forall a. Num a => a -> a -> a
+ Int
10
                 | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'f' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' forall a. Num a => a -> a -> a
+ Int
10
      readHex1 Char
_                        = forall a. Maybe a
Nothing
readHex2 String
_ = forall a. Maybe a
Nothing

-- XML

-- | An error that occurred during XML parsing / validation.
newtype XmlException = XmlException { XmlException -> String
xmlErrorMessage :: String }
    deriving (Int -> XmlException -> ShowS
[XmlException] -> ShowS
XmlException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XmlException] -> ShowS
$cshowList :: [XmlException] -> ShowS
show :: XmlException -> String
$cshow :: XmlException -> String
showsPrec :: Int -> XmlException -> ShowS
$cshowsPrec :: Int -> XmlException -> ShowS
Show, Typeable)

instance E.Exception XmlException

-- | An error that occurred during header parsing / validation.
newtype HeaderException = HeaderException { HeaderException -> String
headerErrorMessage :: String }
    deriving (Int -> HeaderException -> ShowS
[HeaderException] -> ShowS
HeaderException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderException] -> ShowS
$cshowList :: [HeaderException] -> ShowS
show :: HeaderException -> String
$cshow :: HeaderException -> String
showsPrec :: Int -> HeaderException -> ShowS
$cshowsPrec :: Int -> HeaderException -> ShowS
Show, Typeable)

instance E.Exception HeaderException

-- | An error that occurred during form parsing / validation.
newtype FormException = FormException { FormException -> String
formErrorMesage :: String }
    deriving (Int -> FormException -> ShowS
[FormException] -> ShowS
FormException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FormException] -> ShowS
$cshowList :: [FormException] -> ShowS
show :: FormException -> String
$cshow :: FormException -> String
showsPrec :: Int -> FormException -> ShowS
$cshowsPrec :: Int -> FormException -> ShowS
Show, Typeable)

instance E.Exception FormException

-- | No credentials were found and an invariant was violated.
newtype NoCredentialsException = NoCredentialsException { NoCredentialsException -> String
noCredentialsErrorMessage :: String }
    deriving (Int -> NoCredentialsException -> ShowS
[NoCredentialsException] -> ShowS
NoCredentialsException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoCredentialsException] -> ShowS
$cshowList :: [NoCredentialsException] -> ShowS
show :: NoCredentialsException -> String
$cshow :: NoCredentialsException -> String
showsPrec :: Int -> NoCredentialsException -> ShowS
$cshowsPrec :: Int -> NoCredentialsException -> ShowS
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 :: forall (m :: * -> *) a.
MonadThrow m =>
Request -> Response (ConduitM () ByteString m ()) -> m a
throwStatusCodeException Request
req Response (ConduitM () ByteString m ())
resp = do
    let resp' :: Response ()
resp' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ()) Response (ConduitM () ByteString m ())
resp
    -- only take first 10kB of error response
    ByteString
body <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString m ())
resp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ByteString
CB.take (Int
10forall a. Num a => a -> a -> a
*Int
1024)
    let sce :: HttpExceptionContent
sce = Response () -> ByteString -> HttpExceptionContent
HTTP.StatusCodeException Response ()
resp' (ByteString -> ByteString
L.toStrict ByteString
body)
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HTTP.HttpExceptionRequest Request
req HttpExceptionContent
sce

-- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents.
elContent :: T.Text -> Cursor -> [T.Text]
elContent :: Text -> Cursor -> [Text]
elContent Text
name = Text -> Axis
laxElement Text
name forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content

-- | Like 'elContent', but extracts 'String's instead of 'T.Text'.
elCont :: T.Text -> Cursor -> [String]
elCont :: Text -> Cursor -> [String]
elCont Text
name = Text -> Axis
laxElement Text
name forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Text -> String
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 :: forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force = forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
Cu.force forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> XmlException
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 :: forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM = forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [f a] -> f a
Cu.forceM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> XmlException
XmlException

-- | Read a boolean from a 'T.Text', throwing an 'XmlException' on failure.
textReadBool :: MonadThrow m => T.Text -> m Bool
textReadBool :: forall (m :: * -> *). MonadThrow m => Text -> m Bool
textReadBool Text
s = case Text -> String
T.unpack Text
s of
                  String
"true"  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  String
"false" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  String
_        -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid Bool"

-- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure.
textReadInt :: (MonadThrow m, Num a) => T.Text -> m a
textReadInt :: forall (m :: * -> *) a. (MonadThrow m, Num a) => Text -> m a
textReadInt Text
s = case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s of
                  [(Integer
n,String
"")] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
n
                  [(Integer, String)]
_        -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid Integer"

-- | Read an integer from a 'String', throwing an 'XmlException' on failure.
readInt :: (MonadThrow m, Num a) => String -> m a
readInt :: forall (m :: * -> *) a. (MonadThrow m, Num a) => String -> m a
readInt String
s = case forall a. Read a => ReadS a
reads String
s of
              [(Integer
n,String
"")] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
n
              [(Integer, String)]
_        -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"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 :: forall m a.
Monoid m =>
(Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a
xmlCursorConsumer Cursor -> Response m a
parse IORef m
metadataRef Response (ConduitM () ByteString (ResourceT IO) ())
res
    = do Document
doc <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString (ResourceT IO) ())
res forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT ByteString o m Document
XML.sinkDoc forall a. Default a => a
XML.def
         let cursor :: Cursor
cursor = Document -> Cursor
Cu.fromDocument Document
doc
         let Response m
metadata Either SomeException a
x = Cursor -> Response m a
parse Cursor
cursor
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall m. Monoid m => IORef m -> m -> IO ()
tellMetadataRef IORef m
metadataRef m
metadata
         case Either SomeException a
x of
           Left SomeException
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
err
           Right a
v  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v