{-# 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
  -- * Service configuration
, DefaultServiceConfiguration(..)
  -- * HTTP types
, Protocol(..)
, defaultPort
, Method(..)
, httpMethod
)
where

import           Aws.Ec2.InstanceMetadata
import           Aws.Network
import qualified Blaze.ByteString.Builder as Blaze
import           Control.Applicative
import           Control.Arrow
import qualified Control.Exception        as E
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM))
import qualified Crypto.Hash              as CH
import qualified Crypto.MAC.HMAC          as CMH
import qualified Data.Aeson               as A
import qualified Data.ByteArray           as ByteArray
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as B
import qualified Data.ByteString.Base16   as Base16
import qualified Data.ByteString.Base64   as Base64
import           Data.ByteString.Char8    ({- IsString -})
import qualified Data.ByteString.Lazy     as L
import qualified Data.ByteString.UTF8     as BU
import           Data.Char
import           Data.Conduit             ((.|))
import qualified Data.Conduit             as C
#if MIN_VERSION_http_conduit(2,2,0)
import qualified Data.Conduit.Binary      as CB
#endif
import qualified Data.Conduit.List        as CL
import           Data.IORef
import           Data.List
import qualified Data.Map                 as M
import           Data.Maybe
import           Data.Monoid
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
import qualified Data.Text.IO             as T
import           Data.Time
import qualified Data.Traversable         as Traversable
import           Data.Typeable
import           Data.Word
import qualified Network.HTTP.Conduit     as HTTP
import qualified Network.HTTP.Client.TLS  as HTTP
import qualified Network.HTTP.Types       as HTTP
import           System.Directory
import           System.Environment
import           System.FilePath          ((</>))
#if !MIN_VERSION_time(1,5,0)
import           System.Locale
#endif
import qualified Text.XML                 as XML
import qualified Text.XML.Cursor          as Cu
import           Text.XML.Cursor          hiding (force, forceM)
import           Prelude
-------------------------------------------------------------------------------

-- | Types that can be logged (textually).
class Loggable a where
    toLogText :: a -> T.Text

-- | A response with metadata. Can also contain an error response, or
-- an internal error, via 'Attempt'.
--
-- Response forms a Writer-like monad.
data Response m a = Response { Response m a -> m
responseMetadata :: m
                             , 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
showList :: [Response m a] -> ShowS
$cshowList :: forall m a. (Show m, Show a) => [Response m a] -> ShowS
show :: Response m a -> String
$cshow :: forall m a. (Show m, Show a) => Response m a -> String
showsPrec :: Int -> Response m a -> ShowS
$cshowsPrec :: forall m a. (Show m, Show a) => Int -> Response m a -> ShowS
Show, a -> Response m b -> Response m a
(a -> b) -> Response m a -> Response m b
(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
<$ :: a -> Response m b -> Response m a
$c<$ :: forall m a b. a -> Response m b -> Response m a
fmap :: (a -> b) -> Response m a -> Response m b
$cfmap :: forall m a b. (a -> b) -> Response m a -> Response m b
Functor)

-- | Read a response result (if it's a success response, fail otherwise).
readResponse :: MonadThrow n => Response m a -> n a
readResponse :: 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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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 :: Response m a -> io a
readResponseIO = 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 :: m -> Response m ()
tellMetadata m :: m
m = m -> Either SomeException () -> Response m ()
forall m a. m -> Either SomeException a -> Response m a
Response m
m (() -> Either SomeException ()
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 :: (m -> n) -> Response m a -> Response n a
mapMetadata f :: m -> n
f (Response m :: m
m a :: 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 :: a -> Response m a
pure x :: 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 (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 :: a -> Response m a
return x :: 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 m1 :: m
m1 (Left e :: SomeException
e) >>= :: Response m a -> (a -> Response m b) -> 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 m1 :: m
m1 (Right x :: a
x) >>= f :: a -> Response m b
f = let Response m2 :: m
m2 y :: 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 :: e -> Response m a
throwM e :: 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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e)

-- | Add metadata to an 'IORef' (using 'mappend').
tellMetadataRef :: Monoid m => IORef m -> m -> IO ()
tellMetadataRef :: IORef m -> m -> IO ()
tellMetadataRef r :: IORef m
r m :: 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 _ _ _ resp :: 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) ()
-> ConduitM ByteString Void (ResourceT IO) [ByteString]
-> ConduitT () Void (ResourceT IO) [ByteString]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM 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 (m :: * -> *) a. Monad m => a -> m a
return Response (ConduitM () ByteString (ResourceT IO) ())
resp
            { responseBody :: ByteString
HTTP.responseBody = [ByteString] -> ByteString
L.fromChunks [ByteString]
bss
            }

-- | Class for responses that are fully loaded into memory
class AsMemoryResponse resp where
    type MemoryResponse resp :: *
    loadToMemory :: resp -> ResourceT IO (MemoryResponse resp)

-- | Responses that have one main list in them, and perhaps some decoration.
class ListResponse resp item | resp -> item where
    listResponse :: resp -> [item]


-- | Associates a request type and a response type in a bi-directional way.
--
-- This allows the type-checker to infer the response type when given
-- the request type and vice versa.
--
-- Note that the actual request generation and response parsing
-- resides in 'SignQuery' and 'ResponseConsumer' respectively.
class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a))
      => Transaction r a
      | r -> a

-- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits.
class Transaction r a => IteratedTransaction r a | r -> a where
    nextIteratedRequest :: r -> a -> Maybe r

-- | Signature version 4: ((region, service),(date,key))
type V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString))

