{-# 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 { 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
[Response m a] -> ShowS
Response m a -> String
(Int -> Response m a -> ShowS)
-> (Response m a -> String)
-> ([Response m a] -> ShowS)
-> Show (Response m a)
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
$cshowsPrec :: forall m a. (Show m, Show a) => Int -> Response m a -> ShowS
showsPrec :: Int -> Response m a -> ShowS
$cshow :: forall m a. (Show m, Show a) => Response m a -> String
show :: Response m a -> String
$cshowList :: forall m a. (Show m, Show a) => [Response m a] -> ShowS
showList :: [Response m a] -> ShowS
Show, (forall a b. (a -> b) -> Response m a -> Response m b)
-> (forall a b. a -> Response m b -> Response m a)
-> Functor (Response m)
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
$cfmap :: forall m a b. (a -> b) -> Response m a -> Response m b
fmap :: forall a b. (a -> b) -> Response m a -> Response m b
$c<$ :: forall m a b. a -> Response m b -> Response m a
<$ :: forall a b. a -> Response m b -> Response m a
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 = (SomeException -> n a)
-> (a -> n a) -> Either SomeException a -> n a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> n a
forall e a. (HasCallStack, Exception e) => e -> n a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM a -> n a
forall a. a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> n a)
-> (Response m a -> Either SomeException a) -> Response m a -> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response m a -> Either SomeException a
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 = IO a -> io a
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> io a) -> (Response m a -> IO a) -> Response m a -> io a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response m a -> IO a
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 = m -> Either SomeException () -> Response m ()
forall m a. m -> Either SomeException a -> Response m a
Response m
m (() -> Either SomeException ()
forall a. a -> Either SomeException a
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) = n -> Either SomeException a -> Response n 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 = m -> Either SomeException a -> Response m a
forall m a. m -> Either SomeException a -> Response m a
Response m
forall a. Monoid a => a
mempty (a -> Either SomeException a
forall a b. b -> Either a b
Right a
x)
    <*> :: forall a b. Response m (a -> b) -> Response m a -> Response m 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 = m -> Either SomeException a -> Response m a
forall m a. m -> Either SomeException a -> Response m a
Response m
forall a. Monoid a => a
mempty (a -> Either SomeException a
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
_ = m -> Either SomeException b -> Response m b
forall m a. m -> Either SomeException a -> Response m a
Response m
m1 (SomeException -> Either SomeException b
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 m -> Either SomeException b -> Response m b
forall m a. m -> Either SomeException a -> Response m a
Response (m
m1 m -> m -> m
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. (HasCallStack, Exception e) => e -> Response m a
throwM e
e = m -> Either SomeException a -> Response m a
forall m a. m -> Either SomeException a -> Response m a
Response m
forall a. Monoid a => a
mempty (e -> Either SomeException a
forall e a.
(HasCallStack, Exception e) =>
e -> Either SomeException a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 = IORef m -> (m -> m) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef m
r (m -> m -> m
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 <- ConduitT () Void (ResourceT IO) [ByteString]
-> ResourceT IO [ByteString]
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit (ConduitT () Void (ResourceT IO) [ByteString]
 -> ResourceT IO [ByteString])
-> ConduitT () Void (ResourceT IO) [ByteString]
-> ResourceT IO [ByteString]
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString (ResourceT IO) ())
-> ConduitM () ByteString (ResourceT IO) ()
forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString (ResourceT IO) ())
resp ConduitM () ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) [ByteString]
-> ConduitT () Void (ResourceT IO) [ByteString]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void (ResourceT IO) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
        Response ByteString -> ResourceT IO (Response ByteString)
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response (ConduitM () ByteString (ResourceT IO) ())
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.
        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=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show (Credentials -> ByteString
accessKeyID Credentials
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",secretAccessKey=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show (Credentials -> ByteString
secretAccessKey Credentials
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",iamToken=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> String
forall a. Show a => a -> String
show (Credentials -> Maybe ByteString
iamToken Credentials
c) String -> ShowS
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 = IO Credentials -> io Credentials
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Credentials -> io Credentials)
-> IO Credentials -> io Credentials
forall a b. (a -> b) -> a -> b
$ do
    IORef [V4Key]
v4SigningKeys <- [V4Key] -> IO (IORef [V4Key])
forall a. a -> IO (IORef a)
newIORef []
    let iamToken :: Maybe a
iamToken = Maybe a
forall a. Maybe a
Nothing
    let isAnonymousCredentials :: Bool
isAnonymousCredentials = Bool
False
    Credentials -> IO Credentials
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials { Bool
Maybe ByteString
ByteString
IORef [V4Key]
forall a. Maybe a
accessKeyID :: ByteString
secretAccessKey :: ByteString
v4SigningKeys :: IORef [V4Key]
iamToken :: Maybe ByteString
isAnonymousCredentials :: Bool
accessKeyID :: ByteString
secretAccessKey :: ByteString
v4SigningKeys :: IORef [V4Key]
iamToken :: forall a. Maybe a
isAnonymousCredentials :: Bool
.. }

-- | 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 = IO (Maybe String) -> io (Maybe String)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> io (Maybe String))
-> IO (Maybe String) -> io (Maybe String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Maybe String)
forall a. IO a -> IO (Maybe a)
tryMaybe ((String -> ShowS
</> String
".aws-keys") ShowS -> IO String -> IO String
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 = IO (Maybe a) -> (SomeException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) SomeException -> IO (Maybe a)
forall a. SomeException -> IO (Maybe a)
f
  where
    f :: E.SomeException -> IO (Maybe a)
    f :: forall a. SomeException -> IO (Maybe a)
f SomeException
_ = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 = IO (Maybe Credentials) -> io (Maybe Credentials)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Credentials) -> io (Maybe Credentials))
-> IO (Maybe Credentials) -> io (Maybe Credentials)
forall a b. (a -> b) -> a -> b
$ do
  Bool
