{-# LANGUAGE CPP, BangPatterns #-}
module Aws.S3.Core where

import           Aws.Core
import           Control.Arrow                  (first, (***))
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Resource   (MonadThrow, throwM)
import           Data.Char                      (isAscii, isAlphaNum, toUpper, ord)
import           Data.Conduit                   ((.|))
import           Data.Function
import           Data.Functor
import           Data.IORef
import           Data.List
import           Data.Maybe
import           Data.Monoid
import qualified Data.Semigroup                 as Sem
import           Control.Applicative            ((<|>))
import           Data.Time
import           Data.Typeable
import           Numeric                        (showHex)
#if !MIN_VERSION_time(1,5,0)
import           System.Locale
#endif
import           Text.XML.Cursor                (($/), (&|))
import qualified Data.Attoparsec.ByteString     as Atto
import qualified Blaze.ByteString.Builder       as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import qualified Control.Exception              as C
import qualified Crypto.Hash                    as CH
import qualified Data.ByteArray                 as ByteArray
import qualified Data.ByteString                as B
import qualified Data.ByteString.Char8          as B8
import qualified Data.ByteString.Base16         as Base16
import qualified Data.ByteString.Base64         as Base64
import qualified Data.CaseInsensitive           as CI
import qualified Data.Conduit                   as C
import qualified Data.Map                       as Map
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as T
import qualified Network.HTTP.Conduit           as HTTP
import qualified Network.HTTP.Types             as HTTP
import qualified Text.XML                       as XML
import qualified Text.XML.Cursor                as Cu
import           Prelude

data S3Authorization
    = S3AuthorizationHeader
    | S3AuthorizationQuery
    deriving (Int -> S3Authorization -> ShowS
[S3Authorization] -> ShowS
S3Authorization -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S3Authorization] -> ShowS
$cshowList :: [S3Authorization] -> ShowS
show :: S3Authorization -> String
$cshow :: S3Authorization -> String
showsPrec :: Int -> S3Authorization -> ShowS
$cshowsPrec :: Int -> S3Authorization -> ShowS
Show)

data RequestStyle
    = PathStyle -- ^ Requires correctly setting region endpoint, but allows non-DNS compliant bucket names in the US standard region.
    | BucketStyle -- ^ Bucket name must be DNS compliant.
    | VHostStyle
    deriving (Int -> RequestStyle -> ShowS
[RequestStyle] -> ShowS
RequestStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestStyle] -> ShowS
$cshowList :: [RequestStyle] -> ShowS
show :: RequestStyle -> String
$cshow :: RequestStyle -> String
showsPrec :: Int -> RequestStyle -> ShowS
$cshowsPrec :: Int -> RequestStyle -> ShowS
Show)

data S3SignPayloadMode
    = AlwaysUnsigned -- ^ Always use the "UNSIGNED-PAYLOAD" option.
    | SignWithEffort -- ^ Sign the payload when 'HTTP.RequestBody' is a on-memory one ('HTTP.RequestBodyLBS' or 'HTTP.RequestBodyBS'). Otherwise use the "UNSINGED-PAYLOAD" option.
    | AlwaysSigned   -- ^ Always sign the payload. Note: 'error' called when 'HTTP.RequestBody' is a streaming one.
    deriving (S3SignPayloadMode -> S3SignPayloadMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
$c/= :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
== :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
$c== :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
Eq, Int -> S3SignPayloadMode -> ShowS
[S3SignPayloadMode] -> ShowS
S3SignPayloadMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S3SignPayloadMode] -> ShowS
$cshowList :: [S3SignPayloadMode] -> ShowS
show :: S3SignPayloadMode -> String
$cshow :: S3SignPayloadMode -> String
showsPrec :: Int -> S3SignPayloadMode -> ShowS
$cshowsPrec :: Int -> S3SignPayloadMode -> ShowS
Show, ReadPrec [S3SignPayloadMode]
ReadPrec S3SignPayloadMode
Int -> ReadS S3SignPayloadMode
ReadS [S3SignPayloadMode]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [S3SignPayloadMode]
$creadListPrec :: ReadPrec [S3SignPayloadMode]
readPrec :: ReadPrec S3SignPayloadMode
$creadPrec :: ReadPrec S3SignPayloadMode
readList :: ReadS [S3SignPayloadMode]
$creadList :: ReadS [S3SignPayloadMode]
readsPrec :: Int -> ReadS S3SignPayloadMode
$creadsPrec :: Int -> ReadS S3SignPayloadMode
Read, Typeable)

data S3SignVersion
    = S3SignV2
    | S3SignV4 { S3SignVersion -> S3SignPayloadMode
_s3SignPayloadMode :: S3SignPayloadMode }
    deriving (S3SignVersion -> S3SignVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: S3SignVersion -> S3SignVersion -> Bool
$c/= :: S3SignVersion -> S3SignVersion -> Bool
== :: S3SignVersion -> S3SignVersion -> Bool
$c== :: S3SignVersion -> S3SignVersion -> Bool
Eq, Int -> S3SignVersion -> ShowS
[S3SignVersion] -> ShowS
S3SignVersion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S3SignVersion] -> ShowS
$cshowList :: [S3SignVersion] -> ShowS
show :: S3SignVersion -> String
$cshow :: S3SignVersion -> String
showsPrec :: Int -> S3SignVersion -> ShowS
$cshowsPrec :: Int -> S3SignVersion -> ShowS
Show, ReadPrec [S3SignVersion]
ReadPrec S3SignVersion
Int -> ReadS S3SignVersion
ReadS [S3SignVersion]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [S3SignVersion]
$creadListPrec :: ReadPrec [S3SignVersion]
readPrec :: ReadPrec S3SignVersion
$creadPrec :: ReadPrec S3SignVersion
readList :: ReadS [S3SignVersion]
$creadList :: ReadS [S3SignVersion]
readsPrec :: Int -> ReadS S3SignVersion
$creadsPrec :: Int -> ReadS S3SignVersion
Read, Typeable)

data S3Configuration qt
    = S3Configuration {
        forall qt. S3Configuration qt -> Protocol
s3Protocol :: Protocol
      , forall qt. S3Configuration qt -> ByteString
s3Endpoint :: B.ByteString
      , forall qt. S3Configuration qt -> RequestStyle
s3RequestStyle :: RequestStyle
      , forall qt. S3Configuration qt -> Int
s3Port :: Int
      , forall qt. S3Configuration qt -> Maybe ServerSideEncryption
s3ServerSideEncryption :: Maybe ServerSideEncryption
      , forall qt. S3Configuration qt -> Bool
s3UseUri :: Bool
      , forall qt. S3Configuration qt -> NominalDiffTime
s3DefaultExpiry :: NominalDiffTime
      , forall qt. S3Configuration qt -> S3SignVersion
s3SignVersion :: S3SignVersion
      }
    deriving (Int -> S3Configuration qt -> ShowS
forall qt. Int -> S3Configuration qt -> ShowS
forall qt. [S3Configuration qt] -> ShowS
forall qt. S3Configuration qt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S3Configuration qt] -> ShowS
$cshowList :: forall qt. [S3Configuration qt] -> ShowS
show :: S3Configuration qt -> String
$cshow :: forall qt. S3Configuration qt -> String
showsPrec :: Int -> S3Configuration qt -> ShowS
$cshowsPrec :: forall qt. Int -> S3Configuration qt -> ShowS
Show)

instance DefaultServiceConfiguration (S3Configuration NormalQuery) where
  defServiceConfig :: S3Configuration NormalQuery
defServiceConfig = forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
HTTPS ByteString
s3EndpointUsClassic Bool
False

  debugServiceConfig :: S3Configuration NormalQuery
debugServiceConfig = forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
HTTP ByteString
s3EndpointUsClassic Bool
False

instance DefaultServiceConfiguration (S3Configuration UriOnlyQuery) where
  defServiceConfig :: S3Configuration UriOnlyQuery
defServiceConfig = forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
HTTPS ByteString
s3EndpointUsClassic Bool
True
  debugServiceConfig :: S3Configuration UriOnlyQuery
debugServiceConfig = forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
HTTP ByteString
s3EndpointUsClassic Bool
True

s3EndpointUsClassic :: B.ByteString
s3EndpointUsClassic :: ByteString
s3EndpointUsClassic = ByteString
"s3.amazonaws.com"

s3EndpointUsWest :: B.ByteString
s3EndpointUsWest :: ByteString
s3EndpointUsWest = ByteString
"s3-us-west-1.amazonaws.com"

s3EndpointUsWest2 :: B.ByteString
s3EndpointUsWest2 :: ByteString
s3EndpointUsWest2 = ByteString
"s3-us-west-2.amazonaws.com"

s3EndpointEu :: B.ByteString
s3EndpointEu :: ByteString
s3EndpointEu = ByteString
"s3-eu-west-1.amazonaws.com"

s3EndpointEuWest2 :: B.ByteString
s3EndpointEuWest2 :: ByteString
s3EndpointEuWest2 = ByteString
"s3-eu-west-2.amazonaws.com"

s3EndpointApSouthEast :: B.ByteString
s3EndpointApSouthEast :: ByteString
s3EndpointApSouthEast = ByteString
"s3-ap-southeast-1.amazonaws.com"

s3EndpointApSouthEast2 :: B.ByteString
s3EndpointApSouthEast2 :: ByteString
s3EndpointApSouthEast2 = ByteString
"s3-ap-southeast-2.amazonaws.com"

s3EndpointApNorthEast :: B.ByteString
s3EndpointApNorthEast :: ByteString
s3EndpointApNorthEast = ByteString
"s3-ap-northeast-1.amazonaws.com"