-- | AWS access credentials.
data Credentials
    = Credentials {
        -- | AWS Access Key ID.
        Credentials -> ByteString
accessKeyID :: B.ByteString
        -- | AWS Secret Access Key.
      , Credentials -> ByteString
secretAccessKey :: B.ByteString
        -- | Signing keys for signature version 4
      , Credentials -> IORef [V4Key]
v4SigningKeys :: IORef [V4Key]
        -- | Signed IAM token
      , Credentials -> Maybe ByteString
iamToken :: Maybe B.ByteString
      }
instance Show Credentials where
    show :: Credentials -> String
show c :: Credentials
c = "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]
++ ",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]
++ ",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]
++ "}"

makeCredentials :: MonadIO io
                => B.ByteString -- ^ AWS Access Key ID
                -> B.ByteString -- ^ AWS Secret Access Key
                -> io Credentials
makeCredentials :: ByteString -> ByteString -> io Credentials
makeCredentials accessKeyID :: ByteString
accessKeyID secretAccessKey :: ByteString
secretAccessKey = IO Credentials -> io Credentials
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
    Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials :: ByteString
-> ByteString -> IORef [V4Key] -> Maybe ByteString -> Credentials
Credentials { .. }

-- | The file where access credentials are loaded, when using 'loadCredentialsDefault'.
-- May return 'Nothing' if @HOME@ is unset.
--
-- Value: /<user directory>/@/.aws-keys@
credentialsDefaultFile :: MonadIO io => io (Maybe FilePath)
credentialsDefaultFile :: io (Maybe String)
credentialsDefaultFile = IO (Maybe String) -> io (Maybe String)
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
</> ".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 :: IO a -> IO (Maybe a)
tryMaybe action :: 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 :: SomeException -> IO (Maybe a)
f _ = Maybe a -> IO (Maybe 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 = "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 :: String -> Text -> io (Maybe Credentials)
loadCredentialsFromFile file :: String
file key :: Text
key = IO (Maybe Credentials) -> io (Maybe Credentials)
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)
Traversable.sequence (Maybe (IO Credentials) -> IO (Maybe Credentials))
-> Maybe (IO Credentials) -> IO (Maybe Credentials)
forall a b. (a -> b) -> a -> b
$ do
        [_key :: Text
_key, keyID :: Text
keyID, secret :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Credentials
forall a. Maybe a
Nothing
  where
    hasKey :: a -> [a] -> Bool
hasKey _ [] = Bool
False
    hasKey k :: a
k (k2 :: a
k2 : _) = 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 :: io (Maybe Credentials)
loadCredentialsFromEnv = IO (Maybe Credentials) -> io (Maybe Credentials)
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 (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 "AWS_ACCESS_KEY_ID"
      secret :: Maybe ByteString
secret = String -> Maybe ByteString
lk "AWS_ACCESS_KEY_SECRET" Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe ByteString
lk "AWS_SECRET_ACCESS_KEY"
      setSession :: Credentials -> Credentials
setSession creds :: Credentials
creds = Credentials
creds { iamToken :: Maybe ByteString
iamToken = String -> Maybe ByteString
lk "AWS_SESSION_TOKEN" }
      makeCredentials' :: ByteString -> ByteString -> IO Credentials
makeCredentials' k :: ByteString
k s :: 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)
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ByteString
secret

loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials)
loadCredentialsFromInstanceMetadata :: io (Maybe Credentials)
loadCredentialsFromInstanceMetadata = do
    Manager