exists <- String -> IO Bool
doesFileExist String
file
  if Bool
exists
    then do
      [[Text]]
contents <- (Text -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Text]
T.words ([Text] -> [[Text]]) -> (Text -> [Text]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [[Text]]) -> IO Text -> IO [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
T.readFile String
file
      Maybe (IO Credentials) -> IO (Maybe Credentials)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Maybe (m a) -> m (Maybe a)
Traversable.sequence (Maybe (IO Credentials) -> IO (Maybe Credentials))
-> Maybe (IO Credentials) -> IO (Maybe Credentials)
forall a b. (a -> b) -> a -> b
$ do
        [Text
_key, Text
keyID, Text
secret] <- ([Text] -> Bool) -> [[Text]] -> Maybe [Text]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> [Text] -> Bool
forall {a}. Eq a => a -> [a] -> Bool
hasKey Text
key) [[Text]]
contents
        IO Credentials -> Maybe (IO Credentials)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString -> IO Credentials
forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials (Text -> ByteString
T.encodeUtf8 Text
keyID) (Text -> ByteString
T.encodeUtf8 Text
secret))
    else Maybe Credentials -> IO (Maybe Credentials)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Credentials
forall a. Maybe a
Nothing
  where
    hasKey :: a -> [a] -> Bool
hasKey a
_ [] = Bool
False
    hasKey a
k (a
k2 : [a]
_) = a
k a -> a -> Bool
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 = IO (Maybe Credentials) -> io (Maybe Credentials)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Credentials) -> io (Maybe Credentials))
-> IO (Maybe Credentials) -> io (Maybe Credentials)
forall a b. (a -> b) -> a -> b
$ do
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  let lk :: String -> Maybe ByteString
lk = (String -> ByteString) -> Maybe String -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Maybe String -> Maybe ByteString)
-> (String -> Maybe String) -> String -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [(String, String)] -> Maybe String)
-> [(String, String)] -> String -> Maybe String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [(String, String)] -> Maybe String
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" Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
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 = lk "AWS_SESSION_TOKEN" }
      makeCredentials' :: ByteString -> ByteString -> IO Credentials
makeCredentials' ByteString
k ByteString
s = Credentials -> Credentials
setSession (Credentials -> Credentials) -> IO Credentials -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ByteString -> IO Credentials
forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials ByteString
k ByteString
s
  Maybe (IO Credentials) -> IO (Maybe Credentials)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Maybe (m a) -> m (Maybe a)
Traversable.sequence (Maybe (IO Credentials) -> IO (Maybe Credentials))
-> Maybe (IO Credentials) -> IO (Maybe Credentials)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> IO Credentials
makeCredentials' (ByteString -> ByteString -> IO Credentials)
-> Maybe ByteString -> Maybe (ByteString -> IO Credentials)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
keyID Maybe (ByteString -> IO Credentials)
-> Maybe ByteString -> Maybe (IO Credentials)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
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 <- IO Manager -> io Manager
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
HTTP.getGlobalManager
    -- check if the path is routable
    Bool