s3 :: Protocol -> B.ByteString -> Bool -> S3Configuration qt
s3 :: forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
protocol ByteString
endpoint Bool
uri
    = S3Configuration {
         s3Protocol :: Protocol
s3Protocol = Protocol
protocol
       , s3Endpoint :: ByteString
s3Endpoint = ByteString
endpoint
       , s3RequestStyle :: RequestStyle
s3RequestStyle = RequestStyle
BucketStyle
       , s3Port :: Int
s3Port = Protocol -> Int
defaultPort Protocol
protocol
       , s3ServerSideEncryption :: Maybe ServerSideEncryption
s3ServerSideEncryption = forall a. Maybe a
Nothing
       , s3UseUri :: Bool
s3UseUri = Bool
uri
       , s3DefaultExpiry :: NominalDiffTime
s3DefaultExpiry = NominalDiffTime
15forall a. Num a => a -> a -> a
*NominalDiffTime
60
       , s3SignVersion :: S3SignVersion
s3SignVersion = S3SignVersion
S3SignV2
       }

s3v4 :: Protocol -> B.ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt
s3v4 :: forall qt.
Protocol
-> ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt
s3v4 Protocol
protocol ByteString
endpoint Bool
uri S3SignPayloadMode
payload
    = S3Configuration
    { s3Protocol :: Protocol
s3Protocol = Protocol
protocol
    , s3Endpoint :: ByteString
s3Endpoint = ByteString
endpoint
    , s3RequestStyle :: RequestStyle
s3RequestStyle = RequestStyle
BucketStyle
    , s3Port :: Int
s3Port = Protocol -> Int
defaultPort Protocol
protocol
    , s3ServerSideEncryption :: Maybe ServerSideEncryption
s3ServerSideEncryption = forall a. Maybe a
Nothing
    , s3UseUri :: Bool
s3UseUri = Bool
uri
    , s3DefaultExpiry :: NominalDiffTime
s3DefaultExpiry = NominalDiffTime
15forall a. Num a => a -> a -> a
*NominalDiffTime
60
    , s3SignVersion :: S3SignVersion
s3SignVersion = S3SignPayloadMode -> S3SignVersion
S3SignV4 S3SignPayloadMode
payload
    }


type ErrorCode = T.Text

data S3Error
    = S3Error {
        S3Error -> Status
s3StatusCode :: HTTP.Status
      , S3Error -> LocationConstraint
s3ErrorCode :: ErrorCode -- Error/Code
      , S3Error -> LocationConstraint
s3ErrorMessage :: T.Text -- Error/Message
      , S3Error -> Maybe LocationConstraint
s3ErrorResource :: Maybe T.Text -- Error/Resource
      , S3Error -> Maybe LocationConstraint
s3ErrorHostId :: Maybe T.Text -- Error/HostId
      , S3Error -> Maybe LocationConstraint
s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId
      , S3Error -> Maybe ByteString
s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding)
      , S3Error -> Maybe LocationConstraint
s3ErrorBucket :: Maybe T.Text -- Error/Bucket
      , S3Error -> Maybe LocationConstraint
s3ErrorEndpointRaw :: Maybe T.Text -- Error/Endpoint (i.e. correct bucket location)
      , S3Error -> Maybe ByteString
s3ErrorEndpoint :: Maybe B.ByteString -- Error/Endpoint without the bucket prefix
      }
    deriving (Int -> S3Error -> ShowS
[S3Error] -> ShowS
S3Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S3Error] -> ShowS
$cshowList :: [S3Error] -> ShowS
show :: S3Error -> String
$cshow :: S3Error -> String
showsPrec :: Int -> S3Error -> ShowS
$cshowsPrec :: Int -> S3Error -> ShowS
Show, Typeable)

instance C.Exception S3Error

data S3Metadata
    = S3Metadata {
        S3Metadata -> Maybe LocationConstraint
s3MAmzId2 :: Maybe T.Text
      , S3Metadata -> Maybe LocationConstraint
s3MRequestId :: Maybe T.Text
      }
    deriving (Int -> S3Metadata -> ShowS
[S3Metadata] -> ShowS
S3Metadata -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S3Metadata] -> ShowS
$cshowList :: [S3Metadata] -> ShowS
show :: S3Metadata -> String
$cshow :: S3Metadata -> String
showsPrec :: Int -> S3Metadata -> ShowS
$cshowsPrec :: Int -> S3Metadata -> ShowS
Show, Typeable)

instance Sem.Semigroup S3Metadata where
    S3Metadata Maybe LocationConstraint
a1 Maybe LocationConstraint
r1 <> :: S3Metadata -> S3Metadata -> S3Metadata
<> S3Metadata Maybe LocationConstraint
a2 Maybe LocationConstraint
r2 = Maybe LocationConstraint -> Maybe LocationConstraint -> S3Metadata
S3Metadata (Maybe LocationConstraint
a1 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe LocationConstraint
a2) (Maybe LocationConstraint
r1 forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe LocationConstraint
r2)

instance Monoid S3Metadata where
    mempty :: S3Metadata
mempty = Maybe LocationConstraint -> Maybe LocationConstraint -> S3Metadata
S3Metadata forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    mappend :: S3Metadata -> S3Metadata -> S3Metadata
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)

instance Loggable S3Metadata where
    toLogText :: S3Metadata -> LocationConstraint
toLogText (S3Metadata Maybe LocationConstraint
id2 Maybe LocationConstraint
rid) = LocationConstraint
"S3: request ID=" forall a. Monoid a => a -> a -> a
`mappend`
                                     forall a. a -> Maybe a -> a
fromMaybe LocationConstraint
"<none>" Maybe LocationConstraint
rid forall a. Monoid a => a -> a -> a
`mappend`
                                     LocationConstraint
", x-amz-id-2=" forall a. Monoid a => a -> a -> a
`mappend`
                                     forall a. a -> Maybe a -> a
fromMaybe LocationConstraint
"<none>" Maybe LocationConstraint
id2

data S3Query
    = S3Query {
        S3Query -> Method
s3QMethod :: Method
      , S3Query -> Maybe ByteString
s3QBucket :: Maybe B.ByteString
      , S3Query -> Maybe ByteString
s3QObject :: Maybe B.ByteString
      , S3Query -> Query
s3QSubresources :: HTTP.Query
      , S3Query -> Query
s3QQuery :: HTTP.Query
      , S3Query -> Maybe ByteString
s3QContentType :: Maybe B.ByteString
      , S3Query -> Maybe (Digest MD5)
s3QContentMd5 :: Maybe (CH.Digest CH.MD5)
      , S3Query -> RequestHeaders
s3QAmzHeaders :: HTTP.RequestHeaders
      , S3Query -> RequestHeaders
s3QOtherHeaders :: HTTP.RequestHeaders
      , S3Query -> Maybe RequestBody
s3QRequestBody :: Maybe HTTP.RequestBody
      }

instance Show S3Query where
    show :: S3Query -> String
show S3Query{Query
RequestHeaders
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
Method
s3QRequestBody :: Maybe RequestBody
s3QOtherHeaders :: RequestHeaders
s3QAmzHeaders :: RequestHeaders
s3QContentMd5 :: Maybe (Digest MD5)
s3QContentType :: Maybe ByteString
s3QQuery :: Query
s3QSubresources :: Query
s3QObject :: Maybe ByteString
s3QBucket :: Maybe ByteString
s3QMethod :: Method
s3QRequestBody :: S3Query -> Maybe RequestBody
s3QOtherHeaders :: S3Query -> RequestHeaders
s3QAmzHeaders :: S3Query -> RequestHeaders
s3QContentMd5 :: S3Query -> Maybe (Digest MD5)
s3QContentType :: S3Query -> Maybe ByteString
s3QQuery :: S3Query -> Query
s3QSubresources :: S3Query -> Query
s3QObject :: S3Query -> Maybe ByteString
s3QBucket :: S3Query -> Maybe ByteString
s3QMethod :: S3Query -> Method
..} = String
"S3Query [" forall a. [a] -> [a] -> [a]
++
                       String
" method: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Method
s3QMethod forall a. [a] -> [a] -> [a]
++
                       String
" ; bucket: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe ByteString
s3QBucket forall a. [a] -> [a] -> [a]
++
                       String
" ; subresources: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Query
s3QSubresources forall a. [a] -> [a] -> [a]
++
                       String
" ; query: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Query
s3QQuery forall a. [a] -> [a] -> [a]
++
                       String
" ; request body: " forall a. [a] -> [a] -> [a]
++ (case Maybe RequestBody
s3QRequestBody of Maybe RequestBody
Nothing -> String
"no"; Maybe RequestBody
_ -> String
"yes") forall a. [a] -> [a] -> [a]
++
                       String
"]"

hAmzDate, hAmzContentSha256, hAmzAlgorithm, hAmzCredential, hAmzExpires, hAmzSignedHeaders, hAmzSignature, hAmzSecurityToken :: HTTP.HeaderName
hAmzDate :: HeaderName
hAmzDate          = HeaderName
"X-Amz-Date"
hAmzContentSha256 :: HeaderName
hAmzContentSha256 = HeaderName
"X-Amz-Content-Sha256"
hAmzAlgorithm :: HeaderName
hAmzAlgorithm     = HeaderName
"X-Amz-Algorithm"
hAmzCredential :: HeaderName
hAmzCredential    = HeaderName
"X-Amz-Credential"
hAmzExpires :: HeaderName
hAmzExpires       = HeaderName
"X-Amz-Expires"
hAmzSignedHeaders :: HeaderName
hAmzSignedHeaders = HeaderName
"X-Amz-SignedHeaders"
hAmzSignature :: HeaderName
hAmzSignature     = HeaderName
"X-Amz-Signature"
hAmzSecurityToken :: HeaderName
hAmzSecurityToken = HeaderName
"X-Amz-Security-Token"