mgr <- IO Manager -> io Manager
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 (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 "169.254.169.254"
    if Bool -> Bool
not Bool
avail
      then Maybe Credentials -> io (Maybe Credentials)
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 (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 "latest/meta-data/iam" "info" IO ByteString
-> (ByteString -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ByteString -> IO (Maybe ByteString)
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 (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 (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 (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 "InstanceProfileArn"
        case Maybe String
info' of
          Just name :: String
name ->
            do
              let name' :: String
name' = Int -> ShowS
forall a. Int -> [a] -> [a]
drop 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
/= '/') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
name
              Maybe ByteString
creds <- IO (Maybe ByteString) -> io (Maybe ByteString)
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 "latest/meta-data/iam/security-credentials" String
name' IO ByteString
-> (ByteString -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ByteString -> IO (Maybe ByteString)
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 (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 (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 (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 "AccessKeyId"
                  secret :: Maybe String
secret = Maybe (Map String String)
dict  Maybe (Map String String)
-> (Map String String -> Maybe String) -> Maybe String
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 "SecretAccessKey"
                  token :: Maybe String
token  = Maybe (Map String String)
dict  Maybe (Map String String)
-> (Map String String -> Maybe String) -> Maybe String
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 "Token"
              IORef [V4Key]
ref <- IO (IORef [V4Key]) -> io (IORef [V4Key])
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 (m :: * -> *) a. Monad m => a -> m a
return (ByteString
-> ByteString -> IORef [V4Key] -> Maybe ByteString -> Credentials
Credentials (ByteString
 -> ByteString -> IORef [V4Key] -> Maybe ByteString -> Credentials)
-> Maybe ByteString
-> Maybe
     (ByteString -> IORef [V4Key] -> Maybe ByteString -> 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 -> Credentials)
-> Maybe ByteString
-> Maybe (IORef [V4Key] -> Maybe ByteString -> Credentials)
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 -> Credentials)
-> Maybe (IORef [V4Key]) -> Maybe (Maybe ByteString -> Credentials)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef [V4Key] -> Maybe (IORef [V4Key])
forall (m :: * -> *) a. Monad m => a -> m a
return IORef [V4Key]
ref
                                  Maybe (Maybe ByteString -> Credentials)
-> Maybe (Maybe ByteString) -> Maybe Credentials
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))
          Nothing -> Maybe Credentials -> io (Maybe Credentials)
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 :: String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFile file :: String
file key :: Text
key =
  do
    Maybe Credentials
envcr <- io (Maybe Credentials)
forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv
    case Maybe Credentials
envcr of
      Just cr :: Credentials
cr -> Maybe Credentials -> io (Maybe Credentials)
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> Maybe Credentials
forall a. a -> Maybe a
Just Credentials
cr)
      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 :: String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFileOrInstanceMetadata file :: String
file key :: Text
key =
  do
    Maybe Credentials
envcr <- io (Maybe Credentials)
forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv
    case Maybe Credentials
envcr of
      Just cr :: Credentials
cr -> Maybe Credentials -> io (Maybe Credentials)
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> Maybe Credentials
forall a. a -> Maybe a
Just Credentials
cr)
      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 cr :: Credentials
cr -> Maybe Credentials -> io (Maybe Credentials)
forall (m :: * -> *) a. Monad m => a -> m a
return (Credentials -> Maybe Credentials
forall a. a -> Maybe a
Just Credentials
cr)
            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 :: 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 file :: String
file -> String -> Text -> io (Maybe Credentials)
forall (io :: * -> *).
MonadIO io =>
String -> Text -> io (Maybe Credentials)
loadCredentialsFromEnvOrFileOrInstanceMetadata String
file Text
credentialsDefaultKey
      Nothing   -> io (Maybe Credentials)
forall (io :: * -> *). MonadIO io => io (Maybe Credentials)
loadCredentialsFromEnv

-- | 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
/= :: Protocol -> Protocol -> Bool
$c/= :: Protocol -> Protocol -> Bool
== :: Protocol -> Protocol -> Bool
$c== :: 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
readListPrec :: ReadPrec [Protocol]
$creadListPrec :: ReadPrec [Protocol]
readPrec :: ReadPrec Protocol
$creadPrec :: ReadPrec Protocol
readList :: ReadS [Protocol]
$creadList :: ReadS [Protocol]
readsPrec :: Int -> ReadS Protocol
$creadsPrec :: Int -> ReadS Protocol
Read,Int -> Protocol -> ShowS
[Protocol] -> ShowS
Protocol -> String
(Int -> Protocol -> ShowS)
-> (Protocol -> String) -> ([Protocol] -> ShowS) -> Show Protocol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Protocol] -> ShowS
$cshowList :: [Protocol] -> ShowS
show :: Protocol -> String
$cshow :: Protocol -> String
showsPrec :: Int -> Protocol -> ShowS
$cshowsPrec :: Int -> Protocol -> ShowS
Show,Eq Protocol
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
min :: Protocol -> Protocol -> Protocol
$cmin :: Protocol -> Protocol -> Protocol
max :: Protocol -> Protocol -> Protocol
$cmax :: Protocol -> Protocol -> Protocol
>= :: Protocol -> Protocol -> Bool
$c>= :: Protocol -> Protocol -> Bool
> :: Protocol -> Protocol -> Bool
$c> :: Protocol -> Protocol -> Bool
<= :: Protocol -> Protocol -> Bool
$c<= :: Protocol -> Protocol -> Bool
< :: Protocol -> Protocol -> Bool
$c< :: Protocol -> Protocol -> Bool
compare :: Protocol -> Protocol -> Ordering
$ccompare :: Protocol -> Protocol -> Ordering
$cp1Ord :: Eq 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 HTTP = 80
defaultPort HTTPS = 443

-- | Request method. Not all request methods are supported by all services.
data Method
    = Head      -- ^ HEAD method. Put all request parameters in a query string and HTTP headers.
    | Get       -- ^ GET method. Put all request parameters in a query string and HTTP headers.
    | PostQuery -- ^ POST method. Put all request parameters in a query string and HTTP headers, but send the query string
                --   as a POST payload
    | Post      -- ^ POST method. Sends a service- and request-specific request body.
    | Put       -- ^ PUT method.
    | Delete    -- ^ DELETE method.
    deriving (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
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show, Method -> Method -> Bool
(Method -> Method -> Bool)
-> (Method -> Method -> Bool) -> Eq Method
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq, Eq Method
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
min :: Method -> Method -> Method
$cmin :: Method -> Method -> Method
max :: Method -> Method -> Method
$cmax :: Method -> Method -> Method
>= :: Method -> Method -> Bool
$c>= :: Method -> Method -> Bool
> :: Method -> Method -> Bool
$c> :: Method -> Method -> Bool
<= :: Method -> Method -> Bool
$c<= :: Method -> Method -> Bool
< :: Method -> Method -> Bool
$c< :: Method -> Method -> Bool
compare :: Method -> Method -> Ordering
$ccompare :: Method -> Method -> Ordering
$cp1Ord :: Eq Method
Ord)

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

-- | A pre-signed medium-level request object.
data SignedQuery
    = SignedQuery {
        -- | Request method.
        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{..} =  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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest {
        method :: ByteString
HTTP.method = Method -> ByteString
httpMethod Method
sqMethod
      , secure :: Bool
HTTP.secure = case Protocol
sqProtocol of
                        HTTP -> Bool
False
                        HTTPS -> Bool
True
      , host :: ByteString
HTTP.host = ByteString
sqHost
      , port :: Int
HTTP.port = Int
sqPort
      , path :: ByteString
HTTP.path = ByteString
sqPath
      , queryString :: ByteString
HTTP.queryString =
          if Method
sqMethod Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
PostQuery
            then ""
            else Bool -> Query -> ByteString
HTTP.renderQuery Bool
False Query
sqQuery

      , requestHeaders :: RequestHeaders
HTTP.requestHeaders = [Maybe (HeaderName, ByteString)] -> RequestHeaders
forall a. [Maybe a] -> [a]
catMaybes [ (UTCTime -> (HeaderName, ByteString))
-> Maybe UTCTime -> Maybe (HeaderName, ByteString)
checkDate (\d :: UTCTime
d -> ("Date", UTCTime -> ByteString
fmtRfc822Time UTCTime
d)) Maybe UTCTime
sqDate
                                        , (ByteString -> (HeaderName, ByteString))
-> Maybe ByteString -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\c :: ByteString
c -> ("Content-Type", ByteString
c)) Maybe ByteString
contentType
                                        , (Digest MD5 -> (HeaderName, ByteString))
-> Maybe (Digest MD5) -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\md5 :: Digest MD5
md5 -> ("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)) Maybe (Digest MD5)
sqContentMd5
                                        , (ByteString -> (HeaderName, ByteString))
-> Maybe ByteString -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\auth :: ByteString
auth -> ("Authorization", ByteString
auth)) Maybe ByteString
mauth]
                              RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
sqAmzHeaders
                              RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
sqOtherHeaders
      , requestBody :: RequestBody
HTTP.requestBody =

        -- An explicityly defined body parameter should overwrite everything else.
        case Maybe RequestBody
sqBody of
          Just x :: RequestBody
x -> RequestBody
x
          Nothing ->
            -- a POST query should convert its query string into the body
            case Method
sqMethod of
              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
              _         -> Int64 -> Builder -> RequestBody
HTTP.RequestBodyBuilder 0 Builder
forall a. Monoid a => a
mempty

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

      , redirectCount :: Int
HTTP.redirectCount = 10
      }
    where
      checkDate :: (UTCTime -> (HeaderName, ByteString))
-> Maybe UTCTime -> Maybe (HeaderName, ByteString)
checkDate f :: UTCTime -> (HeaderName, ByteString)
f mb :: Maybe UTCTime
mb = Maybe (HeaderName, ByteString)
-> (ByteString -> Maybe (HeaderName, ByteString))
-> Maybe ByteString
-> Maybe (HeaderName, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UTCTime -> (HeaderName, ByteString)
f (UTCTime -> (HeaderName, ByteString))
-> Maybe UTCTime -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb) (Maybe (HeaderName, ByteString)
-> ByteString -> Maybe (HeaderName, ByteString)
forall a b. a -> b -> a
const Maybe (HeaderName, ByteString)
forall a. Maybe a
Nothing) (Maybe ByteString -> Maybe (HeaderName, ByteString))
-> Maybe ByteString -> Maybe (HeaderName, ByteString)
forall a b. (a -> b) -> a -> b
$ HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ByteString
defContentType
      defContentType :: Maybe ByteString
defContentType = case Method
sqMethod of
                         PostQuery -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just "application/x-www-form-urlencoded; charset=utf-8"
                         _ -> 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{..}
    = [ByteString] -> ByteString
B.concat [
       case Protocol
sqProtocol of
         HTTP -> "http://"
         HTTPS -> "https://"
      , ByteString
sqHost
      , if Int
sqPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Protocol -> Int
defaultPort Protocol
sqProtocol then "" 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 -> 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
showList :: [TimeInfo] -> ShowS
$cshowList :: [TimeInfo] -> ShowS
show :: TimeInfo -> String
$cshow :: TimeInfo -> String
showsPrec :: Int -> TimeInfo -> ShowS
$cshowsPrec :: Int -> TimeInfo -> ShowS
Show)

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

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

-- | Convert 'TimeInfo' to 'AbsoluteTimeInfo' given the current UTC time.
makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo
makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo
makeAbsoluteTimeInfo Timestamp     now :: UTCTime
now = UTCTime -> AbsoluteTimeInfo
AbsoluteTimestamp UTCTime
now
makeAbsoluteTimeInfo (ExpiresAt t :: UTCTime
t) _   = UTCTime -> AbsoluteTimeInfo
AbsoluteExpires UTCTime
t
makeAbsoluteTimeInfo (ExpiresIn s :: NominalDiffTime
s) now :: 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 rti :: TimeInfo
rti cr :: Credentials
cr = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let ti :: AbsoluteTimeInfo
ti = TimeInfo -> UTCTime -> AbsoluteTimeInfo
makeAbsoluteTimeInfo TimeInfo
rti UTCTime
now
  SignatureData -> IO SignatureData
forall (m :: * -> *) a. Monad m => a -> m a
return SignatureData :: AbsoluteTimeInfo -> UTCTime -> Credentials -> SignatureData
SignatureData { signatureTimeInfo :: AbsoluteTimeInfo
signatureTimeInfo = AbsoluteTimeInfo
ti, signatureTime :: UTCTime
signatureTime = UTCTime
now, signatureCredentials :: Credentials
signatureCredentials = Credentials
cr }

-- | Tag type for normal queries.
data NormalQuery
-- | Tag type for URI-only queries.
data UriOnlyQuery

-- | A "signable" request object. Assembles together the Query, and signs it in one go.
class SignQuery request where
    -- | Additional information, like API endpoints and service-specific preferences.
    type ServiceConfiguration request :: * {- Query Type -} -> *

    -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'.
    signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery

-- | Supported crypto hashes for the signature.
data AuthorizationHash
    = HmacSHA1
    | HmacSHA256
    deriving (Int -> AuthorizationHash -> ShowS
[AuthorizationHash] -> ShowS
AuthorizationHash -> String
(Int -> AuthorizationHash -> ShowS)
-> (AuthorizationHash -> String)
-> ([AuthorizationHash] -> ShowS)
-> Show AuthorizationHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthorizationHash] -> ShowS
$cshowList :: [AuthorizationHash] -> ShowS
show :: AuthorizationHash -> String
$cshow :: AuthorizationHash -> String
showsPrec :: Int -> AuthorizationHash -> ShowS
$cshowsPrec :: Int -> AuthorizationHash -> ShowS
Show)

-- | Authorization hash identifier as expected by Amazon.
amzHash :: AuthorizationHash -> B.ByteString
amzHash :: AuthorizationHash -> ByteString
amzHash HmacSHA1 = "HmacSHA1"
amzHash HmacSHA256 = "HmacSHA256"

-- | Create a signature. Usually, AWS wants a specifically constructed string to be signed.
--
-- The signature is a HMAC-based hash of the string and the secret access key.
signature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString
signature :: Credentials -> AuthorizationHash -> ByteString -> ByteString
signature cr :: Credentials
cr ah :: AuthorizationHash
ah input :: ByteString
input = ByteString -> ByteString
Base64.encode ByteString
sig
    where
      sig :: ByteString
sig = case AuthorizationHash
ah of
              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)
              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 sd :: SignatureData
sd region :: ByteString
region service :: ByteString
service = [ByteString] -> ByteString
B.concat
    [ Credentials -> ByteString
accessKeyID (SignatureData -> Credentials
signatureCredentials SignatureData
sd)
    , "/"
    , ByteString
date
    , "/"
    , ByteString
region
    , "/"
    , ByteString
service
    , "/aws4_request"
    ]
    where
        date :: ByteString
date = String -> UTCTime -> ByteString
fmtTime "%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 sd :: SignatureData
sd ah :: AuthorizationHash
ah region :: ByteString
region service :: ByteString
service headers :: ByteString
headers canonicalRequest :: 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 "%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 (d :: ByteString
d,k :: 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
            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
$ \keylist :: [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 (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' sd :: SignatureData
sd ah :: AuthorizationHash
ah region :: ByteString
region service :: ByteString
service headers :: ByteString
headers canonicalRequest :: 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 sd :: SignatureData
sd ah :: AuthorizationHash
ah region :: ByteString
region service :: ByteString
service headers :: ByteString
headers sig :: ByteString
sig = [ByteString] -> ByteString
B.concat
    [ ByteString
alg
    , " Credential="
    , SignatureData -> ByteString -> ByteString -> ByteString
credentialV4 SignatureData
sd ByteString
region ByteString
service
    , ",SignedHeaders="
    , ByteString
headers
    , ",Signature="
    , ByteString
sig
    ]
    where
        alg :: ByteString
alg = case AuthorizationHash
ah of
            HmacSHA1 -> "AWS4-HMAC-SHA1"
            HmacSHA256 -> "AWS4-HMAC-SHA256"

-- | Compute the signature for V4
signatureV4WithKey
    :: SignatureData
    -> AuthorizationHash
    -> B.ByteString -- ^ region, e.g. us-east-1
    -> B.ByteString -- ^ service, e.g. dynamodb
    -> B.ByteString -- ^ canonicalRequest (before hashing)
    -> B.ByteString -- ^ signing key
    -> B.ByteString
signatureV4WithKey :: SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4WithKey sd :: SignatureData
sd ah :: AuthorizationHash
ah region :: ByteString
region service :: ByteString
service canonicalRequest :: ByteString
canonicalRequest key :: 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 "%Y%m%d" (UTCTime -> ByteString) -> UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
        mkHmac :: ByteString -> ByteString -> ByteString
mkHmac k :: ByteString
k i :: ByteString
i = case AuthorizationHash
ah of
            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)
            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 i :: ByteString
i = case AuthorizationHash
ah of
            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)
            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
            HmacSHA1 -> "AWS4-HMAC-SHA1"
            HmacSHA256 -> "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
            , "\n"
            , String -> UTCTime -> ByteString
fmtTime "%Y%m%dT%H%M%SZ" (UTCTime -> ByteString) -> UTCTime -> ByteString
forall a b. (a -> b) -> a -> b
$ SignatureData -> UTCTime
signatureTime SignatureData
sd
            , "\n"
            , ByteString
date
            , "/"
            , ByteString
region
            , "/"
            , ByteString
service
            , "/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 sd :: SignatureData
sd ah :: AuthorizationHash
ah region :: ByteString
region service :: ByteString
service = ByteString
kSigning
    where
        mkHmac :: ByteString -> ByteString -> ByteString
mkHmac k :: ByteString
k i :: ByteString
i = case AuthorizationHash
ah of
            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)
            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 "%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 ("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 "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 sd :: SignatureData
sd ah :: AuthorizationHash
ah region :: ByteString
region service :: ByteString
service canonicalRequest :: 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 :: (a -> [(ByteString, ByteString)])
-> ByteString -> [a] -> [(ByteString, ByteString)]
queryList f :: a -> [(ByteString, ByteString)]
f prefix :: ByteString
prefix xs :: [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) [(1 :: Int) ..]
          combine :: ByteString -> [(ByteString, d)] -> [(ByteString, d)]
combine pf :: 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 (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 x :: ByteString
x y :: ByteString
y = [ByteString] -> ByteString
B.concat [ByteString
x, String -> ByteString
BU.fromString ".", ByteString
y]

-- | A \"true\"/\"false\" boolean as requested by some services.
awsBool :: Bool -> B.ByteString
awsBool :: Bool -> ByteString
awsBool True = "true"
awsBool False = "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 s :: String
s t :: 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 = "%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 "%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 "%s"

-- | Parse HTTP-date (section 3.3.1 of RFC 2616)
parseHttpDate :: String -> Maybe UTCTime
parseHttpDate :: String -> Maybe UTCTime
parseHttpDate s :: String
s =     String -> String -> Maybe UTCTime
p "%a, %d %b %Y %H:%M:%S GMT" String
s -- rfc1123-date
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p "%A, %d-%b-%y %H:%M:%S GMT" String
s -- rfc850-date
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p "%a %b %_d %H:%M:%S %Y" String
s     -- asctime-date
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p "%Y-%m-%dT%H:%M:%S%QZ" String
s      -- iso 8601
                  Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe UTCTime
p "%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 = "%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 = "%Y-%m-%dT%H:%M:%S%QZ"

-- | Parse a two-digit hex number.
readHex2 :: [Char] -> Maybe Word8
readHex2 :: String -> Maybe Word8
readHex2 [c1 :: Char
c1,c2 :: Char
c2] = do Int
n1 <- Char -> Maybe Int
readHex1 Char
c1
                      Int
n2 <- Char -> Maybe Int
readHex1 Char
c2
                      Word8 -> Maybe Word8
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
* 16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2
    where
      readHex1 :: Char -> Maybe Int
readHex1 c :: Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '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 '0'
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '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 'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 10
                 | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= 'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '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 'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 10
      readHex1 _                        = Maybe Int
forall a. Maybe a
Nothing
readHex2 _ = 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
showList :: [XmlException] -> ShowS
$cshowList :: [XmlException] -> ShowS
show :: XmlException -> String
$cshow :: XmlException -> String
showsPrec :: Int -> XmlException -> ShowS
$cshowsPrec :: Int -> XmlException -> ShowS
Show, Typeable)

instance E.Exception XmlException

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

instance E.Exception HeaderException

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

instance E.Exception FormException

-- | No credentials were found and an invariant was violated.
newtype NoCredentialsException = NoCredentialsException { NoCredentialsException -> String
noCredentialsErrorMessage :: String }
    deriving (Int -> NoCredentialsException -> ShowS
[NoCredentialsException] -> ShowS
NoCredentialsException -> String
(Int -> NoCredentialsException -> ShowS)
-> (NoCredentialsException -> String)
-> ([NoCredentialsException] -> ShowS)
-> Show NoCredentialsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoCredentialsException] -> ShowS
$cshowList :: [NoCredentialsException] -> ShowS
show :: NoCredentialsException -> String
$cshow :: NoCredentialsException -> String
showsPrec :: Int -> NoCredentialsException -> ShowS
$cshowsPrec :: Int -> NoCredentialsException -> ShowS
Show, Typeable)