avail <- IO Bool -> io Bool
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> io Bool) -> IO Bool -> io Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
hostAvailable String
"169.254.169.254"
    if Bool -> Bool
not Bool
avail
      then Maybe Credentials -> io (Maybe Credentials)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Credentials
forall a. Maybe a
Nothing
      else do
        Maybe ByteString
info <- IO (Maybe ByteString) -> io (Maybe ByteString)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> io (Maybe ByteString))
-> IO (Maybe ByteString) -> io (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ IO (Maybe ByteString)
-> (HttpException -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
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" IO ByteString
-> (ByteString -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) (\(HttpException
_ :: HTTP.HttpException) -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)
        let infodict :: Maybe (Map String String)
infodict = Maybe ByteString
info Maybe ByteString
-> (ByteString -> Maybe (Map String String))
-> Maybe (Map String String)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Map String String)
forall a. FromJSON a => ByteString -> Maybe a
A.decode :: Maybe (M.Map String String)
            info' :: Maybe String
info'    = Maybe (Map String String)
infodict Maybe (Map String String)
-> (Map String String -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Map String String -> Maybe String
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' = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
name
              Maybe ByteString
creds <- IO (Maybe ByteString) -> io (Maybe ByteString)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> io (Maybe ByteString))
-> IO (Maybe ByteString) -> io (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ IO (Maybe ByteString)
-> (HttpException -> IO (Maybe ByteString))
-> IO (Maybe ByteString)
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' IO ByteString
-> (ByteString -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> (ByteString -> Maybe ByteString)
-> ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) (\(HttpException
_ :: HTTP.HttpException) -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)
              -- this token lasts ~6 hours
              let dict :: Maybe (Map String String)
dict   = Maybe ByteString
creds Maybe ByteString
-> (ByteString -> Maybe (Map String String))
-> Maybe (Map String String)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Map String String)
forall a. FromJSON a => ByteString -> Maybe a
A.decode :: Maybe (M.Map String String)
                  keyID :: Maybe String
keyID  = Maybe (Map String String)
dict  Maybe (Map String String)
-> (Map String String -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"AccessKeyId"
                  secret :: Maybe String
secret = Maybe (Map String String)
dict  Maybe (Map String String)
-> (Map String String -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"SecretAccessKey"
                  token :: Maybe String
token  = Maybe (Map String String)
dict  Maybe (Map String String)
-> (Map String String -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
"Token"
              IORef [V4Key]
ref <- IO (IORef [V4Key]) -> io (IORef [V4Key])
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [V4Key]) -> io (IORef [V4Key]))
-> IO (IORef [V4Key]) -> io (IORef [V4Key])
forall a b. (a -> b) -> a -> b
$ [V4Key] -> IO (IORef [V4Key])
forall a. a -> IO (IORef a)
newIORef []
              Maybe Credentials -> io (Maybe Credentials)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
-> ByteString
-> IORef [V4Key]
-> Maybe ByteString
-> Bool
-> Credentials
Credentials (ByteString
 -> ByteString
 -> IORef [V4Key]
 -> Maybe ByteString
 -> Bool
 -> Credentials)
-> Maybe ByteString
-> Maybe
     (ByteString
      -> IORef [V4Key] -> Maybe ByteString -> Bool -> Credentials)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ByteString) -> Maybe String -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
keyID)
                                  Maybe
  (ByteString
   -> IORef [V4Key] -> Maybe ByteString -> Bool -> Credentials)
-> Maybe ByteString
-> Maybe (IORef [V4Key] -> Maybe ByteString -> Bool -> Credentials)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ByteString) -> Maybe String -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
secret)
                                  Maybe (IORef [V4Key] -> Maybe ByteString -> Bool -> Credentials)
-> Maybe (IORef [V4Key])
-> Maybe (Maybe ByteString -> Bool -> Credentials)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef [V4Key] -> Maybe (IORef [V4Key])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return IORef [V4Key]
ref
                                  Maybe (Maybe ByteString -> Bool -> Credentials)
-> Maybe (Maybe ByteString) -> Maybe (Bool -> Credentials)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (String -> ByteString) -> String -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Maybe ByteString)
-> Maybe String -> Maybe (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
token)
                                  Maybe (Bool -> Credentials) -> Maybe Bool -> Maybe Credentials
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Maybe Bool
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
          Maybe String