s3SignQuery :: S3Query -> S3Configuration qt -> SignatureData -> SignedQuery
s3SignQuery :: forall qt.
S3Query -> S3Configuration qt -> SignatureData -> SignedQuery
s3SignQuery S3Query{Query
RequestHeaders
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
Method
s3QRequestBody :: Maybe RequestBody
s3QOtherHeaders :: RequestHeaders
s3QAmzHeaders :: RequestHeaders
s3QContentMd5 :: Maybe (Digest MD5)
s3QContentType :: Maybe ByteString
s3QQuery :: Query
s3QSubresources :: Query
s3QObject :: Maybe ByteString
s3QBucket :: Maybe ByteString
s3QMethod :: Method
s3QRequestBody :: S3Query -> Maybe RequestBody
s3QOtherHeaders :: S3Query -> RequestHeaders
s3QAmzHeaders :: S3Query -> RequestHeaders
s3QContentMd5 :: S3Query -> Maybe (Digest MD5)
s3QContentType :: S3Query -> Maybe ByteString
s3QQuery :: S3Query -> Query
s3QSubresources :: S3Query -> Query
s3QObject :: S3Query -> Maybe ByteString
s3QBucket :: S3Query -> Maybe ByteString
s3QMethod :: S3Query -> Method
..} S3Configuration{ s3SignVersion :: forall qt. S3Configuration qt -> S3SignVersion
s3SignVersion = S3SignVersion
S3SignV2, Bool
Int
Maybe ServerSideEncryption
ByteString
NominalDiffTime
Protocol
RequestStyle
s3DefaultExpiry :: NominalDiffTime
s3UseUri :: Bool
s3ServerSideEncryption :: Maybe ServerSideEncryption
s3Port :: Int
s3RequestStyle :: RequestStyle
s3Endpoint :: ByteString
s3Protocol :: Protocol
s3DefaultExpiry :: forall qt. S3Configuration qt -> NominalDiffTime
s3UseUri :: forall qt. S3Configuration qt -> Bool
s3ServerSideEncryption :: forall qt. S3Configuration qt -> Maybe ServerSideEncryption
s3Port :: forall qt. S3Configuration qt -> Int
s3RequestStyle :: forall qt. S3Configuration qt -> RequestStyle
s3Endpoint :: forall qt. S3Configuration qt -> ByteString
s3Protocol :: forall qt. S3Configuration qt -> Protocol
.. } SignatureData{UTCTime
AbsoluteTimeInfo
Credentials
signatureCredentials :: SignatureData -> Credentials
signatureTime :: SignatureData -> UTCTime
signatureTimeInfo :: SignatureData -> AbsoluteTimeInfo
signatureCredentials :: Credentials
signatureTime :: UTCTime
signatureTimeInfo :: AbsoluteTimeInfo
..}
    = SignedQuery {
        sqMethod :: Method
sqMethod = Method
s3QMethod
      , sqProtocol :: Protocol
sqProtocol = Protocol
s3Protocol
      , sqHost :: ByteString
sqHost = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
host
      , sqPort :: Int
sqPort = Int
s3Port
      , sqPath :: ByteString
sqPath = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
path
      , sqQuery :: Query
sqQuery = Query
sortedSubresources forall a. [a] -> [a] -> [a]
++ Query
s3QQuery forall a. [a] -> [a] -> [a]
++ Query
authQuery :: HTTP.Query
      , sqDate :: Maybe UTCTime
sqDate = forall a. a -> Maybe a
Just UTCTime
signatureTime
      , sqAuthorization :: Maybe (IO ByteString)
sqAuthorization = Maybe (IO ByteString)
authorization
      , sqContentType :: Maybe ByteString
sqContentType = Maybe ByteString
s3QContentType
      , sqContentMd5 :: Maybe (Digest MD5)
sqContentMd5 = Maybe (Digest MD5)
s3QContentMd5
      , sqAmzHeaders :: RequestHeaders
sqAmzHeaders = RequestHeaders
amzHeaders
      , sqOtherHeaders :: RequestHeaders
sqOtherHeaders = RequestHeaders
s3QOtherHeaders
      , sqBody :: Maybe RequestBody
sqBody = Maybe RequestBody
s3QRequestBody
      , sqStringToSign :: ByteString
sqStringToSign = ByteString
stringToSign
      }
    where
      -- This also implements anonymous queries.
      isanon :: Bool
isanon = Credentials -> Bool
isAnonymousCredentials Credentials
signatureCredentials 
      amzHeaders :: RequestHeaders
amzHeaders = forall {a}. Eq a => [(a, ByteString)] -> [(a, ByteString)]
merge forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ RequestHeaders
s3QAmzHeaders forall a. [a] -> [a] -> [a]
++ 
        if Bool
isanon 
          then []
          else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
k, ByteString
v) -> (forall s. FoldCase s => s -> CI s
CI.mk ByteString
k, ByteString
v)) [(ByteString, ByteString)]
iamTok
          where merge :: [(a, ByteString)] -> [(a, ByteString)]
merge (x1 :: (a, ByteString)
x1@(a
k1,ByteString
v1):x2 :: (a, ByteString)
x2@(a
k2,ByteString
v2):[(a, ByteString)]
xs) | a
k1 forall a. Eq a => a -> a -> Bool
== a
k2  = [(a, ByteString)] -> [(a, ByteString)]
merge ((a
k1, ByteString -> [ByteString] -> ByteString
B8.intercalate ByteString
"," [ByteString
v1, ByteString
v2]) forall a. a -> [a] -> [a]
: [(a, ByteString)]
xs)
                                                 | Bool
otherwise = (a, ByteString)
x1 forall a. a -> [a] -> [a]
: [(a, ByteString)] -> [(a, ByteString)]
merge ((a, ByteString)
x2 forall a. a -> [a] -> [a]
: [(a, ByteString)]
xs)
                merge [(a, ByteString)]
xs = [(a, ByteString)]
xs

      urlEncodedS3QObject :: Maybe ByteString
urlEncodedS3QObject = Bool -> ByteString -> ByteString
s3UriEncode Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
s3QObject
      ([Maybe ByteString]
host, [Maybe ByteString]
path) = case RequestStyle
s3RequestStyle of
                       RequestStyle
PathStyle   -> ([forall a. a -> Maybe a
Just ByteString
s3Endpoint], [forall a. a -> Maybe a
Just ByteString
"/", forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Char -> ByteString
`B8.snoc` Char
'/') Maybe ByteString
s3QBucket, Maybe ByteString
urlEncodedS3QObject])
                       RequestStyle
BucketStyle -> ([Maybe ByteString
s3QBucket, forall a. a -> Maybe a
Just ByteString
s3Endpoint], [forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
                       RequestStyle
VHostStyle  -> ([forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
s3Endpoint Maybe ByteString
s3QBucket], [forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
      sortedSubresources :: Query
sortedSubresources = forall a. Ord a => [a] -> [a]
sort Query
s3QSubresources
      canonicalizedResource :: Builder
canonicalizedResource = Char -> Builder
Blaze8.fromChar Char
'/' forall a. Monoid a => a -> a -> a
`mappend`
                              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\ByteString
s -> ByteString -> Builder
Blaze.copyByteString ByteString
s forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
Blaze8.fromChar Char
'/') Maybe ByteString
s3QBucket forall a. Monoid a => a -> a -> a
`mappend`
                              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ByteString -> Builder
Blaze.copyByteString Maybe ByteString
urlEncodedS3QObject forall a. Monoid a => a -> a -> a
`mappend`
                              Query -> Builder
encodeQuerySign Query
sortedSubresources
      -- query parameters overriding response headers must not be URI encoded when calculating signature
      -- http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#ConstructingTheCanonicalizedResourceElement
      -- Note this is limited to amazon auth version 2 in the new auth version 4 this weird exception is not present
      encodeQuerySign :: Query -> Builder
encodeQuerySign Query
qs =
          let ceq :: Builder
ceq = Char -> Builder
Blaze8.fromChar Char
'='
              cqt :: Builder
cqt = Char -> Builder
Blaze8.fromChar Char
'?'
              camp :: Builder
camp = Char -> Builder
Blaze8.fromChar Char
'&'
              overrideParams :: [ByteString]
overrideParams = forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
B8.pack [String
"response-content-type", String
"response-content-language", String
"response-expires", String
"response-cache-control", String
"response-content-disposition", String
"response-content-encoding"]
              encItem :: (ByteString, Maybe ByteString) -> Builder
encItem (ByteString
k, Maybe ByteString
mv) =
                  let enc :: ByteString -> Builder
enc = if ByteString
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
overrideParams then ByteString -> Builder
Blaze.copyByteString else Bool -> ByteString -> Builder
HTTP.urlEncodeBuilder Bool
True
                  in  ByteString -> Builder
enc ByteString
k forall a. Monoid a => a -> a -> a
`mappend` forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall a. Monoid a => a -> a -> a
mappend Builder
ceq forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
enc) Maybe ByteString
mv
          in case forall a. a -> [a] -> [a]
intersperse Builder
camp (forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> Builder
encItem Query
qs) of
               [] -> forall a. Monoid a => a
mempty
               [Builder]
qs' -> forall a. Monoid a => [a] -> a
mconcat (Builder
cqt forall a. a -> [a] -> [a]
:[Builder]
qs')

      ti :: AbsoluteTimeInfo
ti = case (Bool
s3UseUri, AbsoluteTimeInfo
signatureTimeInfo) of
             (Bool
False, AbsoluteTimeInfo
ti') -> AbsoluteTimeInfo
ti'
             (Bool
True, AbsoluteTimestamp UTCTime
time) -> UTCTime -> AbsoluteTimeInfo
AbsoluteExpires forall a b. (a -> b) -> a -> b
$ NominalDiffTime
s3DefaultExpiry NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
time
             (Bool
True, AbsoluteExpires UTCTime
time) -> UTCTime -> AbsoluteTimeInfo
AbsoluteExpires UTCTime
time
      sig :: ByteString
sig = Credentials -> AuthorizationHash -> ByteString -> ByteString
signature Credentials
signatureCredentials AuthorizationHash
HmacSHA1 ByteString
stringToSign
      iamTok :: [(ByteString, ByteString)]
iamTok = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ByteString
x -> [(ByteString
"x-amz-security-token", ByteString
x)]) (Credentials -> Maybe ByteString
iamToken Credentials
signatureCredentials)
      stringToSign :: ByteString
stringToSign = Builder -> ByteString
Blaze.toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Char -> Builder
Blaze8.fromChar Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat  forall a b. (a -> b) -> a -> b
$
                       [[ByteString -> Builder
Blaze.copyByteString forall a b. (a -> b) -> a -> b
$ Method -> ByteString
httpMethod Method
s3QMethod]
                       , [forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (ByteString -> Builder
Blaze.copyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert) Maybe (Digest MD5)
s3QContentMd5]
                       , [forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ByteString -> Builder
Blaze.copyByteString Maybe ByteString
s3QContentType]
                       , [ByteString -> Builder
Blaze.copyByteString forall a b. (a -> b) -> a -> b
$ case AbsoluteTimeInfo
ti of
                                                   AbsoluteTimestamp UTCTime
time -> UTCTime -> ByteString
fmtRfc822Time UTCTime
time
                                                   AbsoluteExpires UTCTime
time -> UTCTime -> ByteString
fmtTimeEpochSeconds UTCTime
time]
                       , forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, ByteString) -> Builder
amzHeader RequestHeaders
amzHeaders
                       , [Builder
canonicalizedResource]
                       ]
          where amzHeader :: (HeaderName, ByteString) -> Builder
amzHeader (HeaderName
k, ByteString
v) = ByteString -> Builder
Blaze.copyByteString (forall s. CI s -> s
CI.foldedCase HeaderName
k) forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
Blaze8.fromChar Char
':' forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
Blaze.copyByteString ByteString
v
      (Maybe (IO ByteString)
authorization, Query
authQuery) = case AbsoluteTimeInfo
ti of
                                 AbsoluteTimestamp UTCTime
_
                                        | Bool
isanon -> (forall a. Maybe a
Nothing, [])
                                        | Bool
otherwise -> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
"AWS ", Credentials -> ByteString
accessKeyID Credentials
signatureCredentials, ByteString
":", ByteString
sig], [])
                                 AbsoluteExpires UTCTime