instance E.Exception NoCredentialsException

-- | A helper to throw an 'HTTP.StatusCodeException'.
throwStatusCodeException :: MonadThrow m => HTTP.Request -> HTTP.Response (C.ConduitM () ByteString m ()) -> m a
throwStatusCodeException :: Request -> Response (ConduitM () ByteString m ()) -> m a
throwStatusCodeException req :: Request
req resp :: Response (ConduitM () ByteString m ())
resp = do
    let resp' :: Response ()
resp' = (ConduitM () ByteString m () -> ())
-> Response (ConduitM () ByteString m ()) -> Response ()
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 ()
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Int -> ConduitM ByteString Void m ByteString
forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ByteString
CB.take (10Int -> Int -> Int
forall a. Num a => a -> a -> a
*1024)
    let sce :: HttpExceptionContent
sce = Response () -> ByteString -> HttpExceptionContent
HTTP.StatusCodeException Response ()
resp' (ByteString -> ByteString
L.toStrict ByteString
body)
    HttpException -> m a
forall (m :: * -> *) e a. (MonadThrow m, 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 name :: 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 name :: 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 :: 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 :: 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 :: Text -> m Bool
textReadBool s :: Text
s = case Text -> String
T.unpack Text
s of
                  "true"  -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  "false" -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  _        -> XmlException -> m Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m Bool) -> XmlException -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException "Invalid Bool"

-- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure.
textReadInt :: (MonadThrow m, Num a) => T.Text -> m a
textReadInt :: Text -> m a
textReadInt s :: 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
                  [(n :: Integer
n,"")] -> 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
                  _        -> XmlException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException "Invalid Integer"

-- | Read an integer from a 'String', throwing an 'XmlException' on failure.
readInt :: (MonadThrow m, Num a) => String -> m a
readInt :: String -> m a
readInt s :: String
s = case ReadS Integer
forall a. Read a => ReadS a
reads String
s of
              [(n :: Integer
n,"")] -> 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
              _        -> XmlException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException "Invalid Integer"

-- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response
-- body.
--
-- This function is highly recommended for any services that parse relatively short XML responses. (If status and response
-- headers are required, simply take them as function parameters, and pass them through to this function.)
xmlCursorConsumer ::
    (Monoid m)
    => (Cu.Cursor -> Response m a)
    -> IORef m
    -> HTTPResponseConsumer a
xmlCursorConsumer :: (Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a
xmlCursorConsumer parse :: Cursor -> Response m a
parse metadataRef :: IORef m
metadataRef res :: 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) ()
-> ConduitM ByteString Void (ResourceT IO) Document
-> ConduitT () Void (ResourceT IO) Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ParseSettings -> ConduitM 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 metadata :: m
metadata x :: Either SomeException a
x = Cursor -> Response m a
parse Cursor
cursor
         IO () -> ResourceT IO ()
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 err :: SomeException
err -> 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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
err
           Right v :: a
v  -> a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v