Nothing -> Maybe Credentials -> io (Maybe Credentials)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Credentials
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 <- io (Maybe Credentials)
forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv
    case Maybe Credentials
envcr of
      Just Credentials
cr -> Maybe Credentials -> io (Maybe Credentials)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> Maybe Credentials
forall a. a -> Maybe a
Just Credentials
cr)
      Maybe Credentials
Nothing -> String -> Text -> io (Maybe Credentials)
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 <- io (Maybe Credentials)
forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv
    case Maybe Credentials
envcr of
      Just Credentials
cr -> Maybe Credentials -> io (Maybe Credentials)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> Maybe Credentials
forall a. a -> Maybe a
Just Credentials
cr)
      Maybe Credentials
Nothing ->
        do
          Maybe Credentials
filecr <- String -> Text -> io (Maybe Credentials)
forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromFile String
file Text
key
          case Maybe Credentials
filecr of
            Just Credentials
cr -> Maybe Credentials -> io (Maybe Credentials)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> Maybe Credentials
forall a. a -> Maybe a
Just Credentials
cr)
            Maybe Credentials
Nothing -> io (Maybe Credentials)
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 <- io (Maybe String)
forall (io :: * -> *). MonadIO io => io (Maybe String)
credentialsDefaultFile
  case Maybe String
mfile of
      Just String
file -> String -> Text -> io (Maybe Credentials)
forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFileOrInstanceMetadata String
file Text
credentialsDefaultKey
      Maybe String
Nothing   -> io (Maybe Credentials)
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 <- ByteString -> ByteString -> io Credentials
forall (io :: * -> *).
MonadIO io =>
ByteString -> ByteString -> io Credentials
makeCredentials ByteString
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty
  Credentials -> io Credentials
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials
cr { isAnonymousCredentials = True })

-- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols.
data Protocol
    = HTTP
    | HTTPS
    deriving (Protocol -> Protocol -> Bool
(Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Bool) -> Eq Protocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Protocol -> Protocol -> Bool
== :: Protocol -> Protocol -> Bool
$c/= :: Protocol -> Protocol -> Bool
/= :: Protocol -> Protocol -> Bool
Eq,ReadPrec [Protocol]
ReadPrec Protocol
Int -> ReadS Protocol
ReadS [Protocol]
(Int -> ReadS Protocol)
-> ReadS [Protocol]
-> ReadPrec Protocol
-> ReadPrec [Protocol]
-> Read Protocol
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Protocol
readsPrec :: Int -> ReadS Protocol
$creadList :: ReadS [Protocol]
readList :: ReadS [Protocol]
$creadPrec :: ReadPrec Protocol
readPrec :: ReadPrec Protocol
$creadListPrec :: ReadPrec [Protocol]
readListPrec :: ReadPrec [Protocol]
Read,Int -> Protocol -> ShowS
[Protocol] -> ShowS
Protocol -> String
(Int -> Protocol -> ShowS)
-> (Protocol -> String) -> ([Protocol] -> ShowS) -> Show Protocol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Protocol -> ShowS
showsPrec :: Int -> Protocol -> ShowS
$cshow :: Protocol -> String
show :: Protocol -> String
$cshowList :: [Protocol] -> ShowS
showList :: [Protocol] -> ShowS
Show,Eq Protocol
Eq Protocol =>
(Protocol -> Protocol -> Ordering)
-> (Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Protocol)
-> (Protocol -> Protocol -> Protocol)
-> Ord 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
$ccompare :: Protocol -> Protocol -> Ordering
compare :: Protocol -> Protocol -> Ordering
$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
>= :: Protocol -> Protocol -> Bool
$cmax :: Protocol -> Protocol -> Protocol
max :: Protocol -> Protocol -> Protocol
$cmin :: Protocol -> Protocol -> Protocol
min :: Protocol -> Protocol -> Protocol
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
(Int -> Method -> ShowS)
-> (Method -> String) -> ([Method] -> ShowS) -> Show Method
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Method -> ShowS
showsPrec :: Int -> Method -> ShowS
$cshow :: Method -> String
show :: Method -> String
$cshowList :: [Method] -> ShowS
showList :: [Method] -> ShowS
Show, Method -> Method -> Bool
(Method -> Method -> Bool)
-> (Method -> Method -> Bool) -> Eq Method
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
/= :: Method -> Method -> Bool
Eq, Eq Method
Eq Method =>
(Method -> Method -> Ordering)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Method)
-> (Method -> Method -> Method)
-> Ord 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
$ccompare :: Method -> Method -> Ordering
compare :: Method -> Method -> Ordering
$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
>= :: Method -> Method -> Bool
$cmax :: Method -> Method -> Method
max :: Method -> Method -> Method
$cmin :: Method -> Method -> Method
min :: Method -> Method -> Method
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 UTCTime
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
ByteString
Method
Protocol
sqMethod :: SignedQuery -> Method
sqProtocol :: SignedQuery -> Protocol
sqHost :: SignedQuery -> ByteString
sqPort :: SignedQuery -> Int
sqPath :: SignedQuery -> ByteString
sqQuery :: SignedQuery -> Query
sqDate :: SignedQuery -> Maybe UTCTime
sqAuthorization :: SignedQuery -> Maybe (IO ByteString)
sqContentType :: SignedQuery -> Maybe ByteString
sqContentMd5 :: SignedQuery -> Maybe (Digest MD5)
sqAmzHeaders :: SignedQuery -> RequestHeaders
sqOtherHeaders :: SignedQuery -> RequestHeaders
sqBody :: SignedQuery -> Maybe RequestBody
sqStringToSign :: SignedQuery -> ByteString
sqMethod :: Method
sqProtocol :: Protocol
sqHost :: ByteString
sqPort :: Int
sqPath :: ByteString
sqQuery :: Query
sqDate :: Maybe UTCTime
sqAuthorization :: Maybe (IO ByteString)
sqContentType :: Maybe ByteString
sqContentMd5 :: Maybe (Digest MD5)
sqAmzHeaders :: RequestHeaders
sqOtherHeaders :: RequestHeaders
sqBody :: Maybe RequestBody
sqStringToSign :: ByteString
..} =  do
    Maybe ByteString