time -> (forall a. Maybe a
Nothing, forall a. QueryLike a => a -> Query
HTTP.toQuery forall a b. (a -> b) -> a -> b
$ UTCTime -> [(ByteString, ByteString)]
makeAuthQuery UTCTime
time)
      makeAuthQuery :: UTCTime -> [(ByteString, ByteString)]
makeAuthQuery UTCTime
time
        | Bool
isanon = []
        | Bool
otherwise = 
                [ (ByteString
"Expires" :: B8.ByteString, UTCTime -> ByteString
fmtTimeEpochSeconds UTCTime
time)
                , (ByteString
"AWSAccessKeyId", Credentials -> ByteString
accessKeyID Credentials
signatureCredentials)
                , (ByteString
"SignatureMethod", ByteString
"HmacSHA256")
                , (ByteString
"Signature", ByteString
sig)] forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
iamTok
s3SignQuery sq :: S3Query
sq@S3Query{Query
RequestHeaders
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
Method
s3QRequestBody :: Maybe RequestBody
s3QOtherHeaders :: RequestHeaders
s3QAmzHeaders :: RequestHeaders
s3QContentMd5 :: Maybe (Digest MD5)
s3QContentType :: Maybe ByteString
s3QQuery :: Query
s3QSubresources :: Query
s3QObject :: Maybe ByteString
s3QBucket :: Maybe ByteString
s3QMethod :: Method
s3QRequestBody :: S3Query -> Maybe RequestBody
s3QOtherHeaders :: S3Query -> RequestHeaders
s3QAmzHeaders :: S3Query -> RequestHeaders
s3QContentMd5 :: S3Query -> Maybe (Digest MD5)
s3QContentType :: S3Query -> Maybe ByteString
s3QQuery :: S3Query -> Query
s3QSubresources :: S3Query -> Query
s3QObject :: S3Query -> Maybe ByteString
s3QBucket :: S3Query -> Maybe ByteString
s3QMethod :: S3Query -> Method
..} sc :: S3Configuration qt
sc@S3Configuration{ s3SignVersion :: forall qt. S3Configuration qt -> S3SignVersion
s3SignVersion = S3SignV4 S3SignPayloadMode
signpayload, Bool
Int
Maybe ServerSideEncryption
ByteString
NominalDiffTime
Protocol
RequestStyle
s3DefaultExpiry :: NominalDiffTime
s3UseUri :: Bool
s3ServerSideEncryption :: Maybe ServerSideEncryption
s3Port :: Int
s3RequestStyle :: RequestStyle
s3Endpoint :: ByteString
s3Protocol :: Protocol
s3DefaultExpiry :: forall qt. S3Configuration qt -> NominalDiffTime
s3UseUri :: forall qt. S3Configuration qt -> Bool
s3ServerSideEncryption :: forall qt. S3Configuration qt -> Maybe ServerSideEncryption
s3Port :: forall qt. S3Configuration qt -> Int
s3RequestStyle :: forall qt. S3Configuration qt -> RequestStyle
s3Endpoint :: forall qt. S3Configuration qt -> ByteString
s3Protocol :: forall qt. S3Configuration qt -> Protocol
.. } sd :: SignatureData
sd@SignatureData{UTCTime
AbsoluteTimeInfo
Credentials
signatureCredentials :: Credentials
signatureTime :: UTCTime
signatureTimeInfo :: AbsoluteTimeInfo
signatureCredentials :: SignatureData -> Credentials
signatureTime :: SignatureData -> UTCTime
signatureTimeInfo :: SignatureData -> AbsoluteTimeInfo
..}
    | Credentials -> Bool
isAnonymousCredentials Credentials
signatureCredentials =
      forall qt.
S3Query -> S3Configuration qt -> SignatureData -> SignedQuery
s3SignQuery S3Query
sq (S3Configuration qt
sc { s3SignVersion :: S3SignVersion
s3SignVersion = S3SignVersion
S3SignV2 }) SignatureData
sd
    | Bool
otherwise = SignedQuery
      { sqMethod :: Method
sqMethod = Method
s3QMethod
      , sqProtocol :: Protocol
sqProtocol = Protocol
s3Protocol
      , sqHost :: ByteString
sqHost = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
host
      , sqPort :: Int
sqPort = Int
s3Port
      , sqPath :: ByteString
sqPath = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
path
      , sqQuery :: Query
sqQuery = Query
queryString forall a. [a] -> [a] -> [a]
++ Query
signatureQuery :: HTTP.Query
      , sqDate :: Maybe UTCTime
sqDate = forall a. a -> Maybe a
Just UTCTime
signatureTime
      , sqAuthorization :: Maybe (IO ByteString)
sqAuthorization = Maybe (IO ByteString)
authorization
      , sqContentType :: Maybe ByteString
sqContentType = Maybe ByteString
s3QContentType
      , sqContentMd5 :: Maybe (Digest MD5)
sqContentMd5 = Maybe (Digest MD5)
s3QContentMd5
      , sqAmzHeaders :: RequestHeaders
sqAmzHeaders = forall k a. Map k a -> [(k, a)]
Map.toList Map HeaderName ByteString
amzHeaders
      , sqOtherHeaders :: RequestHeaders
sqOtherHeaders = RequestHeaders
s3QOtherHeaders
      , sqBody :: Maybe RequestBody
sqBody = Maybe RequestBody
s3QRequestBody
      , sqStringToSign :: ByteString
sqStringToSign = ByteString
stringToSign
      }
    where
        -- V4 signing
        -- * <http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html>
        -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-auth-using-authorization-header.html>
        -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html>

        iamTok :: RequestHeaders
iamTok = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ByteString
x -> [(HeaderName
hAmzSecurityToken, ByteString
x)]) forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe ByteString
iamToken Credentials
signatureCredentials

        amzHeaders :: Map HeaderName ByteString
amzHeaders = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ (HeaderName
hAmzDate, ByteString
sigTime)forall a. a -> [a] -> [a]
:(HeaderName
hAmzContentSha256, ByteString
payloadHash)forall a. a -> [a] -> [a]
:RequestHeaders
iamTok forall a. [a] -> [a] -> [a]
++ RequestHeaders
s3QAmzHeaders
            where
                -- needs to match the one produces in the @authorizationV4@
                sigTime :: ByteString
sigTime = String -> UTCTime -> ByteString
fmtTime String
"%Y%m%dT%H%M%SZ" forall a b. (a -> b) -> a -> b
$ UTCTime
signatureTime
                payloadHash :: ByteString
