{-# LANGUAGE CPP #-} module Aws.Core ( -- * Logging Loggable(..) -- * Response -- ** Metadata in responses , Response(..) , readResponse , readResponseIO , tellMetadata , tellMetadataRef , mapMetadata -- ** Response data consumers , HTTPResponseConsumer , ResponseConsumer(..) -- ** Memory response , AsMemoryResponse(..) -- ** List response , ListResponse(..) -- ** Exception types , XmlException(..) , HeaderException(..) , FormException(..) , NoCredentialsException(..) , throwStatusCodeException -- ** Response deconstruction helpers , readHex2 -- *** XML , elContent , elCont , force , forceM , textReadBool , textReadInt , readInt , xmlCursorConsumer -- * Query , SignedQuery(..) , NormalQuery , UriOnlyQuery , queryToHttpRequest , queryToUri -- ** Expiration , TimeInfo(..) , AbsoluteTimeInfo(..) , fromAbsoluteTimeInfo , makeAbsoluteTimeInfo -- ** Signature , SignatureData(..) , signatureData , SignQuery(..) , AuthorizationHash(..) , amzHash , signature , authorizationV4 -- ** Query construction helpers , queryList , awsBool , awsTrue , awsFalse , fmtTime , fmtRfc822Time , rfc822Time , fmtAmzTime , fmtTimeEpochSeconds , parseHttpDate , httpDate1 , textHttpDate , iso8601UtcDate -- * Transactions , Transaction , IteratedTransaction(..) -- * Credentials , Credentials(..) , makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv , loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault -- * Service configuration , DefaultServiceConfiguration(..) -- * HTTP types , Protocol(..) , defaultPort , Method(..) , httpMethod ) where import Aws.Ec2.InstanceMetadata import Aws.Network import qualified Blaze.ByteString.Builder as Blaze import Control.Applicative import Control.Arrow import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM)) import Crypto.Hash import qualified Data.Aeson as A import Data.Byteable import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as BU import Data.Char import Data.Conduit (($$+-)) import qualified Data.Conduit as C #if MIN_VERSION_http_conduit(2,2,0) import qualified Data.Conduit.Binary as CB #endif import qualified Data.Conduit.List as CL import Data.IORef import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time import qualified Data.Traversable as Traversable import Data.Typeable import Data.Word import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import System.Directory import System.Environment import System.FilePath (()) #if !MIN_VERSION_time(1,5,0) import System.Locale #endif import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu import Text.XML.Cursor hiding (force, forceM) import Prelude ------------------------------------------------------------------------------- -- | Types that can be logged (textually). class Loggable a where toLogText :: a -> T.Text -- | A response with metadata. Can also contain an error response, or -- an internal error, via 'Attempt'. -- -- Response forms a Writer-like monad. data Response m a = Response { responseMetadata :: m , responseResult :: Either E.SomeException a } deriving (Show, Functor) -- | Read a response result (if it's a success response, fail otherwise). readResponse :: MonadThrow n => Response m a -> n a readResponse = either throwM return . responseResult -- | Read a response result (if it's a success response, fail otherwise). In MonadIO. readResponseIO :: MonadIO io => Response m a -> io a readResponseIO = liftIO . readResponse -- | An empty response with some metadata. tellMetadata :: m -> Response m () tellMetadata m = Response m (return ()) -- | Apply a function to the metadata. mapMetadata :: (m -> n) -> Response m a -> Response n a mapMetadata f (Response m a) = Response (f m) a --multiResponse :: Monoid m => Response m a -> Response [m] a -> instance Monoid m => Applicative (Response m) where pure x = Response mempty (Right x) (<*>) = ap instance Monoid m => Monad (Response m) where return x = Response mempty (Right x) Response m1 (Left e) >>= _ = Response m1 (Left e) Response m1 (Right x) >>= f = let Response m2 y = f x in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too instance Monoid m => MonadThrow (Response m) where throwM e = Response mempty (throwM e) -- | Add metadata to an 'IORef' (using 'mappend'). tellMetadataRef :: Monoid m => IORef m -> m -> IO () tellMetadataRef r m = modifyIORef r (`mappend` m) -- | A full HTTP response parser. Takes HTTP status, response headers, and response body. type HTTPResponseConsumer a = HTTP.Response (C.ResumableSource (ResourceT IO) ByteString) -> ResourceT IO a -- | Class for types that AWS HTTP responses can be parsed into. -- -- The request is also passed for possibly required additional metadata. -- -- Note that for debugging, there is an instance for 'L.ByteString'. class Monoid (ResponseMetadata resp) => ResponseConsumer req resp where -- | Metadata associated with a response. Typically there is one -- metadata type for each AWS service. type ResponseMetadata resp -- | Response parser. Takes the corresponding AWS request, the derived -- @http-client@ request (for error reporting), an 'IORef' for metadata, and -- HTTP response data. responseConsumer :: HTTP.Request -> req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp -- | Does not parse response. For debugging. instance ResponseConsumer r (HTTP.Response L.ByteString) where type ResponseMetadata (HTTP.Response L.ByteString) = () responseConsumer _ _ _ resp = do bss <- HTTP.responseBody resp $$+- CL.consume return resp { HTTP.responseBody = L.fromChunks bss } -- | Class for responses that are fully loaded into memory class AsMemoryResponse resp where type MemoryResponse resp :: * loadToMemory :: resp -> ResourceT IO (MemoryResponse resp) -- | Responses that have one main list in them, and perhaps some decoration. class ListResponse resp item | resp -> item where listResponse :: resp -> [item] -- | Associates a request type and a response type in a bi-directional way. -- -- This allows the type-checker to infer the response type when given -- the request type and vice versa. -- -- Note that the actual request generation and response parsing -- resides in 'SignQuery' and 'ResponseConsumer' respectively. class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a)) => Transaction r a | r -> a -- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits. class Transaction r a => IteratedTransaction r a | r -> a where nextIteratedRequest :: r -> a -> Maybe r -- | Signature version 4: ((region, service),(date,key)) type V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString)) -- | AWS access credentials. data Credentials = Credentials { -- | AWS Access Key ID. accessKeyID :: B.ByteString -- | AWS Secret Access Key. , secretAccessKey :: B.ByteString -- | Signing keys for signature version 4 , v4SigningKeys :: IORef [V4Key] -- | Signed IAM token , iamToken :: Maybe B.ByteString } instance Show Credentials where show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" makeCredentials :: MonadIO io => B.ByteString -- ^ AWS Access Key ID -> B.ByteString -- ^ AWS Secret Access Key -> io Credentials makeCredentials accessKeyID secretAccessKey = liftIO $ do v4SigningKeys <- newIORef [] let iamToken = Nothing return Credentials { .. } -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. -- May return 'Nothing' if @HOME@ is unset. -- -- Value: //@/.aws-keys@ credentialsDefaultFile :: MonadIO io => io (Maybe FilePath) credentialsDefaultFile = liftIO $ tryMaybe (( ".aws-keys") <$> getHomeDirectory) tryMaybe :: IO a -> IO (Maybe a) tryMaybe action = E.catch (Just <$> action) f where f :: E.SomeException -> IO (Maybe a) f _ = return Nothing -- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'. -- -- Value: @default@ credentialsDefaultKey :: T.Text credentialsDefaultKey = "default" -- | Load credentials from a (text) file given a key name. -- -- The file consists of a sequence of lines, each in the following format: -- -- @keyName awsKeyID awsKeySecret@ loadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromFile file key = liftIO $ do exists <- doesFileExist file if exists then do contents <- map T.words . T.lines <$> T.readFile file Traversable.sequence $ do [_key, keyID, secret] <- find (hasKey key) contents return (makeCredentials (T.encodeUtf8 keyID) (T.encodeUtf8 secret)) else return Nothing where hasKey _ [] = False hasKey k (k2 : _) = k == k2 -- | Load credentials from the environment variables @AWS_ACCESS_KEY_ID@ and @AWS_ACCESS_KEY_SECRET@ -- (or @AWS_SECRET_ACCESS_KEY@), if possible. loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment let lk = fmap (T.encodeUtf8 . T.pack) . flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY" setSession creds = creds { iamToken = lk "AWS_SESSION_TOKEN" } makeCredentials' k s = setSession <$> makeCredentials k s Traversable.sequence $ makeCredentials' <$> keyID <*> secret loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) loadCredentialsFromInstanceMetadata = do mgr <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings -- check if the path is routable avail <- liftIO $ hostAvailable "169.254.169.254" if not avail then return Nothing else do info <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam" "info" >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) let infodict = info >>= A.decode :: Maybe (M.Map String String) info' = infodict >>= M.lookup "InstanceProfileArn" case info' of Just name -> do let name' = drop 1 $ dropWhile (/= '/') $ name creds <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam/security-credentials" name' >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) -- this token lasts ~6 hours let dict = creds >>= A.decode :: Maybe (M.Map String String) keyID = dict >>= M.lookup "AccessKeyId" secret = dict >>= M.lookup "SecretAccessKey" token = dict >>= M.lookup "Token" ref <- liftIO $ newIORef [] return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret) <*> return ref <*> (Just . T.encodeUtf8 . T.pack <$> token)) Nothing -> return Nothing -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsFromEnvOrFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromEnvOrFile file key = do envcr <- loadCredentialsFromEnv case envcr of Just cr -> return (Just cr) Nothing -> loadCredentialsFromFile file key -- | Load credentials from environment variables if possible, or alternatively from the instance metadata store, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv', 'loadCredentialsFromFile' and 'loadCredentialsFromInstanceMetadata' for details. loadCredentialsFromEnvOrFileOrInstanceMetadata :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromEnvOrFileOrInstanceMetadata file key = do envcr <- loadCredentialsFromEnv case envcr of Just cr -> return (Just cr) Nothing -> do filecr <- loadCredentialsFromFile file key case filecr of Just cr -> return (Just cr) Nothing -> loadCredentialsFromInstanceMetadata -- | Load credentials from environment variables if possible, or alternative from the default file with the default -- key name. -- -- Default file: //@/.aws-keys@ -- Default key name: @default@ -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do mfile <- credentialsDefaultFile case mfile of Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey Nothing -> loadCredentialsFromEnv -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol = HTTP | HTTPS deriving (Eq,Read,Show,Ord,Typeable) -- | The default port to be used for a protocol if no specific port is specified. defaultPort :: Protocol -> Int defaultPort HTTP = 80 defaultPort HTTPS = 443 -- | Request method. Not all request methods are supported by all services. data Method = Head -- ^ HEAD method. Put all request parameters in a query string and HTTP headers. | Get -- ^ GET method. Put all request parameters in a query string and HTTP headers. | PostQuery -- ^ POST method. Put all request parameters in a query string and HTTP headers, but send the query string -- as a POST payload | Post -- ^ POST method. Sends a service- and request-specific request body. | Put -- ^ PUT method. | Delete -- ^ DELETE method. deriving (Show, Eq, Ord) -- | HTTP method associated with a request method. httpMethod :: Method -> HTTP.Method httpMethod Head = "HEAD" httpMethod Get = "GET" httpMethod PostQuery = "POST" httpMethod Post = "POST" httpMethod Put = "PUT" httpMethod Delete = "DELETE" -- | A pre-signed medium-level request object. data SignedQuery = SignedQuery { -- | Request method. sqMethod :: !Method -- | Protocol to be used. , sqProtocol :: !Protocol -- | HTTP host. , sqHost :: !B.ByteString -- | IP port. , sqPort :: !Int -- | HTTP path. , sqPath :: !B.ByteString -- | Query string list (used with 'Get' and 'PostQuery'). , sqQuery :: !HTTP.Query -- | Request date/time. , sqDate :: !(Maybe UTCTime) -- | Authorization string (if applicable), for @Authorization@ header. See 'authorizationV4' , sqAuthorization :: !(Maybe (IO B.ByteString)) -- | Request body content type. , sqContentType :: !(Maybe B.ByteString) -- | Request body content MD5. , sqContentMd5 :: !(Maybe (Digest MD5)) -- | Additional Amazon "amz" headers. , sqAmzHeaders :: !HTTP.RequestHeaders -- | Additional non-"amz" headers. , sqOtherHeaders :: !HTTP.RequestHeaders -- | Request body (used with 'Post' and 'Put'). #if MIN_VERSION_http_conduit(2, 0, 0) , sqBody :: !(Maybe HTTP.RequestBody) #else , sqBody :: !(Maybe (HTTP.RequestBody (C.ResourceT IO))) #endif -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes. , sqStringToSign :: !B.ByteString } --deriving (Show) -- | Create a HTTP request from a 'SignedQuery' object. #if MIN_VERSION_http_conduit(2, 0, 0) queryToHttpRequest :: SignedQuery -> IO HTTP.Request #else queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO)) #endif queryToHttpRequest SignedQuery{..} = do mauth <- maybe (return Nothing) (Just<$>) sqAuthorization return $ HTTP.defaultRequest { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False HTTPS -> True , HTTP.host = sqHost , HTTP.port = sqPort , HTTP.path = sqPath , HTTP.queryString = if sqMethod == PostQuery then "" else HTTP.renderQuery False sqQuery , HTTP.requestHeaders = catMaybes [ checkDate (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType , fmap (\md5 -> ("Content-MD5", Base64.encode $ toBytes md5)) sqContentMd5 , fmap (\auth -> ("Authorization", auth)) mauth] ++ sqAmzHeaders ++ sqOtherHeaders , HTTP.requestBody = -- An explicityly defined body parameter should overwrite everything else. case sqBody of Just x -> x Nothing -> -- a POST query should convert its query string into the body case sqMethod of PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery _ -> HTTP.RequestBodyBuilder 0 mempty , HTTP.decompress = HTTP.alwaysDecompress #if MIN_VERSION_http_conduit(2,2,0) , HTTP.checkResponse = \_ _ -> return () #else , HTTP.checkStatus = \_ _ _-> Nothing #endif , HTTP.redirectCount = 10 } where checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup "date" sqOtherHeaders -- An explicitly defined content-type should override everything else. contentType = sqContentType `mplus` defContentType defContentType = case sqMethod of PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8" _ -> Nothing -- | Create a URI fro a 'SignedQuery' object. -- -- Unused / incompatible fields will be silently ignored. queryToUri :: SignedQuery -> B.ByteString queryToUri SignedQuery{..} = B.concat [ case sqProtocol of HTTP -> "http://" HTTPS -> "https://" , sqHost , if sqPort == defaultPort sqProtocol then "" else T.encodeUtf8 . T.pack $ ':' : show sqPort , sqPath , HTTP.renderQuery True sqQuery ] -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration -- (absolute or relative). data TimeInfo = Timestamp -- ^ Use a simple timestamp to let AWS check the request validity. | ExpiresAt { fromExpiresAt :: UTCTime } -- ^ Let requests expire at a specific fixed time. | ExpiresIn { fromExpiresIn :: NominalDiffTime } -- ^ Let requests expire a specific number of seconds after they -- were generated. deriving (Show) -- | Like 'TimeInfo', but with all relative times replaced by absolute UTC. data AbsoluteTimeInfo = AbsoluteTimestamp { fromAbsoluteTimestamp :: UTCTime } | AbsoluteExpires { fromAbsoluteExpires :: UTCTime } deriving (Show) -- | Just the UTC time value. fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime fromAbsoluteTimeInfo (AbsoluteTimestamp time) = time fromAbsoluteTimeInfo (AbsoluteExpires time) = time -- | Convert 'TimeInfo' to 'AbsoluteTimeInfo' given the current UTC time. makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo makeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now makeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t makeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now -- | Data that is always required for signing requests. data SignatureData = SignatureData { -- | Expiration or timestamp. signatureTimeInfo :: AbsoluteTimeInfo -- | Current time. , signatureTime :: UTCTime -- | Access credentials. , signatureCredentials :: Credentials } -- | Create signature data using the current system time. signatureData :: TimeInfo -> Credentials -> IO SignatureData signatureData rti cr = do now <- getCurrentTime let ti = makeAbsoluteTimeInfo rti now return SignatureData { signatureTimeInfo = ti, signatureTime = now, signatureCredentials = cr } -- | Tag type for normal queries. data NormalQuery -- | Tag type for URI-only queries. data UriOnlyQuery -- | A "signable" request object. Assembles together the Query, and signs it in one go. class SignQuery request where -- | Additional information, like API endpoints and service-specific preferences. type ServiceConfiguration request :: * {- Query Type -} -> * -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'. signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery -- | Supported crypto hashes for the signature. data AuthorizationHash = HmacSHA1 | HmacSHA256 deriving (Show) -- | Authorization hash identifier as expected by Amazon. amzHash :: AuthorizationHash -> B.ByteString amzHash HmacSHA1 = "HmacSHA1" amzHash HmacSHA256 = "HmacSHA256" -- | Create a signature. Usually, AWS wants a specifically constructed string to be signed. -- -- The signature is a HMAC-based hash of the string and the secret access key. signature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString signature cr ah input = Base64.encode sig where sig = case ah of HmacSHA1 -> computeSig SHA1 HmacSHA256 -> computeSig SHA256 computeSig :: HashAlgorithm a => a -> ByteString computeSig t = toBytes (hmacAlg t (secretAccessKey cr) input) -- | Use this to create the Authorization header to set into 'sqAuthorization'. -- See : you must create the -- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3. authorizationV4 :: SignatureData -> AuthorizationHash -> B.ByteString -- ^ region, e.g. us-east-1 -> B.ByteString -- ^ service, e.g. dynamodb -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target -> B.ByteString -- ^ canonicalRequest (before hashing) -> IO B.ByteString authorizationV4 sd ah region service headers canonicalRequest = do let ref = v4SigningKeys $ signatureCredentials sd date = fmtTime "%Y%m%d" $ signatureTime sd mkHmac k i = case ah of HmacSHA1 -> toBytes (hmac k i :: HMAC SHA1) HmacSHA256 -> toBytes (hmac k i :: HMAC SHA256) mkHash i = case ah of HmacSHA1 -> toBytes (hash i :: Digest SHA1) HmacSHA256 -> toBytes (hash i :: Digest SHA256) alg = case ah of HmacSHA1 -> "AWS4-HMAC-SHA1" HmacSHA256 -> "AWS4-HMAC-SHA256" -- Lookup existing signing key allkeys <- readIORef ref let mkey = case lookup (region,service) allkeys of Just (d,k) | d /= date -> Nothing | otherwise -> Just k Nothing -> Nothing -- possibly create a new signing key key <- case mkey of Just k -> return k Nothing -> atomicModifyIORef ref $ \keylist -> let secretKey = secretAccessKey $ signatureCredentials sd kDate = mkHmac ("AWS4" <> secretKey) date kRegion = mkHmac kDate region kService = mkHmac kRegion service kSigning = mkHmac kService "aws4_request" lstK = (region,service) keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist in (keylist', kSigning) -- now do the signature let canonicalRequestHash = Base16.encode $ mkHash canonicalRequest stringToSign = B.concat [ alg , "\n" , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd , "\n" , date , "/" , region , "/" , service , "/aws4_request\n" , canonicalRequestHash ] sig = Base16.encode $ mkHmac key stringToSign -- finally, return the header return $ B.concat [ alg , " Credential=" , accessKeyID (signatureCredentials sd) , "/" , date , "/" , region , "/" , service , "/aws4_request," , "SignedHeaders=" , headers , ",Signature=" , sig ] -- | Default configuration for a specific service. class DefaultServiceConfiguration config where -- | Default service configuration. defServiceConfig :: config -- | Default debugging-only configuration. (Normally using HTTP instead of HTTPS for easier debugging.) debugServiceConfig :: config debugServiceConfig = defServiceConfig -- | @queryList f prefix xs@ constructs a query list from a list of -- elements @xs@, using a common prefix @prefix@, and a transformer -- function @f@. -- -- A dot (@.@) is interspersed between prefix and generated key. -- -- Example: -- -- @queryList swap \"pfx\" [(\"a\", \"b\"), (\"c\", \"d\")]@ evaluates to @[(\"pfx.b\", \"a\"), (\"pfx.d\", \"c\")]@ -- (except with ByteString instead of String, of course). queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)] queryList f prefix xs = concat $ zipWith combine prefixList (map f xs) where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..] combine pf = map $ first (pf `dot`) dot x y = B.concat [x, BU.fromString ".", y] -- | A \"true\"/\"false\" boolean as requested by some services. awsBool :: Bool -> B.ByteString awsBool True = "true" awsBool False = "false" -- | \"true\" awsTrue :: B.ByteString awsTrue = awsBool True -- | \"false\" awsFalse :: B.ByteString awsFalse = awsBool False -- | Format time according to a format string, as a ByteString. fmtTime :: String -> UTCTime -> B.ByteString fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t rfc822Time :: String rfc822Time = "%a, %0d %b %Y %H:%M:%S GMT" -- | Format time in RFC 822 format. fmtRfc822Time :: UTCTime -> B.ByteString fmtRfc822Time = fmtTime rfc822Time -- | Format time in yyyy-mm-ddThh-mm-ss format. fmtAmzTime :: UTCTime -> B.ByteString fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S" -- | Format time as seconds since the Unix epoch. fmtTimeEpochSeconds :: UTCTime -> B.ByteString fmtTimeEpochSeconds = fmtTime "%s" -- | Parse HTTP-date (section 3.3.1 of RFC 2616) parseHttpDate :: String -> Maybe UTCTime parseHttpDate s = p "%a, %d %b %Y %H:%M:%S GMT" s -- rfc1123-date <|> p "%A, %d-%b-%y %H:%M:%S GMT" s -- rfc850-date <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date <|> p "%Y-%m-%dT%H:%M:%S%QZ" s -- iso 8601 <|> p "%Y-%m-%dT%H:%M:%S%Q%Z" s -- iso 8601 where p = parseTime defaultTimeLocale -- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) httpDate1 :: String httpDate1 = "%a, %d %b %Y %H:%M:%S GMT" -- rfc1123-date -- | Format (as Text) HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) textHttpDate :: UTCTime -> T.Text textHttpDate = T.pack . formatTime defaultTimeLocale httpDate1 iso8601UtcDate :: String iso8601UtcDate = "%Y-%m-%dT%H:%M:%S%QZ" -- | Parse a two-digit hex number. readHex2 :: [Char] -> Maybe Word8 readHex2 [c1,c2] = do n1 <- readHex1 c1 n2 <- readHex1 c2 return . fromIntegral $ n1 * 16 + n2 where readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0' | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10 | c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10 readHex1 _ = Nothing readHex2 _ = Nothing -- XML -- | An error that occurred during XML parsing / validation. newtype XmlException = XmlException { xmlErrorMessage :: String } deriving (Show, Typeable) instance E.Exception XmlException -- | An error that occurred during header parsing / validation. newtype HeaderException = HeaderException { headerErrorMessage :: String } deriving (Show, Typeable) instance E.Exception HeaderException -- | An error that occurred during form parsing / validation. newtype FormException = FormException { formErrorMesage :: String } deriving (Show, Typeable) instance E.Exception FormException -- | No credentials were found and an invariant was violated. newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMessage :: String } deriving (Show, Typeable) instance E.Exception NoCredentialsException -- | A helper to throw an 'HTTP.StatusCodeException'. throwStatusCodeException :: HTTP.Request -> HTTP.Response (C.ResumableSource (ResourceT IO) ByteString) -> ResourceT IO a #if MIN_VERSION_http_conduit(2,2,0) throwStatusCodeException req resp = do let resp' = fmap (const ()) resp -- only take first 10kB of error response body <- HTTP.responseBody resp C.$$+- CB.take (10*1024) let sce = HTTP.StatusCodeException resp' (L.toStrict body) throwM $ HTTP.HttpExceptionRequest req sce #else throwStatusCodeException _req resp = do let cookies = HTTP.responseCookieJar resp headers = HTTP.responseHeaders resp status = HTTP.responseStatus resp throwM $ HTTP.StatusCodeException status headers cookies #endif -- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents. elContent :: T.Text -> Cursor -> [T.Text] elContent name = laxElement name &/ content -- | Like 'elContent', but extracts 'String's instead of 'T.Text'. elCont :: T.Text -> Cursor -> [String] elCont name = laxElement name &/ content &| T.unpack -- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty. force :: MonadThrow m => String -> [a] -> m a force = Cu.force . XmlException -- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty. forceM :: MonadThrow m => String -> [m a] -> m a forceM = Cu.forceM . XmlException -- | Read a boolean from a 'T.Text', throwing an 'XmlException' on failure. textReadBool :: MonadThrow m => T.Text -> m Bool textReadBool s = case T.unpack s of "true" -> return True "false" -> return False _ -> throwM $ XmlException "Invalid Bool" -- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure. textReadInt :: (MonadThrow m, Num a) => T.Text -> m a textReadInt s = case reads $ T.unpack s of [(n,"")] -> return $ fromInteger n _ -> throwM $ XmlException "Invalid Integer" -- | Read an integer from a 'String', throwing an 'XmlException' on failure. readInt :: (MonadThrow m, Num a) => String -> m a readInt s = case reads s of [(n,"")] -> return $ fromInteger n _ -> throwM $ XmlException "Invalid Integer" -- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response -- body. -- -- This function is highly recommended for any services that parse relatively short XML responses. (If status and response -- headers are required, simply take them as function parameters, and pass them through to this function.) xmlCursorConsumer :: (Monoid m) => (Cu.Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a xmlCursorConsumer parse metadataRef res = do doc <- HTTP.responseBody res $$+- XML.sinkDoc XML.def let cursor = Cu.fromDocument doc let Response metadata x = parse cursor liftIO $ tellMetadataRef metadataRef metadata case x of Left err -> liftIO $ throwM err Right v -> return v