mauth <- IO (Maybe ByteString)
-> (IO ByteString -> IO (Maybe ByteString))
-> Maybe (IO ByteString)
-> IO (Maybe ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing) (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just(ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) Maybe (IO ByteString)
sqAuthorization
    Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest {
        HTTP.method = httpMethod sqMethod
      , HTTP.secure = case sqProtocol of
                        Protocol
HTTP -> Bool
False
                        Protocol
HTTPS -> Bool
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 (\UTCTime
d -> (HeaderName
"Date", UTCTime -> ByteString
fmtRfc822Time UTCTime
d)) sqDate
                                        , fmap (\ByteString
c -> (HeaderName
"Content-Type", ByteString
c)) contentType
                                        , fmap (\Digest MD5
md5 -> (HeaderName
"Content-MD5", ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert Digest MD5
md5)) sqContentMd5
                                        , fmap (\ByteString
auth -> (HeaderName
"Authorization", ByteString
auth)) mauth]
                              ++ sqAmzHeaders
                              ++ sqOtherHeaders
      , HTTP.requestBody =

        -- An explicityly defined body parameter should overwrite everything else.
        case 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 (ByteString -> RequestBody)
-> (Builder -> ByteString) -> Builder -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
Blaze.toLazyByteString (Builder -> RequestBody) -> Builder -> RequestBody
forall a b. (a -> b) -> a -> b
$
                           Bool -> Query -> Builder
HTTP.renderQueryBuilder Bool
False Query
sqQuery
              Method
_         -> Int64 -> Builder -> RequestBody
HTTP.RequestBodyBuilder Int64
0 Builder
forall a. Monoid a => a
mempty

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

      , HTTP.redirectCount = 10
      }
    where
      checkDate :: (UTCTime -> Header) -> Maybe UTCTime -> Maybe Header
checkDate UTCTime -> Header
f Maybe UTCTime
mb = Maybe Header
-> (ByteString -> Maybe Header) -> Maybe ByteString -> Maybe Header
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UTCTime -> Header
f (UTCTime -> Header) -> Maybe UTCTime -> Maybe Header
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb) (Maybe Header -> ByteString -> Maybe Header
forall a b. a -> b -> a
const Maybe Header
forall a. Maybe a
Nothing) (Maybe ByteString -> Maybe Header)
-> Maybe ByteString -> Maybe Header
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
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 Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
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 -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"application/x-www-form-urlencoded; charset=utf-8"
                         Method