payloadHash = case (S3SignPayloadMode
signpayload, Maybe RequestBody
s3QRequestBody) of
                    (S3SignPayloadMode
AlwaysUnsigned, Maybe RequestBody
_)                 -> ByteString
"UNSIGNED-PAYLOAD"
                    (S3SignPayloadMode
_, Maybe RequestBody
Nothing)                        -> ByteString
emptyBodyHash
                    (S3SignPayloadMode
_, Just (HTTP.RequestBodyLBS ByteString
lbs)) -> ByteString -> ByteString
Base16.encode forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall a. HashAlgorithm a => ByteString -> Digest a
CH.hashlazy ByteString
lbs :: CH.Digest CH.SHA256)
                    (S3SignPayloadMode
_, Just (HTTP.RequestBodyBS ByteString
bs))   -> ByteString -> ByteString
Base16.encode forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash ByteString
bs :: CH.Digest CH.SHA256)
                    (S3SignPayloadMode
SignWithEffort, Maybe RequestBody
_)                 -> ByteString
"UNSIGNED-PAYLOAD"
                    (S3SignPayloadMode
AlwaysSigned, Maybe RequestBody
_)                   -> forall a. HasCallStack => String -> a
error String
"aws: RequestBody must be a on-memory one when AlwaysSigned mode."
                emptyBodyHash :: ByteString
emptyBodyHash = ByteString
"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"

        ([Maybe ByteString]
host, [Maybe ByteString]
path) = case RequestStyle
s3RequestStyle of
            RequestStyle
PathStyle   -> ([forall a. a -> Maybe a
Just ByteString
s3Endpoint], [forall a. a -> Maybe a
Just ByteString
"/", forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Char -> ByteString
`B8.snoc` Char
'/') Maybe ByteString
s3QBucket, Maybe ByteString
urlEncodedS3QObject])
            RequestStyle
BucketStyle -> ([Maybe ByteString
s3QBucket, forall a. a -> Maybe a
Just ByteString
s3Endpoint], [forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
            RequestStyle
VHostStyle  -> ([forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
s3Endpoint Maybe ByteString
s3QBucket], [forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
            where
                urlEncodedS3QObject :: Maybe ByteString
urlEncodedS3QObject = Bool -> ByteString -> ByteString
s3UriEncode Bool
False forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
s3QObject

        -- must provide host in the canonical headers.
        canonicalHeaders :: Map HeaderName ByteString
canonicalHeaders = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map HeaderName ByteString
amzHeaders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
            [ forall a. a -> Maybe a
Just (HeaderName
"host", ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
host)
            , (HeaderName
"content-type",) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
s3QContentType
            ]
        signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
B8.intercalate ByteString
";" (forall a b. (a -> b) -> [a] -> [b]
map forall s. CI s -> s
CI.foldedCase forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map HeaderName ByteString
canonicalHeaders)
        stringToSign :: ByteString
stringToSign = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"\n" forall a b. (a -> b) -> a -> b
$
            [ Method -> ByteString
httpMethod Method
s3QMethod                   -- method
            , forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [Maybe ByteString]
path             -- path
            , Bool -> Query -> ByteString
s3RenderQuery Bool
False forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort Query
queryString -- query string
            ] forall a. [a] -> [a] -> [a]
++
            forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\HeaderName
a ByteString
b -> [forall s. CI s -> s
CI.foldedCase HeaderName
a forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
":" forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
b]) Map HeaderName ByteString
canonicalHeaders forall a. [a] -> [a] -> [a]
++
            [ ByteString
"" -- end headers
            , ByteString
signedHeaders
            , Map HeaderName ByteString
amzHeaders forall k a. Ord k => Map k a -> k -> a
Map.! HeaderName
hAmzContentSha256
            ]

        (Maybe (IO ByteString)
authorization, Query
signatureQuery, Query
queryString) = case AbsoluteTimeInfo
ti of
            AbsoluteTimestamp UTCTime
_  -> (forall a. a -> Maybe a
Just IO ByteString
auth, [], Query
allQueries)
            AbsoluteExpires UTCTime
time ->
                ( forall a. Maybe a
Nothing
                , [(forall s. CI s -> s
CI.original HeaderName
hAmzSignature, forall a. a -> Maybe a
Just ByteString
sig)]
                , (Query
allQueries forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QueryLike a => a -> Query
HTTP.toQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall s. CI s -> s
CI.original) forall a b. (a -> b) -> a -> b
$
                    [ (HeaderName
hAmzAlgorithm, ByteString
"AWS4-HMAC-SHA256")
                    , (HeaderName
hAmzCredential, ByteString
cred)
                    , (HeaderName
hAmzDate, Map HeaderName ByteString
amzHeaders forall k a. Ord k => Map k a -> k -> a
Map.! HeaderName
hAmzDate)
                    , (HeaderName
hAmzExpires, String -> ByteString
B8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Show a => a -> String
show :: Integer -> String) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
time UTCTime
signatureTime)
                    , (HeaderName
hAmzSignedHeaders, ByteString
signedHeaders)
                    ] forall a. [a] -> [a] -> [a]
++ RequestHeaders
iamTok
                )
            where
                allQueries :: Query
allQueries = Query
s3QSubresources forall a. [a] -> [a] -> [a]
++ Query
s3QQuery
                region :: ByteString
region = ByteString -> ByteString
s3ExtractRegion ByteString
s3Endpoint
                auth :: IO ByteString
auth = SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> IO ByteString
authorizationV4 SignatureData
sd AuthorizationHash
HmacSHA256 ByteString
region ByteString
"s3" ByteString
signedHeaders ByteString
stringToSign
                sig :: ByteString
sig  = SignatureData
-> AuthorizationHash
-> ByteString
-> ByteString
-> ByteString
-> ByteString
signatureV4     SignatureData
sd AuthorizationHash
HmacSHA256 ByteString
region ByteString
"s3"               ByteString
stringToSign
                cred :: ByteString
cred = SignatureData -> ByteString -> ByteString -> ByteString
credentialV4    SignatureData
sd            ByteString
region ByteString
"s3"
                ti :: AbsoluteTimeInfo
ti = case (Bool
s3UseUri, AbsoluteTimeInfo
signatureTimeInfo) of
                    (Bool
False, AbsoluteTimeInfo
t) -> AbsoluteTimeInfo
t
                    (Bool
True, AbsoluteTimestamp UTCTime
time) -> UTCTime -> AbsoluteTimeInfo
AbsoluteExpires forall a b. (a -> b) -> a -> b
$ NominalDiffTime
s3DefaultExpiry NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
time
                    (Bool
True, AbsoluteExpires UTCTime
time) -> UTCTime -> AbsoluteTimeInfo
AbsoluteExpires UTCTime
time

-- | Custom UriEncode function
-- see <http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html>
s3UriEncode
    :: Bool         -- ^ Whether encode slash characters
    -> B.ByteString
    -> B.ByteString
s3UriEncode :: Bool -> ByteString -> ByteString
s3UriEncode Bool
encodeSlash = (Char -> ByteString) -> ByteString -> ByteString
B8.concatMap forall a b. (a -> b) -> a -> b
$ \Char
c ->
    if (Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c) Bool -> Bool -> Bool
|| (Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
nonEncodeMarks)
        then Char -> ByteString
B8.singleton Char
c
        else String -> ByteString
B8.pack forall a b. (a -> b) -> a -> b
$ Char
'%' forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (forall a. (Integral a, Show a) => a -> ShowS
showHex (Char -> Int
ord Char
c) String
"")
    where
        nonEncodeMarks :: String
        nonEncodeMarks :: String
nonEncodeMarks = if Bool
encodeSlash
            then String
"_-~."
            else String
"_-~./"

s3RenderQuery
    :: Bool -- ^ Whether prepend a question mark
    -> HTTP.Query
    -> B.ByteString
s3RenderQuery :: Bool -> Query -> ByteString
s3RenderQuery Bool
qm = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
qmf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Char -> ByteString
B8.singleton Char
'&') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> ByteString
renderItem
    where
        qmf :: [ByteString] -> [ByteString]
qmf = if Bool
qm then (ByteString
"?"forall a. a -> [a] -> [a]
:) else forall a. a -> a
id

        renderItem :: HTTP.QueryItem -> B8.ByteString
        renderItem :: (ByteString, Maybe ByteString) -> ByteString
renderItem (ByteString
k, Just ByteString
v) = Bool -> ByteString -> ByteString
s3UriEncode Bool
True ByteString
k forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
"=" forall a. Semigroup a => a -> a -> a
Sem.<> Bool -> ByteString -> ByteString
s3UriEncode Bool
True ByteString
v
        renderItem (ByteString
k, Maybe ByteString
Nothing) = Bool -> ByteString -> ByteString
s3UriEncode Bool
True ByteString
k forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
"="

-- | see: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>
s3ExtractRegion :: B.ByteString -> B.ByteString
s3ExtractRegion :: ByteString -> ByteString
s3ExtractRegion ByteString
"s3.amazonaws.com"            = ByteString
"us-east-1"
s3ExtractRegion ByteString
"s3-external-1.amazonaws.com" = ByteString
"us-east-1"
s3ExtractRegion ByteString
domain = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const ByteString
domain) [Word8] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser ByteString [Word8]
parser ByteString
domain
    where
        -- s3.dualstack.<WA-DIR-N>.amazonaws.com
        -- s3-<WA-DIR-N>.amazonaws.com
        -- s3.<WA-DIR-N>.amazonaws.com
        parser :: Parser ByteString [Word8]
parser = do
            ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"s3"
            ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
".dualstack." forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
Atto.string ByteString
"-" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
Atto.string ByteString
"."
            [Word8]
r <- forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
Atto.manyTill Parser Word8
Atto.anyWord8 forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
Atto.string ByteString
".amazonaws.com"
            forall t. Chunk t => Parser t ()
Atto.endOfInput
            forall (m :: * -> *) a. Monad m => a -> m a
return [Word8]
r

s3ResponseConsumer :: HTTPResponseConsumer a
                         -> IORef S3Metadata
                         -> HTTPResponseConsumer a
s3ResponseConsumer :: forall a.
HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
s3ResponseConsumer HTTPResponseConsumer a
inner IORef S3Metadata
metadataRef = forall a.
HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
s3BinaryResponseConsumer HTTPResponseConsumer a
inner' IORef S3Metadata
metadataRef
  where inner' :: HTTPResponseConsumer a
inner' Response (ConduitM () ByteString (ResourceT IO) ())
resp =
          do
            !a
res <- HTTPResponseConsumer a
inner Response (ConduitM () ByteString (ResourceT IO) ())
resp
            forall (m :: * -> *) a. Monad m => a -> m a
return a
res

s3BinaryResponseConsumer :: HTTPResponseConsumer a
                   -> IORef S3Metadata
                   -> HTTPResponseConsumer a
s3BinaryResponseConsumer :: forall a.
HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
s3BinaryResponseConsumer HTTPResponseConsumer a
inner IORef S3Metadata
metadata Response (ConduitM () ByteString (ResourceT IO) ())
resp = do
      let headerString :: HeaderName -> Maybe LocationConstraint
headerString = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> LocationConstraint
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response (ConduitM () ByteString (ResourceT IO) ())
resp)
      let amzId2 :: Maybe LocationConstraint
amzId2 = HeaderName -> Maybe LocationConstraint
headerString HeaderName
"x-amz-id-2"
      let requestId :: Maybe LocationConstraint
requestId = HeaderName -> Maybe LocationConstraint
headerString HeaderName
"x-amz-request-id"

      let m :: S3Metadata
m = S3Metadata { s3MAmzId2 :: Maybe LocationConstraint
s3MAmzId2 = Maybe LocationConstraint
amzId2, s3MRequestId :: Maybe LocationConstraint
s3MRequestId = Maybe LocationConstraint
requestId }
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall m. Monoid m => IORef m -> m -> IO ()
tellMetadataRef IORef S3Metadata
metadata S3Metadata
m

      if forall body. Response body -> Status
HTTP.responseStatus Response (ConduitM () ByteString (ResourceT IO) ())
resp forall a. Ord a => a -> a -> Bool
>= Status
HTTP.status300
        then forall a. HTTPResponseConsumer a
s3ErrorResponseConsumer Response (ConduitM () ByteString (ResourceT IO) ())
resp
        else HTTPResponseConsumer a
inner Response (ConduitM () ByteString (ResourceT IO) ())
resp

s3XmlResponseConsumer :: (Cu.Cursor -> Response S3Metadata a)
                      -> IORef S3Metadata
                      -> HTTPResponseConsumer a
s3XmlResponseConsumer :: forall a.
(Cursor -> Response S3Metadata a)
-> IORef S3Metadata -> HTTPResponseConsumer a
s3XmlResponseConsumer Cursor -> Response S3Metadata a
parse IORef S3Metadata
metadataRef =
    forall a.
HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
s3ResponseConsumer (forall m a.
Monoid m =>
(Cursor -> Response m a) -> IORef m -> HTTPResponseConsumer a
xmlCursorConsumer Cursor -> Response S3Metadata a
parse IORef S3Metadata
metadataRef) IORef S3Metadata
metadataRef

s3ErrorResponseConsumer :: HTTPResponseConsumer a
s3ErrorResponseConsumer :: forall a. HTTPResponseConsumer a
s3ErrorResponseConsumer Response (ConduitM () ByteString (ResourceT IO) ())
resp
    = do Document
doc <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
C.runConduit forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
HTTP.responseBody Response (ConduitM () ByteString (ResourceT IO) ())
resp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT ByteString o m Document
XML.sinkDoc forall a. Default a => a
XML.def
         let cursor :: Cursor
cursor = Document -> Cursor
Cu.fromDocument Document
doc
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Cursor -> Either SomeException S3Error
parseError Cursor
cursor of
           Right S3Error
err      -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM S3Error
err
           Left SomeException
otherErr  -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
otherErr
    where
      parseError :: Cu.Cursor -> Either C.SomeException S3Error
      parseError :: Cursor -> Either SomeException S3Error
parseError Cursor
root = do LocationConstraint
code <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing error Code" forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Code"
                           LocationConstraint
message <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing error Message" forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Message"
                           let resource :: Maybe LocationConstraint
resource = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Resource"
                               hostId :: Maybe LocationConstraint
hostId = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"HostId"
                               accessKeyId :: Maybe LocationConstraint
accessKeyId = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"AWSAccessKeyId"
                               bucket :: Maybe LocationConstraint
bucket = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Bucket"
                               endpointRaw :: Maybe LocationConstraint
endpointRaw = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Endpoint"
                               endpoint :: Maybe ByteString
endpoint = LocationConstraint -> ByteString
T.encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LocationConstraint
-> LocationConstraint -> Maybe LocationConstraint
T.stripPrefix (forall a. a -> Maybe a -> a
fromMaybe LocationConstraint
"" Maybe LocationConstraint
bucket forall a. Semigroup a => a -> a -> a
Sem.<> LocationConstraint
".") forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe LocationConstraint
endpointRaw)
                               stringToSign :: Maybe ByteString
stringToSign = do String
unprocessed <- forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Cursor
root forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [String]
elCont LocationConstraint
"StringToSignBytes"
                                                 [Word8]
bytes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Maybe Word8
readHex2 forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
unprocessed
                                                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
B.pack [Word8]
bytes
                           forall (m :: * -> *) a. Monad m => a -> m a
return S3Error {
                                        s3StatusCode :: Status
s3StatusCode = forall body. Response body -> Status
HTTP.responseStatus Response (ConduitM () ByteString (ResourceT IO) ())
resp
                                      , s3ErrorCode :: LocationConstraint
s3ErrorCode = LocationConstraint
code
                                      , s3ErrorMessage :: LocationConstraint
s3ErrorMessage = LocationConstraint
message
                                      , s3ErrorResource :: Maybe LocationConstraint
s3ErrorResource = Maybe LocationConstraint
resource
                                      , s3ErrorHostId :: Maybe LocationConstraint
s3ErrorHostId = Maybe LocationConstraint
hostId
                                      , s3ErrorAccessKeyId :: Maybe LocationConstraint
s3ErrorAccessKeyId = Maybe LocationConstraint
accessKeyId
                                      , s3ErrorStringToSign :: Maybe ByteString
s3ErrorStringToSign = Maybe ByteString
stringToSign
                                      , s3ErrorBucket :: Maybe LocationConstraint
s3ErrorBucket = Maybe LocationConstraint
bucket
                                      , s3ErrorEndpointRaw :: Maybe LocationConstraint
s3ErrorEndpointRaw = Maybe LocationConstraint
endpointRaw
                                      , s3ErrorEndpoint :: Maybe ByteString
s3ErrorEndpoint = Maybe ByteString
endpoint
                                      }

type CanonicalUserId = T.Text

data UserInfo
    = UserInfo {
        UserInfo -> LocationConstraint
userId          :: CanonicalUserId
      , UserInfo -> Maybe LocationConstraint
userDisplayName :: Maybe T.Text
      }
    deriving (Int -> UserInfo -> ShowS
[UserInfo] -> ShowS
UserInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserInfo] -> ShowS
$cshowList :: [UserInfo] -> ShowS
show :: UserInfo -> String
$cshow :: UserInfo -> String
showsPrec :: Int -> UserInfo -> ShowS
$cshowsPrec :: Int -> UserInfo -> ShowS
Show)

parseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo
parseUserInfo :: forall (m :: * -> *). MonadThrow m => Cursor -> m UserInfo
parseUserInfo Cursor
el = do LocationConstraint
id_ <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing user ID" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"ID"
                      Maybe LocationConstraint
displayName <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"DisplayName") of
                                                  (LocationConstraint
x:[LocationConstraint]
_) -> forall a. a -> Maybe a
Just LocationConstraint
x
                                                  []    -> forall a. Maybe a
Nothing
                      forall (m :: * -> *) a. Monad m => a -> m a
return UserInfo { userId :: LocationConstraint
userId = LocationConstraint
id_, userDisplayName :: Maybe LocationConstraint
userDisplayName = Maybe LocationConstraint
displayName }

data CannedAcl
    = AclPrivate
    | AclPublicRead
    | AclPublicReadWrite
    | AclAuthenticatedRead
    | AclBucketOwnerRead
    | AclBucketOwnerFullControl
    | AclLogDeliveryWrite
    deriving (Int -> CannedAcl -> ShowS
[CannedAcl] -> ShowS
CannedAcl -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CannedAcl] -> ShowS
$cshowList :: [CannedAcl] -> ShowS
show :: CannedAcl -> String
$cshow :: CannedAcl -> String
showsPrec :: Int -> CannedAcl -> ShowS
$cshowsPrec :: Int -> CannedAcl -> ShowS
Show)

writeCannedAcl :: CannedAcl -> T.Text
writeCannedAcl :: CannedAcl -> LocationConstraint
writeCannedAcl CannedAcl
AclPrivate                = LocationConstraint
"private"
writeCannedAcl CannedAcl
AclPublicRead             = LocationConstraint
"public-read"
writeCannedAcl CannedAcl
AclPublicReadWrite        = LocationConstraint
"public-read-write"
writeCannedAcl CannedAcl
AclAuthenticatedRead      = LocationConstraint
"authenticated-read"
writeCannedAcl CannedAcl
AclBucketOwnerRead        = LocationConstraint
"bucket-owner-read"
writeCannedAcl CannedAcl
AclBucketOwnerFullControl = LocationConstraint
"bucket-owner-full-control"
writeCannedAcl CannedAcl
AclLogDeliveryWrite       = LocationConstraint
"log-delivery-write"