_ -> Maybe ByteString
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 UTCTime
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
ByteString
Method
Protocol
sqMethod :: SignedQuery -> Method
sqProtocol :: SignedQuery -> Protocol
sqHost :: SignedQuery -> ByteString
sqPort :: SignedQuery -> Int
sqPath :: SignedQuery -> ByteString
sqQuery :: SignedQuery -> Query
sqDate :: SignedQuery -> Maybe UTCTime
sqAuthorization :: SignedQuery -> Maybe (IO ByteString)
sqContentType :: SignedQuery -> Maybe ByteString
sqContentMd5 :: SignedQuery -> Maybe (Digest MD5)
sqAmzHeaders :: SignedQuery -> RequestHeaders
sqOtherHeaders :: SignedQuery -> RequestHeaders
sqBody :: SignedQuery -> Maybe RequestBody
sqStringToSign :: SignedQuery -> ByteString
sqMethod :: Method
sqProtocol :: Protocol
sqHost :: ByteString
sqPort :: Int
sqPath :: ByteString
sqQuery :: Query
sqDate :: Maybe UTCTime
sqAuthorization :: Maybe (IO ByteString)
sqContentType :: Maybe ByteString
sqContentMd5 :: Maybe (Digest MD5)
sqAmzHeaders :: RequestHeaders
sqOtherHeaders :: RequestHeaders
sqBody :: Maybe RequestBody
sqStringToSign :: ByteString
..}
    = [ByteString] -> ByteString