data StorageClass
    = Standard
    | StandardInfrequentAccess
    | ReducedRedundancy
    | Glacier
    | OtherStorageClass T.Text
    deriving (Int -> StorageClass -> ShowS
[StorageClass] -> ShowS
StorageClass -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorageClass] -> ShowS
$cshowList :: [StorageClass] -> ShowS
show :: StorageClass -> String
$cshow :: StorageClass -> String
showsPrec :: Int -> StorageClass -> ShowS
$cshowsPrec :: Int -> StorageClass -> ShowS
Show)

parseStorageClass :: T.Text -> StorageClass
parseStorageClass :: LocationConstraint -> StorageClass
parseStorageClass LocationConstraint
"STANDARD"           = StorageClass
Standard
parseStorageClass LocationConstraint
"STANDARD_IA"        = StorageClass
StandardInfrequentAccess
parseStorageClass LocationConstraint
"REDUCED_REDUNDANCY" = StorageClass
ReducedRedundancy
parseStorageClass LocationConstraint
"GLACIER"            = StorageClass
Glacier
parseStorageClass LocationConstraint
s                    = LocationConstraint -> StorageClass
OtherStorageClass LocationConstraint
s

writeStorageClass :: StorageClass -> T.Text
writeStorageClass :: StorageClass -> LocationConstraint
writeStorageClass StorageClass
Standard                 = LocationConstraint
"STANDARD"
writeStorageClass StorageClass
StandardInfrequentAccess = LocationConstraint
"STANDARD_IA"
writeStorageClass StorageClass
ReducedRedundancy        = LocationConstraint
"REDUCED_REDUNDANCY"
writeStorageClass StorageClass
Glacier                  = LocationConstraint
"GLACIER"
writeStorageClass (OtherStorageClass LocationConstraint
s) = LocationConstraint
s

data ServerSideEncryption
    = AES256
    deriving (Int -> ServerSideEncryption -> ShowS
[ServerSideEncryption] -> ShowS
ServerSideEncryption -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerSideEncryption] -> ShowS
$cshowList :: [ServerSideEncryption] -> ShowS
show :: ServerSideEncryption -> String
$cshow :: ServerSideEncryption -> String
showsPrec :: Int -> ServerSideEncryption -> ShowS
$cshowsPrec :: Int -> ServerSideEncryption -> ShowS
Show)

parseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption
parseServerSideEncryption :: forall (m :: * -> *).
MonadThrow m =>
LocationConstraint -> m ServerSideEncryption
parseServerSideEncryption LocationConstraint
"AES256" = forall (m :: * -> *) a. Monad m => a -> m a
return ServerSideEncryption
AES256
parseServerSideEncryption LocationConstraint
s = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> XmlException
XmlException forall a b. (a -> b) -> a -> b
$ String
"Invalid Server Side Encryption: " forall a. [a] -> [a] -> [a]
++ LocationConstraint -> String
T.unpack LocationConstraint
s

writeServerSideEncryption :: ServerSideEncryption -> T.Text
writeServerSideEncryption :: ServerSideEncryption -> LocationConstraint
writeServerSideEncryption ServerSideEncryption
AES256 = LocationConstraint
"AES256"

type Bucket = T.Text

data BucketInfo
    = BucketInfo {
        BucketInfo -> LocationConstraint
bucketName         :: Bucket
      , BucketInfo -> UTCTime
bucketCreationDate :: UTCTime
      }
    deriving (Int -> BucketInfo -> ShowS
[BucketInfo] -> ShowS
BucketInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BucketInfo] -> ShowS
$cshowList :: [BucketInfo] -> ShowS
show :: BucketInfo -> String
$cshow :: BucketInfo -> String
showsPrec :: Int -> BucketInfo -> ShowS
$cshowsPrec :: Int -> BucketInfo -> ShowS
Show)

type Object = T.Text

data ObjectId
    = ObjectId {
        ObjectId -> LocationConstraint
oidBucket :: Bucket
      , ObjectId -> LocationConstraint
oidObject :: Object
      , ObjectId -> Maybe LocationConstraint
oidVersion :: Maybe T.Text
      }
    deriving (Int -> ObjectId -> ShowS
[ObjectId] -> ShowS
ObjectId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectId] -> ShowS
$cshowList :: [ObjectId] -> ShowS
show :: ObjectId -> String
$cshow :: ObjectId -> String
showsPrec :: Int -> ObjectId -> ShowS
$cshowsPrec :: Int -> ObjectId -> ShowS
Show)

data ObjectVersionInfo
    = ObjectVersion {
        ObjectVersionInfo -> LocationConstraint
oviKey          :: T.Text
      , ObjectVersionInfo -> LocationConstraint
oviVersionId    :: T.Text
      , ObjectVersionInfo -> Bool
oviIsLatest     :: Bool
      , ObjectVersionInfo -> UTCTime
oviLastModified :: UTCTime
      , ObjectVersionInfo -> LocationConstraint
oviETag         :: T.Text
      , ObjectVersionInfo -> Integer
oviSize         :: Integer
      , ObjectVersionInfo -> StorageClass
oviStorageClass :: StorageClass
      , ObjectVersionInfo -> Maybe UserInfo
oviOwner        :: Maybe UserInfo
      }
    | DeleteMarker {
        oviKey          :: T.Text
      , oviVersionId    :: T.Text
      , oviIsLatest     :: Bool
      , oviLastModified :: UTCTime
      , oviOwner        :: Maybe UserInfo
      }
    deriving (Int -> ObjectVersionInfo -> ShowS
[ObjectVersionInfo] -> ShowS
ObjectVersionInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectVersionInfo] -> ShowS
$cshowList :: [ObjectVersionInfo] -> ShowS
show :: ObjectVersionInfo -> String
$cshow :: ObjectVersionInfo -> String
showsPrec :: Int -> ObjectVersionInfo -> ShowS
$cshowsPrec :: Int -> ObjectVersionInfo -> ShowS
Show)

parseObjectVersionInfo :: MonadThrow m => Cu.Cursor -> m ObjectVersionInfo
parseObjectVersionInfo :: forall (m :: * -> *). MonadThrow m => Cursor -> m ObjectVersionInfo
parseObjectVersionInfo Cursor
el
    = do LocationConstraint
key <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object Key" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Key"
         LocationConstraint
versionId <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object VersionId" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"VersionId"
         Bool
isLatest <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object IsLatest" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"IsLatest" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *). MonadThrow m => LocationConstraint -> m Bool
textReadBool
         let time :: LocationConstraint -> m a
time LocationConstraint
s = case (forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%QZ" forall a b. (a -> b) -> a -> b
$ LocationConstraint -> String
T.unpack LocationConstraint
s) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           (forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%Q%Z" forall a b. (a -> b) -> a -> b
$ LocationConstraint -> String
T.unpack LocationConstraint
s) of
                        Maybe a
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid time"
                        Just a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
         UTCTime
lastModified <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object LastModified" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"LastModified" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall {a} {m :: * -> *}.
(ParseTime a, MonadThrow m) =>
LocationConstraint -> m a
time
         Maybe UserInfo
owner <- case Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Axis
Cu.laxElement LocationConstraint
"Owner" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *). MonadThrow m => Cursor -> m UserInfo
parseUserInfo of
                    (m UserInfo
x:[m UserInfo]
_) -> forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' forall a. a -> Maybe a
Just m UserInfo
x
                    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
         case forall node. Cursor node -> node
Cu.node Cursor
el of
           XML.NodeElement Element
e | Element -> LocationConstraint
elName Element
e forall a. Eq a => a -> a -> Bool
== LocationConstraint
"Version" ->
             do LocationConstraint
eTag <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object ETag" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"ETag"
                Integer
size <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object Size" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Size" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *) a.
(MonadThrow m, Num a) =>
LocationConstraint -> m a
textReadInt
                StorageClass
storageClass <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object StorageClass" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"StorageClass" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocationConstraint -> StorageClass
parseStorageClass
                forall (m :: * -> *) a. Monad m => a -> m a
return ObjectVersion{
                             oviKey :: LocationConstraint
oviKey          = LocationConstraint
key
                           , oviVersionId :: LocationConstraint
oviVersionId    = LocationConstraint
versionId
                           , oviIsLatest :: Bool
oviIsLatest     = Bool
isLatest
                           , oviLastModified :: UTCTime
oviLastModified = UTCTime
lastModified
                           , oviETag :: LocationConstraint
oviETag         = LocationConstraint
eTag
                           , oviSize :: Integer
oviSize         = Integer
size
                           , oviStorageClass :: StorageClass
oviStorageClass = StorageClass
storageClass
                           , oviOwner :: Maybe UserInfo
oviOwner        = Maybe UserInfo
owner
                           }
           XML.NodeElement Element
e | Element -> LocationConstraint
elName Element
e forall a. Eq a => a -> a -> Bool
== LocationConstraint
"DeleteMarker" ->
             forall (m :: * -> *) a. Monad m => a -> m a
return DeleteMarker{
                             oviKey :: LocationConstraint
oviKey          = LocationConstraint
key
                           , oviVersionId :: LocationConstraint
oviVersionId    = LocationConstraint
versionId
                           , oviIsLatest :: Bool
oviIsLatest     = Bool
isLatest
                           , oviLastModified :: UTCTime
oviLastModified = UTCTime
lastModified
                           , oviOwner :: Maybe UserInfo
oviOwner        = Maybe UserInfo
owner
                           }
           Node
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid object version tag"
    where
      elName :: Element -> LocationConstraint
elName = Name -> LocationConstraint
XML.nameLocalName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
XML.elementName
      fmap' :: Monad m => (a -> b) -> m a -> m b
      fmap' :: forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' a -> b
f m a
ma = m a
ma forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

data ObjectInfo
    = ObjectInfo {
        ObjectInfo -> LocationConstraint
objectKey          :: T.Text
      , ObjectInfo -> UTCTime
objectLastModified :: UTCTime
      , ObjectInfo -> LocationConstraint
objectETag         :: T.Text
      , ObjectInfo -> Integer
objectSize         :: Integer
      , ObjectInfo -> StorageClass
objectStorageClass :: StorageClass
      , ObjectInfo -> Maybe UserInfo
objectOwner        :: Maybe UserInfo
      }
    deriving (Int -> ObjectInfo -> ShowS
[ObjectInfo] -> ShowS
ObjectInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectInfo] -> ShowS
$cshowList :: [ObjectInfo] -> ShowS
show :: ObjectInfo -> String
$cshow :: ObjectInfo -> String
showsPrec :: Int -> ObjectInfo -> ShowS
$cshowsPrec :: Int -> ObjectInfo -> ShowS
Show)

parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo
parseObjectInfo :: forall (m :: * -> *). MonadThrow m => Cursor -> m ObjectInfo
parseObjectInfo Cursor
el
    = do LocationConstraint
key <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object Key" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Key"
         let time :: LocationConstraint -> m a
time LocationConstraint
s = case (forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%QZ" forall a b. (a -> b) -> a -> b
$ LocationConstraint -> String
T.unpack LocationConstraint
s) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           (forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%Q%Z" forall a b. (a -> b) -> a -> b
$ LocationConstraint -> String
T.unpack LocationConstraint
s) of
                        Maybe a
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid time"
                        Just a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v
         UTCTime
lastModified <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object LastModified" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"LastModified" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall {a} {m :: * -> *}.
(ParseTime a, MonadThrow m) =>
LocationConstraint -> m a
time
         LocationConstraint
eTag <- forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object ETag" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"ETag"
         Integer
size <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object Size" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Size" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *) a.
(MonadThrow m, Num a) =>
LocationConstraint -> m a
textReadInt
         StorageClass
storageClass <- forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object StorageClass" forall a b. (a -> b) -> a -> b
$ Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"StorageClass" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocationConstraint -> StorageClass
parseStorageClass
         Maybe UserInfo
owner <- case Cursor
el forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Axis
Cu.laxElement LocationConstraint
"Owner" forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| forall (m :: * -> *). MonadThrow m => Cursor -> m UserInfo
parseUserInfo of
                    (m UserInfo
x:[m UserInfo]
_) -> forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' forall a. a -> Maybe a
Just m UserInfo
x
                    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
         forall (m :: * -> *) a. Monad m => a -> m a
return ObjectInfo{
                      objectKey :: LocationConstraint
objectKey          = LocationConstraint
key
                    , objectLastModified :: UTCTime
objectLastModified = UTCTime
lastModified
                    , objectETag :: LocationConstraint
objectETag         = LocationConstraint
eTag
                    , objectSize :: Integer
objectSize         = Integer
size
                    , objectStorageClass :: StorageClass
objectStorageClass = StorageClass
storageClass
                    , objectOwner :: Maybe UserInfo
objectOwner        = Maybe UserInfo
owner
                    }
    where
      fmap' :: Monad m => (a -> b) -> m a -> m b
      fmap' :: forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' a -> b
f m a
ma = m a
ma forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

data ObjectMetadata
    = ObjectMetadata {
        ObjectMetadata -> Bool
omDeleteMarker         :: Bool
      , ObjectMetadata -> LocationConstraint
omETag                 :: T.Text
      , ObjectMetadata -> UTCTime
omLastModified         :: UTCTime
      , ObjectMetadata -> Maybe LocationConstraint
omVersionId            :: Maybe T.Text
-- TODO:
--      , omExpiration           :: Maybe (UTCTime, T.Text)
      , ObjectMetadata -> [(LocationConstraint, LocationConstraint)]
omUserMetadata         :: [(T.Text, T.Text)]
      , ObjectMetadata -> Maybe LocationConstraint
omMissingUserMetadata  :: Maybe T.Text
      , ObjectMetadata -> Maybe ServerSideEncryption
omServerSideEncryption :: Maybe ServerSideEncryption
      }
    deriving (Int -> ObjectMetadata -> ShowS
[ObjectMetadata] -> ShowS
ObjectMetadata -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectMetadata] -> ShowS
$cshowList :: [ObjectMetadata] -> ShowS
show :: ObjectMetadata -> String
$cshow :: ObjectMetadata -> String
showsPrec :: Int -> ObjectMetadata -> ShowS
$cshowsPrec :: Int -> ObjectMetadata -> ShowS
Show)

parseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata
parseObjectMetadata :: forall (m :: * -> *).
MonadThrow m =>
RequestHeaders -> m ObjectMetadata
parseObjectMetadata RequestHeaders
h = Bool
-> LocationConstraint
-> UTCTime
-> Maybe LocationConstraint
-> [(LocationConstraint, LocationConstraint)]
-> Maybe LocationConstraint
-> Maybe ServerSideEncryption
-> ObjectMetadata
ObjectMetadata
                        forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
`liftM` m Bool
deleteMarker
                        forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m LocationConstraint
etag
                        forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m UTCTime
lastModified
                        forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocationConstraint
versionId
--                        `ap` expiration
                        forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall (m :: * -> *) a. Monad m => a -> m a
return [(LocationConstraint, LocationConstraint)]
userMetadata
                        forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocationConstraint
missingUserMetadata
                        forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m (Maybe ServerSideEncryption)
serverSideEncryption
  where deleteMarker :: m Bool
deleteMarker = case ByteString -> String
B8.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-delete-marker" RequestHeaders
h of
                         Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         Just String
"true" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         Just String
"false" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         Just String
x -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException (String
"Invalid x-amz-delete-marker " forall a. [a] -> [a] -> [a]
++ String
x)
        etag :: m LocationConstraint
etag = case ByteString -> LocationConstraint
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"ETag" RequestHeaders
h of
                 Just LocationConstraint
x -> forall (m :: * -> *) a. Monad m => a -> m a
return LocationConstraint
x
                 Maybe LocationConstraint
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException String
"ETag missing"
        lastModified :: m UTCTime
lastModified = case ByteString -> String
B8.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Last-Modified" RequestHeaders
h of
                         Just String
ts -> case String -> Maybe UTCTime
parseHttpDate String
ts of
                                      Just UTCTime
t -> forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
                                      Maybe UTCTime
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException (String
"Invalid Last-Modified: " forall a. [a] -> [a] -> [a]
++ String
ts)
                         Maybe String
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException String
"Last-Modified missing"
        versionId :: Maybe LocationConstraint
versionId = ByteString -> LocationConstraint
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-version-id" RequestHeaders
h
        -- expiration = return undefined
        userMetadata :: [(LocationConstraint, LocationConstraint)]
userMetadata = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(LocationConstraint, LocationConstraint)]
ht forall a b. (a -> b) -> a -> b
$
                       \(LocationConstraint
k, LocationConstraint
v) -> do LocationConstraint
i <- LocationConstraint
-> LocationConstraint -> Maybe LocationConstraint
T.stripPrefix LocationConstraint
"x-amz-meta-" LocationConstraint
k
                                     forall (m :: * -> *) a. Monad m => a -> m a
return (LocationConstraint
i, LocationConstraint
v)
        missingUserMetadata :: Maybe LocationConstraint
missingUserMetadata = ByteString -> LocationConstraint
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-missing-meta" RequestHeaders
h
        serverSideEncryption :: m (Maybe ServerSideEncryption)
serverSideEncryption = case ByteString -> LocationConstraint
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-server-side-encryption" RequestHeaders
h of
                                 Just LocationConstraint
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
LocationConstraint -> m ServerSideEncryption
parseServerSideEncryption LocationConstraint
x
                                 Maybe LocationConstraint
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        ht :: [(LocationConstraint, LocationConstraint)]
ht = forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> LocationConstraint
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
CI.foldedCase) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> LocationConstraint
T.decodeUtf8) RequestHeaders
h

type LocationConstraint = T.Text

locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuWest2, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint
locationUsClassic :: LocationConstraint
locationUsClassic = LocationConstraint
""
locationUsWest :: LocationConstraint
locationUsWest = LocationConstraint
"us-west-1"
locationUsWest2 :: LocationConstraint
locationUsWest2 = LocationConstraint
"us-west-2"
locationEu :: LocationConstraint
locationEu = LocationConstraint
"EU"
locationEuWest2 :: LocationConstraint
locationEuWest2 = LocationConstraint
"eu-west-2"
locationEuFrankfurt :: LocationConstraint
locationEuFrankfurt = LocationConstraint
"eu-central-1"
locationApSouthEast :: LocationConstraint
locationApSouthEast = LocationConstraint
"ap-southeast-1"
locationApSouthEast2 :: LocationConstraint
locationApSouthEast2 = LocationConstraint
"ap-southeast-2"
locationApNorthEast :: LocationConstraint
locationApNorthEast = LocationConstraint
"ap-northeast-1"
locationSA :: LocationConstraint
locationSA = LocationConstraint
"sa-east-1"

normaliseLocation :: LocationConstraint -> LocationConstraint
normaliseLocation :: LocationConstraint -> LocationConstraint
normaliseLocation LocationConstraint
location
  | LocationConstraint
location forall a. Eq a => a -> a -> Bool
== LocationConstraint
"eu-west-1" = LocationConstraint
locationEu
  | Bool
otherwise = LocationConstraint
location