B.concat [
       case Protocol
sqProtocol of
         Protocol
HTTP -> ByteString
"http://"
         Protocol
HTTPS -> ByteString
"https://"
      , ByteString
sqHost
      , if Int
sqPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Protocol -> Int
defaultPort Protocol
sqProtocol then ByteString
"" else Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
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
(Int -> TimeInfo -> ShowS)
-> (TimeInfo -> String) -> ([TimeInfo] -> ShowS) -> Show TimeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeInfo -> ShowS
showsPrec :: Int -> TimeInfo -> ShowS
$cshow :: TimeInfo -> String
show :: TimeInfo -> String
$cshowList :: [TimeInfo] -> ShowS
showList :: [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
(Int -> AbsoluteTimeInfo -> ShowS)
-> (AbsoluteTimeInfo -> String)
-> ([AbsoluteTimeInfo] -> ShowS)
-> Show AbsoluteTimeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AbsoluteTimeInfo -> ShowS
showsPrec :: Int -> AbsoluteTimeInfo -> ShowS
$cshow :: AbsoluteTimeInfo -> String
show :: AbsoluteTimeInfo -> String
$cshowList :: [AbsoluteTimeInfo] -> ShowS
showList :: [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 (UTCTime -> AbsoluteTimeInfo) -> UTCTime -> AbsoluteTimeInfo
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
  SignatureData -> IO SignatureData
forall a. a -> IO a
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 :: 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 (Int -> AuthorizationHash -> ShowS
[AuthorizationHash] -> ShowS
AuthorizationHash -> String
(Int -> AuthorizationHash -> ShowS)
-> (AuthorizationHash -> String)
-> ([AuthorizationHash] -> ShowS)
-> Show AuthorizationHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthorizationHash -> ShowS
showsPrec :: Int -> AuthorizationHash -> ShowS
$cshow :: AuthorizationHash -> String
show :: AuthorizationHash -> String
$cshowList :: [AuthorizationHash] -> ShowS
showList :: [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 -> HMAC SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> ByteString -> HMAC SHA1
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 -> HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> ByteString -> HMAC SHA256
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" (UTCTime -> ByteString) -> UTCTime -> ByteString
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 (Credentials -> IORef [V4Key]) -> Credentials -> IORef [V4Key]
forall a b. (a -> b) -> a -> b
$ SignatureData -> Credentials
signatureCredentials SignatureData
sd
        date :: ByteString
date = String -> UTCTime -> ByteString
fmtTime String
"%Y%m%d" (UTCTime -> ByteString) -> UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd

    -- Lookup existing signing key
    [V4Key]
allkeys <- IORef [V4Key] -> IO [V4Key]
forall a. IORef a -> IO a
readIORef IORef [V4Key]
ref
    let mkey :: Maybe ByteString
mkey = case (ByteString, ByteString)
-> [V4Key] -> Maybe (ByteString, ByteString)
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
date -> Maybe ByteString
forall a. Maybe a
Nothing
                       | Bool
otherwise -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
k
            Maybe (ByteString, ByteString)
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing

    -- possibly create a new signing key
    let createNewKey :: IO ByteString
createNewKey = IORef [V4Key]
-> ([V4Key] -> ([V4Key], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [V4Key]
ref (([V4Key] -> ([V4Key], ByteString)) -> IO ByteString)
-> ([V4Key] -> ([V4Key], ByteString)) -> IO ByteString
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)) V4Key -> [V4Key] -> [V4Key]
forall a. a -> [a] -> [a]
: (V4Key -> Bool) -> [V4Key] -> [V4Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (((ByteString, ByteString)
lstK(ByteString, ByteString) -> (ByteString, ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
/=)((ByteString, ByteString) -> Bool)
-> (V4Key -> (ByteString, ByteString)) -> V4Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.V4Key -> (ByteString, ByteString)
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
         (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
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
        (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
createNewKey ByteString -> IO ByteString
forall a. a -> IO a
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
        (ByteString -> ByteString) -> ByteString -> ByteString
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 (ByteString -> ByteString) -> ByteString -> ByteString
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" (UTCTime -> ByteString) -> UTCTime -> ByteString
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 -> HMAC SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> ByteString -> HMAC SHA1
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 -> HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> ByteString -> HMAC SHA256
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 -> Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> Digest SHA1
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash ByteString
i :: CH.Digest CH.SHA1)
            AuthorizationHash
HmacSHA256 -> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> Digest SHA256
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 (ByteString -> ByteString) -> ByteString -> ByteString
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" (UTCTime -> ByteString) -> UTCTime -> ByteString
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 -> HMAC SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> ByteString -> HMAC SHA1
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 -> HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> ByteString -> HMAC SHA256
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" (UTCTime -> ByteString) -> UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
        secretKey :: ByteString
secretKey = Credentials -> ByteString
secretAccessKey (Credentials -> ByteString) -> Credentials -> ByteString
forall a b. (a -> b) -> a -> b
$ SignatureData -> Credentials
signatureCredentials SignatureData
sd
        kDate :: ByteString
kDate = ByteString -> ByteString -> ByteString
mkHmac (ByteString
"AWS4" ByteString -> ByteString -> ByteString
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
        (ByteString -> ByteString) -> ByteString -> ByteString
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 = config
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 = [[(ByteString, ByteString)]] -> [(ByteString, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(ByteString, ByteString)]] -> [(ByteString, ByteString)])
-> [[(ByteString, ByteString)]] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (ByteString
 -> [(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [ByteString]
-> [[(ByteString, ByteString)]]
-> [[(ByteString, ByteString)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ByteString
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall {d}. ByteString -> [(ByteString, d)] -> [(ByteString, d)]
combine [ByteString]
prefixList ((a -> [(ByteString, ByteString)])
-> [a] -> [[(ByteString, ByteString)]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [(ByteString, ByteString)]
f [a]
xs)
    where prefixList :: [ByteString]
prefixList = (Int -> ByteString) -> [Int] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
dot ByteString
prefix (ByteString -> ByteString)
-> (Int -> ByteString) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BU.fromString (String -> ByteString) -> (Int -> String) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1 :: Int) ..]
          combine :: ByteString -> [(ByteString, d)] -> [(ByteString, d)]
combine ByteString
pf = ((ByteString, d) -> (ByteString, d))
-> [(ByteString, d)] -> [(ByteString, d)]
forall a b. (a -> b) -> [a] -> [b]
map (((ByteString, d) -> (ByteString, d))
 -> [(ByteString, d)] -> [(ByteString, d)])
-> ((ByteString, d) -> (ByteString, d))
-> [(ByteString, d)]
-> [(ByteString, d)]
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> (ByteString, d) -> (ByteString, d)
forall b c d. (b -> c) -> (b, d) -> (c, d)
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
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
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall a. Maybe a -> Maybe a -> Maybe a
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
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall a. Maybe a -> Maybe a -> Maybe a
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
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall a. Maybe a -> Maybe a -> Maybe a
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
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall a. Maybe a -> Maybe a -> Maybe a
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 = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
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 (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
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
                      Word8 -> Maybe Word8
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Maybe Word8) -> (Int -> Word8) -> Int -> Maybe Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Maybe Word8) -> Int -> Maybe Word8
forall a b. (a -> b) -> a -> b
$ Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2
    where
      readHex1 :: Char -> Maybe Int
readHex1 Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
      readHex1 Char
_                        = Maybe Int
forall a. Maybe a
Nothing
readHex2 String
_ = Maybe Word8
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
(Int -> XmlException -> ShowS)
-> (XmlException -> String)
-> ([XmlException] -> ShowS)
-> Show XmlException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XmlException -> ShowS
showsPrec :: Int -> XmlException -> ShowS
$cshow :: XmlException -> String
show :: XmlException -> String
$cshowList :: [XmlException] -> ShowS
showList :: [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
(Int -> HeaderException -> ShowS)
-> (HeaderException -> String)
-> ([HeaderException] -> ShowS)
-> Show HeaderException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderException -> ShowS
showsPrec :: Int -> HeaderException -> ShowS
$cshow :: HeaderException -> String
show :: HeaderException -> String
$cshowList :: [HeaderException] -> ShowS
showList :: [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
(Int -> FormException -> ShowS)
-> (FormException -> String)
-> ([FormException] -> ShowS)
-> Show FormException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormException -> ShowS
showsPrec :: Int -> FormException -> ShowS
$cshow :: FormException -> String
show :: FormException -> String
$cshowList :: [FormException] -> ShowS
showList :: [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
(Int -> NoCredentialsException -> ShowS)
-> (NoCredentialsException -> String)
-> ([NoCredentialsException] -> ShowS)
-> Show NoCredentialsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoCredentialsException -> ShowS
showsPrec :: Int -> NoCredentialsException -> ShowS
$cshow :: NoCredentialsException -> String
show :: NoCredentialsException -> String
$cshowList :: [NoCredentialsException] -> ShowS
showList :: [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' = (ConduitM () ByteString m () -> ())
-> Response (ConduitM () ByteString m ()) -> Response ()
forall a b. (a -> b) -> Response a -> Response b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ConduitM () ByteString m () -> ()
forall a b. a -> b -> a
const ()) Response (ConduitM () ByteString m ())
resp
    -- only take first 10kB of error response
    ByteString
body <- ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit (ConduitT () Void m ByteString -> m ByteString)
-> ConduitT () Void m ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString m ())
-> ConduitM () ByteString m ()
forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString m ())
resp ConduitM () ByteString m ()
-> ConduitT ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Int -> ConduitT ByteString Void m ByteString
forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ByteString
CB.take (Int
10Int -> Int -> Int
forall 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)
    HttpException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (HttpException -> m a) -> HttpException -> m a
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 Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
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 Axis -> (Cursor -> [String]) -> Cursor -> [String]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content (Cursor -> [Text]) -> (Text -> String) -> Cursor -> [String]
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 = XmlException -> [a] -> m a
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
Cu.force (XmlException -> [a] -> m a)
-> (String -> XmlException) -> String -> [a] -> m a
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 = XmlException -> [m a] -> m a
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [f a] -> f a
Cu.forceM (XmlException -> [m a] -> m a)
-> (String -> XmlException) -> String -> [m a] -> m a
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"  -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  String
"false" -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  String
_        -> XmlException -> m Bool
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m Bool) -> XmlException -> m Bool
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 ReadS Integer
forall a. Read a => ReadS a
reads ReadS Integer -> ReadS Integer
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s of
                  [(Integer
n,String
"")] -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
n
                  [(Integer, String)]
_        -> XmlException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
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 ReadS Integer
forall a. Read a => ReadS a
reads String
s of
              [(Integer
n,String
"")] -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
n
              [(Integer, String)]
_        -> XmlException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
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 <- ConduitT () Void (ResourceT IO) Document -> ResourceT IO Document
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit (ConduitT () Void (ResourceT IO) Document -> ResourceT IO Document)
-> ConduitT () Void (ResourceT IO) Document
-> ResourceT IO Document
forall a b. (a -> b) -> a -> b
$ Response (ConduitM () ByteString (ResourceT IO) ())
-> ConduitM () ByteString (ResourceT IO) ()
forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString (ResourceT IO) ())
res ConduitM () ByteString (ResourceT IO) ()
-> ConduitT ByteString Void (ResourceT IO) Document
-> ConduitT () Void (ResourceT IO) Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ParseSettings -> ConduitT ByteString Void (ResourceT IO) Document
forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT ByteString o m Document
XML.sinkDoc ParseSettings
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
         IO () -> ResourceT IO ()
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ IORef m -> m -> IO ()
forall m. Monoid m => IORef m -> m -> IO ()
tellMetadataRef IORef m
metadataRef m
metadata
         case Either SomeException a
x of
           Left SomeException
err -> IO a -> ResourceT IO a
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ResourceT IO a) -> IO a -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ SomeException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
err
           Right a
v  -> a -> ResourceT IO a
forall a. a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v