{-# 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
(Int -> S3Authorization -> ShowS)
-> (S3Authorization -> String)
-> ([S3Authorization] -> ShowS)
-> Show S3Authorization
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
(Int -> RequestStyle -> ShowS)
-> (RequestStyle -> String)
-> ([RequestStyle] -> ShowS)
-> Show RequestStyle
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
(S3SignPayloadMode -> S3SignPayloadMode -> Bool)
-> (S3SignPayloadMode -> S3SignPayloadMode -> Bool)
-> Eq S3SignPayloadMode
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
(Int -> S3SignPayloadMode -> ShowS)
-> (S3SignPayloadMode -> String)
-> ([S3SignPayloadMode] -> ShowS)
-> Show S3SignPayloadMode
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]
(Int -> ReadS S3SignPayloadMode)
-> ReadS [S3SignPayloadMode]
-> ReadPrec S3SignPayloadMode
-> ReadPrec [S3SignPayloadMode]
-> Read 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
(S3SignVersion -> S3SignVersion -> Bool)
-> (S3SignVersion -> S3SignVersion -> Bool) -> Eq S3SignVersion
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
(Int -> S3SignVersion -> ShowS)
-> (S3SignVersion -> String)
-> ([S3SignVersion] -> ShowS)
-> Show S3SignVersion
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]
(Int -> ReadS S3SignVersion)
-> ReadS [S3SignVersion]
-> ReadPrec S3SignVersion
-> ReadPrec [S3SignVersion]
-> Read 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 {
        S3Configuration qt -> Protocol
s3Protocol :: Protocol
      , S3Configuration qt -> ByteString
s3Endpoint :: B.ByteString
      , S3Configuration qt -> RequestStyle
s3RequestStyle :: RequestStyle
      , S3Configuration qt -> Int
s3Port :: Int
      , S3Configuration qt -> Maybe ServerSideEncryption
s3ServerSideEncryption :: Maybe ServerSideEncryption
      , S3Configuration qt -> Bool
s3UseUri :: Bool
      , S3Configuration qt -> NominalDiffTime
s3DefaultExpiry :: NominalDiffTime
      , S3Configuration qt -> S3SignVersion
s3SignVersion :: S3SignVersion
      }
    deriving (Int -> S3Configuration qt -> ShowS
[S3Configuration qt] -> ShowS
S3Configuration qt -> String
(Int -> S3Configuration qt -> ShowS)
-> (S3Configuration qt -> String)
-> ([S3Configuration qt] -> ShowS)
-> Show (S3Configuration qt)
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 = Protocol -> ByteString -> Bool -> S3Configuration NormalQuery
forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
HTTPS ByteString
s3EndpointUsClassic Bool
False

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

instance DefaultServiceConfiguration (S3Configuration UriOnlyQuery) where
  defServiceConfig :: S3Configuration UriOnlyQuery
defServiceConfig = Protocol -> ByteString -> Bool -> S3Configuration UriOnlyQuery
forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
HTTPS ByteString
s3EndpointUsClassic Bool
True
  debugServiceConfig :: S3Configuration UriOnlyQuery
debugServiceConfig = Protocol -> ByteString -> Bool -> S3Configuration UriOnlyQuery
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 :: Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
protocol ByteString
endpoint Bool
uri
    = S3Configuration :: forall qt.
Protocol
-> ByteString
-> RequestStyle
-> Int
-> Maybe ServerSideEncryption
-> Bool
-> NominalDiffTime
-> S3SignVersion
-> S3Configuration qt
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 = Maybe ServerSideEncryption
forall a. Maybe a
Nothing
       , s3UseUri :: Bool
s3UseUri = Bool
uri
       , s3DefaultExpiry :: NominalDiffTime
s3DefaultExpiry = NominalDiffTime
15NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60
       , s3SignVersion :: S3SignVersion
s3SignVersion = S3SignVersion
S3SignV2
       }

s3v4 :: Protocol -> B.ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt
s3v4 :: Protocol
-> ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt
s3v4 Protocol
protocol ByteString
endpoint Bool
uri S3SignPayloadMode
payload
    = S3Configuration :: forall qt.
Protocol
-> ByteString
-> RequestStyle
-> Int
-> Maybe ServerSideEncryption
-> Bool
-> NominalDiffTime
-> S3SignVersion
-> S3Configuration qt
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 = Maybe ServerSideEncryption
forall a. Maybe a
Nothing
    , s3UseUri :: Bool
s3UseUri = Bool
uri
    , s3DefaultExpiry :: NominalDiffTime
s3DefaultExpiry = NominalDiffTime
15NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall 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 -> ErrorCode
s3ErrorCode :: ErrorCode -- Error/Code
      , S3Error -> ErrorCode
s3ErrorMessage :: T.Text -- Error/Message
      , S3Error -> Maybe ErrorCode
s3ErrorResource :: Maybe T.Text -- Error/Resource
      , S3Error -> Maybe ErrorCode
s3ErrorHostId :: Maybe T.Text -- Error/HostId
      , S3Error -> Maybe ErrorCode
s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId
      , S3Error -> Maybe ByteString
s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding)
      , S3Error -> Maybe ErrorCode
s3ErrorBucket :: Maybe T.Text -- Error/Bucket
      , S3Error -> Maybe ErrorCode
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
(Int -> S3Error -> ShowS)
-> (S3Error -> String) -> ([S3Error] -> ShowS) -> Show S3Error
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 ErrorCode
s3MAmzId2 :: Maybe T.Text
      , S3Metadata -> Maybe ErrorCode
s3MRequestId :: Maybe T.Text
      }
    deriving (Int -> S3Metadata -> ShowS
[S3Metadata] -> ShowS
S3Metadata -> String
(Int -> S3Metadata -> ShowS)
-> (S3Metadata -> String)
-> ([S3Metadata] -> ShowS)
-> Show S3Metadata
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 ErrorCode
a1 Maybe ErrorCode
r1 <> :: S3Metadata -> S3Metadata -> S3Metadata
<> S3Metadata Maybe ErrorCode
a2 Maybe ErrorCode
r2 = Maybe ErrorCode -> Maybe ErrorCode -> S3Metadata
S3Metadata (Maybe ErrorCode
a1 Maybe ErrorCode -> Maybe ErrorCode -> Maybe ErrorCode
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ErrorCode
a2) (Maybe ErrorCode
r1 Maybe ErrorCode -> Maybe ErrorCode -> Maybe ErrorCode
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe ErrorCode
r2)

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

instance Loggable S3Metadata where
    toLogText :: S3Metadata -> ErrorCode
toLogText (S3Metadata Maybe ErrorCode
id2 Maybe ErrorCode
rid) = ErrorCode
"S3: request ID=" ErrorCode -> ErrorCode -> ErrorCode
forall a. Monoid a => a -> a -> a
`mappend`
                                     ErrorCode -> Maybe ErrorCode -> ErrorCode
forall a. a -> Maybe a -> a
fromMaybe ErrorCode
"<none>" Maybe ErrorCode
rid ErrorCode -> ErrorCode -> ErrorCode
forall a. Monoid a => a -> a -> a
`mappend`
                                     ErrorCode
", x-amz-id-2=" ErrorCode -> ErrorCode -> ErrorCode
forall a. Monoid a => a -> a -> a
`mappend`
                                     ErrorCode -> Maybe ErrorCode -> ErrorCode
forall a. a -> Maybe a -> a
fromMaybe ErrorCode
"<none>" Maybe ErrorCode
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 [" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" method: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Method -> String
forall a. Show a => a -> String
show Method
s3QMethod String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" ; bucket: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> String
forall a. Show a => a -> String
show Maybe ByteString
s3QBucket String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" ; subresources: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Query -> String
forall a. Show a => a -> String
show Query
s3QSubresources String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" ; query: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Query -> String
forall a. Show a => a -> String
show Query
s3QQuery String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
" ; request body: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (case Maybe RequestBody
s3QRequestBody of Maybe RequestBody
Nothing -> String
"no"; Maybe RequestBody
_ -> String
"yes") String -> ShowS
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 :: 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 :: Method
-> Protocol
-> ByteString
-> Int
-> ByteString
-> Query
-> Maybe UTCTime
-> Maybe (IO ByteString)
-> Maybe ByteString
-> Maybe (Digest MD5)
-> RequestHeaders
-> RequestHeaders
-> Maybe RequestBody
-> ByteString
-> SignedQuery
SignedQuery {
        sqMethod :: Method
sqMethod = Method
s3QMethod
      , sqProtocol :: Protocol
sqProtocol = Protocol
s3Protocol
      , sqHost :: ByteString
sqHost = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
host
      , sqPort :: Int
sqPort = Int
s3Port
      , sqPath :: ByteString
sqPath = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
path
      , sqQuery :: Query
sqQuery = Query
sortedSubresources Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ Query
s3QQuery Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ Query
authQuery :: HTTP.Query
      , sqDate :: Maybe UTCTime
sqDate = UTCTime -> Maybe UTCTime
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
      amzHeaders :: RequestHeaders
amzHeaders = RequestHeaders -> RequestHeaders
forall a. Eq a => [(a, ByteString)] -> [(a, ByteString)]
merge (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ ((HeaderName, ByteString) -> (HeaderName, ByteString) -> Ordering)
-> RequestHeaders -> RequestHeaders
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (HeaderName -> HeaderName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (HeaderName -> HeaderName -> Ordering)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> (HeaderName, ByteString)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (RequestHeaders
s3QAmzHeaders RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ (((ByteString, ByteString) -> (HeaderName, ByteString))
-> [(ByteString, ByteString)] -> RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ByteString
k, ByteString
v) -> (ByteString -> HeaderName
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 a -> a -> Bool
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]) (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
: [(a, ByteString)]
xs)
                                                 | Bool
otherwise = (a, ByteString)
x1 (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
: [(a, ByteString)] -> [(a, ByteString)]
merge ((a, ByteString)
x2 (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
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 (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
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   -> ([ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s3Endpoint], [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/", (ByteString -> ByteString) -> Maybe ByteString -> Maybe 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, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s3Endpoint], [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
                       RequestStyle
VHostStyle  -> ([ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
s3Endpoint Maybe ByteString
s3QBucket], [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
      sortedSubresources :: Query
sortedSubresources = Query -> Query
forall a. Ord a => [a] -> [a]
sort Query
s3QSubresources
      canonicalizedResource :: Builder
canonicalizedResource = Char -> Builder
Blaze8.fromChar Char
'/' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                              Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (\ByteString
s -> ByteString -> Builder
Blaze.copyByteString ByteString
s Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
Blaze8.fromChar Char
'/') Maybe ByteString
s3QBucket Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                              Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty ByteString -> Builder
Blaze.copyByteString Maybe ByteString
urlEncodedS3QObject Builder -> Builder -> Builder
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 = (String -> ByteString) -> [String] -> [ByteString]
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 ByteString -> [ByteString] -> Bool
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 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend Builder
ceq (Builder -> Builder)
-> (ByteString -> Builder) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
enc) Maybe ByteString
mv
          in case Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
camp (((ByteString, Maybe ByteString) -> Builder) -> Query -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> Builder
encItem Query
qs) of
               [] -> Builder
forall a. Monoid a => a
mempty
               [Builder]
qs' -> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder
cqt Builder -> [Builder] -> [Builder]
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 (UTCTime -> AbsoluteTimeInfo) -> UTCTime -> AbsoluteTimeInfo
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 = [(ByteString, ByteString)]
-> (ByteString -> [(ByteString, ByteString)])
-> Maybe ByteString
-> [(ByteString, ByteString)]
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 (Builder -> ByteString)
-> ([[Builder]] -> Builder) -> [[Builder]] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([[Builder]] -> [Builder]) -> [[Builder]] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
Blaze8.fromChar Char
'\n') ([Builder] -> [Builder])
-> ([[Builder]] -> [Builder]) -> [[Builder]] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Builder]] -> [Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat  ([[Builder]] -> ByteString) -> [[Builder]] -> ByteString
forall a b. (a -> b) -> a -> b
$
                       [[ByteString -> Builder
Blaze.copyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Method -> ByteString
httpMethod Method
s3QMethod]
                       , [Builder -> (Digest MD5 -> Builder) -> Maybe (Digest MD5) -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty (ByteString -> Builder
Blaze.copyByteString (ByteString -> Builder)
-> (Digest MD5 -> ByteString) -> Digest MD5 -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> (Digest MD5 -> ByteString) -> Digest MD5 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert) Maybe (Digest MD5)
s3QContentMd5]
                       , [Builder -> (ByteString -> Builder) -> Maybe ByteString -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty ByteString -> Builder
Blaze.copyByteString Maybe ByteString
s3QContentType]
                       , [ByteString -> Builder
Blaze.copyByteString (ByteString -> Builder) -> ByteString -> Builder
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]
                       , ((HeaderName, ByteString) -> Builder)
-> RequestHeaders -> [Builder]
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 (HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
k) Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
Blaze8.fromChar Char
':' Builder -> Builder -> Builder
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
_ -> (IO ByteString -> Maybe (IO ByteString)
forall a. a -> Maybe a
Just (IO ByteString -> Maybe (IO ByteString))
-> IO ByteString -> Maybe (IO ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [ByteString
"AWS ", Credentials -> ByteString
accessKeyID Credentials
signatureCredentials, ByteString
":", ByteString
sig], [])
                                 AbsoluteExpires UTCTime
time -> (Maybe (IO ByteString)
forall a. Maybe a
Nothing, [(ByteString, ByteString)] -> Query
forall a. QueryLike a => a -> Query
HTTP.toQuery ([(ByteString, ByteString)] -> Query)
-> [(ByteString, ByteString)] -> Query
forall a b. (a -> b) -> a -> b
$ UTCTime -> [(ByteString, ByteString)]
makeAuthQuery UTCTime
time)
      makeAuthQuery :: UTCTime -> [(ByteString, ByteString)]
makeAuthQuery UTCTime
time
          = [(ByteString
"Expires" :: B8.ByteString, UTCTime -> ByteString
fmtTimeEpochSeconds UTCTime
time)
            , (ByteString
"AWSAccessKeyId", Credentials -> ByteString
accessKeyID Credentials
signatureCredentials)
            , (ByteString
"SignatureMethod", ByteString
"HmacSHA256")
            , (ByteString
"Signature", ByteString
sig)] [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
iamTok
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 = 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
..}
    = SignedQuery :: Method
-> Protocol
-> ByteString
-> Int
-> ByteString
-> Query
-> Maybe UTCTime
-> Maybe (IO ByteString)
-> Maybe ByteString
-> Maybe (Digest MD5)
-> RequestHeaders
-> RequestHeaders
-> Maybe RequestBody
-> ByteString
-> SignedQuery
SignedQuery
    { sqMethod :: Method
sqMethod = Method
s3QMethod
    , sqProtocol :: Protocol
sqProtocol = Protocol
s3Protocol
    , sqHost :: ByteString
sqHost = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
host
    , sqPort :: Int
sqPort = Int
s3Port
    , sqPath :: ByteString
sqPath = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
path
    , sqQuery :: Query
sqQuery = Query
queryString Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++ Query
signatureQuery :: HTTP.Query
    , sqDate :: Maybe UTCTime
sqDate = UTCTime -> Maybe UTCTime
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 = Map HeaderName ByteString -> RequestHeaders
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 = RequestHeaders
-> (ByteString -> RequestHeaders)
-> Maybe ByteString
-> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ByteString
x -> [(HeaderName
hAmzSecurityToken, ByteString
x)]) (Maybe ByteString -> RequestHeaders)
-> Maybe ByteString -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe ByteString
iamToken Credentials
signatureCredentials

        amzHeaders :: Map HeaderName ByteString
amzHeaders = RequestHeaders -> Map HeaderName ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (RequestHeaders -> Map HeaderName ByteString)
-> RequestHeaders -> Map HeaderName ByteString
forall a b. (a -> b) -> a -> b
$ (HeaderName
hAmzDate, ByteString
sigTime)(HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:(HeaderName
hAmzContentSha256, ByteString
payloadHash)(HeaderName, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:RequestHeaders
iamTok RequestHeaders -> RequestHeaders -> RequestHeaders
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" (UTCTime -> ByteString) -> UTCTime -> ByteString
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 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> Digest SHA256
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 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash ByteString
bs :: CH.Digest CH.SHA256)
                    (S3SignPayloadMode
SignWithEffort, Maybe RequestBody
_)                 -> ByteString
"UNSIGNED-PAYLOAD"
                    (S3SignPayloadMode
AlwaysSigned, Maybe RequestBody
_)                   -> String -> ByteString
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   -> ([ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s3Endpoint], [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/", (ByteString -> ByteString) -> Maybe ByteString -> Maybe 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, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s3Endpoint], [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
            RequestStyle
VHostStyle  -> ([ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
s3Endpoint Maybe ByteString
s3QBucket], [ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/", Maybe ByteString
urlEncodedS3QObject])
            where
                urlEncodedS3QObject :: Maybe ByteString
urlEncodedS3QObject = Bool -> ByteString -> ByteString
s3UriEncode Bool
False (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
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 = Map HeaderName ByteString
-> Map HeaderName ByteString -> Map HeaderName ByteString
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map HeaderName ByteString
amzHeaders (Map HeaderName ByteString -> Map HeaderName ByteString)
-> (RequestHeaders -> Map HeaderName ByteString)
-> RequestHeaders
-> Map HeaderName ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestHeaders -> Map HeaderName ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (RequestHeaders -> Map HeaderName ByteString)
-> RequestHeaders -> Map HeaderName ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe (HeaderName, ByteString)] -> RequestHeaders
forall a. [Maybe a] -> [a]
catMaybes
            [ (HeaderName, ByteString) -> Maybe (HeaderName, ByteString)
forall a. a -> Maybe a
Just (HeaderName
"host", ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
host)
            , (HeaderName
"content-type",) (ByteString -> (HeaderName, ByteString))
-> Maybe ByteString -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
s3QContentType
            ]
        signedHeaders :: ByteString
signedHeaders = ByteString -> [ByteString] -> ByteString
B8.intercalate ByteString
";" ((HeaderName -> ByteString) -> [HeaderName] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase ([HeaderName] -> [ByteString]) -> [HeaderName] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Map HeaderName ByteString -> [HeaderName]
forall k a. Map k a -> [k]
Map.keys Map HeaderName ByteString
canonicalHeaders)
        stringToSign :: ByteString
stringToSign = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"\n" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
            [ Method -> ByteString
httpMethod Method
s3QMethod                   -- method
            , [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ([Maybe ByteString] -> [ByteString])
-> [Maybe ByteString]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ByteString] -> ByteString)
-> [Maybe ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString]
path             -- path
            , Bool -> Query -> ByteString
s3RenderQuery Bool
False (Query -> ByteString) -> Query -> ByteString
forall a b. (a -> b) -> a -> b
$ Query -> Query
forall a. Ord a => [a] -> [a]
sort Query
queryString -- query string
            ] [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
            (HeaderName -> ByteString -> [ByteString])
-> Map HeaderName ByteString -> [ByteString]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\HeaderName
a ByteString
b -> [HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
":" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
b]) Map HeaderName ByteString
canonicalHeaders [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++
            [ ByteString
"" -- end headers
            , ByteString
signedHeaders
            , Map HeaderName ByteString
amzHeaders Map HeaderName ByteString -> HeaderName -> ByteString
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
_  -> (IO ByteString -> Maybe (IO ByteString)
forall a. a -> Maybe a
Just IO ByteString
auth, [], Query
allQueries)
            AbsoluteExpires UTCTime
time ->
                ( Maybe (IO ByteString)
forall a. Maybe a
Nothing
                , [(HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
hAmzSignature, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
sig)]
                , (Query
allQueries Query -> Query -> Query
forall a. [a] -> [a] -> [a]
++) (Query -> Query)
-> (RequestHeaders -> Query) -> RequestHeaders -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, ByteString)] -> Query
forall a. QueryLike a => a -> Query
HTTP.toQuery ([(ByteString, ByteString)] -> Query)
-> (RequestHeaders -> [(ByteString, ByteString)])
-> RequestHeaders
-> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> (ByteString, ByteString))
-> RequestHeaders -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> ByteString)
-> (HeaderName, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first HeaderName -> ByteString
forall s. CI s -> s
CI.original) (RequestHeaders -> Query) -> RequestHeaders -> Query
forall a b. (a -> b) -> a -> b
$
                    [ (HeaderName
hAmzAlgorithm, ByteString
"AWS4-HMAC-SHA256")
                    , (HeaderName
hAmzCredential, ByteString
cred)
                    , (HeaderName
hAmzDate, Map HeaderName ByteString
amzHeaders Map HeaderName ByteString -> HeaderName -> ByteString
forall k a. Ord k => Map k a -> k -> a
Map.! HeaderName
hAmzDate)
                    , (HeaderName
hAmzExpires, String -> ByteString
B8.pack (String -> ByteString)
-> (NominalDiffTime -> String) -> NominalDiffTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> String
forall a. Show a => a -> String
show :: Integer -> String) (Integer -> String)
-> (NominalDiffTime -> Integer) -> NominalDiffTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> ByteString) -> NominalDiffTime -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
time UTCTime
signatureTime)
                    , (HeaderName
hAmzSignedHeaders, ByteString
signedHeaders)
                    ] RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ RequestHeaders
iamTok
                )
            where
                allQueries :: Query
allQueries = Query
s3QSubresources Query -> Query -> Query
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 (UTCTime -> AbsoluteTimeInfo) -> UTCTime -> AbsoluteTimeInfo
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 ((Char -> ByteString) -> ByteString -> ByteString)
-> (Char -> ByteString) -> ByteString -> ByteString
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 Char -> String -> Bool
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 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Char
'%' Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (Int -> ShowS
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 = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> (Query -> [ByteString]) -> Query -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
qmf ([ByteString] -> [ByteString])
-> (Query -> [ByteString]) -> Query -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
intersperse (Char -> ByteString
B8.singleton Char
'&') ([ByteString] -> [ByteString])
-> (Query -> [ByteString]) -> Query -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> ByteString)
-> Query -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> ByteString
renderItem
    where
        qmf :: [ByteString] -> [ByteString]
qmf = if Bool
qm then (ByteString
"?"ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) else [ByteString] -> [ByteString]
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
Sem.<> ByteString
"=" ByteString -> ByteString -> 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 ByteString -> ByteString -> ByteString
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 = (String -> ByteString)
-> ([Word8] -> ByteString) -> Either String [Word8] -> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> String -> ByteString
forall a b. a -> b -> a
const ByteString
domain) [Word8] -> ByteString
B.pack (Either String [Word8] -> ByteString)
-> Either String [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Parser [Word8] -> ByteString -> Either String [Word8]
forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser [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 [Word8]
parser = do
            ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"s3"
            ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
".dualstack." Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
Atto.string ByteString
"-" Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
Atto.string ByteString
"."
            [Word8]
r <- Parser ByteString Word8 -> Parser ByteString -> Parser [Word8]
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
Atto.manyTill Parser ByteString Word8
Atto.anyWord8 (Parser ByteString -> Parser [Word8])
-> Parser ByteString -> Parser [Word8]
forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString
Atto.string ByteString
".amazonaws.com"
            Parser ByteString ()
forall t. Chunk t => Parser t ()
Atto.endOfInput
            [Word8] -> Parser [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8]
r

s3ResponseConsumer :: HTTPResponseConsumer a
                         -> IORef S3Metadata
                         -> HTTPResponseConsumer a
s3ResponseConsumer :: HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
s3ResponseConsumer HTTPResponseConsumer a
inner IORef S3Metadata
metadataRef = HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
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
            a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

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

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

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

type CanonicalUserId = T.Text

data UserInfo
    = UserInfo {
        UserInfo -> ErrorCode
userId          :: CanonicalUserId
      , UserInfo -> Maybe ErrorCode
userDisplayName :: Maybe T.Text
      }
    deriving (Int -> UserInfo -> ShowS
[UserInfo] -> ShowS
UserInfo -> String
(Int -> UserInfo -> ShowS)
-> (UserInfo -> String) -> ([UserInfo] -> ShowS) -> Show UserInfo
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 :: Cursor -> m UserInfo
parseUserInfo Cursor
el = do ErrorCode
id_ <- String -> [ErrorCode] -> m ErrorCode
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing user ID" ([ErrorCode] -> m ErrorCode) -> [ErrorCode] -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"ID"
                      Maybe ErrorCode
displayName <- Maybe ErrorCode -> m (Maybe ErrorCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ErrorCode -> m (Maybe ErrorCode))
-> Maybe ErrorCode -> m (Maybe ErrorCode)
forall a b. (a -> b) -> a -> b
$ case (Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"DisplayName") of
                                                  (ErrorCode
x:[ErrorCode]
_) -> ErrorCode -> Maybe ErrorCode
forall a. a -> Maybe a
Just ErrorCode
x
                                                  []    -> Maybe ErrorCode
forall a. Maybe a
Nothing
                      UserInfo -> m UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return UserInfo :: ErrorCode -> Maybe ErrorCode -> UserInfo
UserInfo { userId :: ErrorCode
userId = ErrorCode
id_, userDisplayName :: Maybe ErrorCode
userDisplayName = Maybe ErrorCode
displayName }

data CannedAcl
    = AclPrivate
    | AclPublicRead
    | AclPublicReadWrite
    | AclAuthenticatedRead
    | AclBucketOwnerRead
    | AclBucketOwnerFullControl
    | AclLogDeliveryWrite
    deriving (Int -> CannedAcl -> ShowS
[CannedAcl] -> ShowS
CannedAcl -> String
(Int -> CannedAcl -> ShowS)
-> (CannedAcl -> String)
-> ([CannedAcl] -> ShowS)
-> Show CannedAcl
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 -> ErrorCode
writeCannedAcl CannedAcl
AclPrivate                = ErrorCode
"private"
writeCannedAcl CannedAcl
AclPublicRead             = ErrorCode
"public-read"
writeCannedAcl CannedAcl
AclPublicReadWrite        = ErrorCode
"public-read-write"
writeCannedAcl CannedAcl
AclAuthenticatedRead      = ErrorCode
"authenticated-read"
writeCannedAcl CannedAcl
AclBucketOwnerRead        = ErrorCode
"bucket-owner-read"
writeCannedAcl CannedAcl
AclBucketOwnerFullControl = ErrorCode
"bucket-owner-full-control"
writeCannedAcl CannedAcl
AclLogDeliveryWrite       = ErrorCode
"log-delivery-write"

data StorageClass
    = Standard
    | StandardInfrequentAccess
    | ReducedRedundancy
    | Glacier
    | OtherStorageClass T.Text
    deriving (Int -> StorageClass -> ShowS
[StorageClass] -> ShowS
StorageClass -> String
(Int -> StorageClass -> ShowS)
-> (StorageClass -> String)
-> ([StorageClass] -> ShowS)
-> Show StorageClass
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 :: ErrorCode -> StorageClass
parseStorageClass ErrorCode
"STANDARD"           = StorageClass
Standard
parseStorageClass ErrorCode
"STANDARD_IA"        = StorageClass
StandardInfrequentAccess
parseStorageClass ErrorCode
"REDUCED_REDUNDANCY" = StorageClass
ReducedRedundancy
parseStorageClass ErrorCode
"GLACIER"            = StorageClass
Glacier
parseStorageClass ErrorCode
s                    = ErrorCode -> StorageClass
OtherStorageClass ErrorCode
s

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

data ServerSideEncryption
    = AES256
    deriving (Int -> ServerSideEncryption -> ShowS
[ServerSideEncryption] -> ShowS
ServerSideEncryption -> String
(Int -> ServerSideEncryption -> ShowS)
-> (ServerSideEncryption -> String)
-> ([ServerSideEncryption] -> ShowS)
-> Show ServerSideEncryption
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 :: ErrorCode -> m ServerSideEncryption
parseServerSideEncryption ErrorCode
"AES256" = ServerSideEncryption -> m ServerSideEncryption
forall (m :: * -> *) a. Monad m => a -> m a
return ServerSideEncryption
AES256
parseServerSideEncryption ErrorCode
s = XmlException -> m ServerSideEncryption
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m ServerSideEncryption)
-> (String -> XmlException) -> String -> m ServerSideEncryption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> XmlException
XmlException (String -> m ServerSideEncryption)
-> String -> m ServerSideEncryption
forall a b. (a -> b) -> a -> b
$ String
"Invalid Server Side Encryption: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorCode -> String
T.unpack ErrorCode
s

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

type Bucket = T.Text

data BucketInfo
    = BucketInfo {
        BucketInfo -> ErrorCode
bucketName         :: Bucket
      , BucketInfo -> UTCTime
bucketCreationDate :: UTCTime
      }
    deriving (Int -> BucketInfo -> ShowS
[BucketInfo] -> ShowS
BucketInfo -> String
(Int -> BucketInfo -> ShowS)
-> (BucketInfo -> String)
-> ([BucketInfo] -> ShowS)
-> Show BucketInfo
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 -> ErrorCode
oidBucket :: Bucket
      , ObjectId -> ErrorCode
oidObject :: Object
      , ObjectId -> Maybe ErrorCode
oidVersion :: Maybe T.Text
      }
    deriving (Int -> ObjectId -> ShowS
[ObjectId] -> ShowS
ObjectId -> String
(Int -> ObjectId -> ShowS)
-> (ObjectId -> String) -> ([ObjectId] -> ShowS) -> Show ObjectId
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 -> ErrorCode
oviKey          :: T.Text
      , ObjectVersionInfo -> ErrorCode
oviVersionId    :: T.Text
      , ObjectVersionInfo -> Bool
oviIsLatest     :: Bool
      , ObjectVersionInfo -> UTCTime
oviLastModified :: UTCTime
      , ObjectVersionInfo -> ErrorCode
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
(Int -> ObjectVersionInfo -> ShowS)
-> (ObjectVersionInfo -> String)
-> ([ObjectVersionInfo] -> ShowS)
-> Show ObjectVersionInfo
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 :: Cursor -> m ObjectVersionInfo
parseObjectVersionInfo Cursor
el
    = do ErrorCode
key <- String -> [ErrorCode] -> m ErrorCode
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object Key" ([ErrorCode] -> m ErrorCode) -> [ErrorCode] -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"Key"
         ErrorCode
versionId <- String -> [ErrorCode] -> m ErrorCode
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object VersionId" ([ErrorCode] -> m ErrorCode) -> [ErrorCode] -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"VersionId"
         Bool
isLatest <- String -> [m Bool] -> m Bool
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object IsLatest" ([m Bool] -> m Bool) -> [m Bool] -> m Bool
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m Bool]) -> [m Bool]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"IsLatest" (Cursor -> [ErrorCode])
-> (ErrorCode -> m Bool) -> Cursor -> [m Bool]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| ErrorCode -> m Bool
forall (m :: * -> *). MonadThrow m => ErrorCode -> m Bool
textReadBool
         let time :: ErrorCode -> m a
time ErrorCode
s = case (Bool -> TimeLocale -> String -> String -> Maybe 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%QZ" (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> String
T.unpack ErrorCode
s) Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           (Bool -> TimeLocale -> String -> String -> Maybe 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" (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> String
T.unpack ErrorCode
s) of
                        Maybe a
Nothing -> XmlException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid time"
                        Just a
v -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
         UTCTime
lastModified <- String -> [m UTCTime] -> m UTCTime
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object LastModified" ([m UTCTime] -> m UTCTime) -> [m UTCTime] -> m UTCTime
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m UTCTime]) -> [m UTCTime]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"LastModified" (Cursor -> [ErrorCode])
-> (ErrorCode -> m UTCTime) -> Cursor -> [m UTCTime]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| ErrorCode -> m UTCTime
forall a (m :: * -> *).
(ParseTime a, MonadThrow m) =>
ErrorCode -> m a
time
         Maybe UserInfo
owner <- case Cursor
el Cursor -> (Cursor -> [m UserInfo]) -> [m UserInfo]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Axis
Cu.laxElement ErrorCode
"Owner" Axis -> (Cursor -> m UserInfo) -> Cursor -> [m UserInfo]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m UserInfo
forall (m :: * -> *). MonadThrow m => Cursor -> m UserInfo
parseUserInfo of
                    (m UserInfo
x:[m UserInfo]
_) -> (UserInfo -> Maybe UserInfo) -> m UserInfo -> m (Maybe UserInfo)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just m UserInfo
x
                    [] -> Maybe UserInfo -> m (Maybe UserInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserInfo
forall a. Maybe a
Nothing
         case Cursor -> Node
forall node. Cursor node -> node
Cu.node Cursor
el of
           XML.NodeElement Element
e | Element -> ErrorCode
elName Element
e ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorCode
"Version" ->
             do ErrorCode
eTag <- String -> [ErrorCode] -> m ErrorCode
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object ETag" ([ErrorCode] -> m ErrorCode) -> [ErrorCode] -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"ETag"
                Integer
size <- String -> [m Integer] -> m Integer
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object Size" ([m Integer] -> m Integer) -> [m Integer] -> m Integer
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m Integer]) -> [m Integer]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"Size" (Cursor -> [ErrorCode])
-> (ErrorCode -> m Integer) -> Cursor -> [m Integer]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| ErrorCode -> m Integer
forall (m :: * -> *) a. (MonadThrow m, Num a) => ErrorCode -> m a
textReadInt
                StorageClass
storageClass <- String -> [m StorageClass] -> m StorageClass
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object StorageClass" ([m StorageClass] -> m StorageClass)
-> [m StorageClass] -> m StorageClass
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m StorageClass]) -> [m StorageClass]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"StorageClass" (Cursor -> [ErrorCode])
-> (ErrorCode -> m StorageClass) -> Cursor -> [m StorageClass]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| StorageClass -> m StorageClass
forall (m :: * -> *) a. Monad m => a -> m a
return (StorageClass -> m StorageClass)
-> (ErrorCode -> StorageClass) -> ErrorCode -> m StorageClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCode -> StorageClass
parseStorageClass
                ObjectVersionInfo -> m ObjectVersionInfo
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectVersion :: ErrorCode
-> ErrorCode
-> Bool
-> UTCTime
-> ErrorCode
-> Integer
-> StorageClass
-> Maybe UserInfo
-> ObjectVersionInfo
ObjectVersion{
                             oviKey :: ErrorCode
oviKey          = ErrorCode
key
                           , oviVersionId :: ErrorCode
oviVersionId    = ErrorCode
versionId
                           , oviIsLatest :: Bool
oviIsLatest     = Bool
isLatest
                           , oviLastModified :: UTCTime
oviLastModified = UTCTime
lastModified
                           , oviETag :: ErrorCode
oviETag         = ErrorCode
eTag
                           , oviSize :: Integer
oviSize         = Integer
size
                           , oviStorageClass :: StorageClass
oviStorageClass = StorageClass
storageClass
                           , oviOwner :: Maybe UserInfo
oviOwner        = Maybe UserInfo
owner
                           }
           XML.NodeElement Element
e | Element -> ErrorCode
elName Element
e ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorCode
"DeleteMarker" ->
             ObjectVersionInfo -> m ObjectVersionInfo
forall (m :: * -> *) a. Monad m => a -> m a
return DeleteMarker :: ErrorCode
-> ErrorCode
-> Bool
-> UTCTime
-> Maybe UserInfo
-> ObjectVersionInfo
DeleteMarker{
                             oviKey :: ErrorCode
oviKey          = ErrorCode
key
                           , oviVersionId :: ErrorCode
oviVersionId    = ErrorCode
versionId
                           , oviIsLatest :: Bool
oviIsLatest     = Bool
isLatest
                           , oviLastModified :: UTCTime
oviLastModified = UTCTime
lastModified
                           , oviOwner :: Maybe UserInfo
oviOwner        = Maybe UserInfo
owner
                           }
           Node
_ -> XmlException -> m ObjectVersionInfo
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m ObjectVersionInfo)
-> XmlException -> m ObjectVersionInfo
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid object version tag"
    where
      elName :: Element -> ErrorCode
elName = Name -> ErrorCode
XML.nameLocalName (Name -> ErrorCode) -> (Element -> Name) -> Element -> ErrorCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
XML.elementName
      fmap' :: Monad m => (a -> b) -> m a -> m b
      fmap' :: (a -> b) -> m a -> m b
fmap' a -> b
f m a
ma = m a
ma m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

data ObjectInfo
    = ObjectInfo {
        ObjectInfo -> ErrorCode
objectKey          :: T.Text
      , ObjectInfo -> UTCTime
objectLastModified :: UTCTime
      , ObjectInfo -> ErrorCode
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
(Int -> ObjectInfo -> ShowS)
-> (ObjectInfo -> String)
-> ([ObjectInfo] -> ShowS)
-> Show ObjectInfo
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 :: Cursor -> m ObjectInfo
parseObjectInfo Cursor
el
    = do ErrorCode
key <- String -> [ErrorCode] -> m ErrorCode
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object Key" ([ErrorCode] -> m ErrorCode) -> [ErrorCode] -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"Key"
         let time :: ErrorCode -> m a
time ErrorCode
s = case (Bool -> TimeLocale -> String -> String -> Maybe 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%QZ" (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> String
T.unpack ErrorCode
s) Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           (Bool -> TimeLocale -> String -> String -> Maybe 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" (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$ ErrorCode -> String
T.unpack ErrorCode
s) of
                        Maybe a
Nothing -> XmlException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid time"
                        Just a
v -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
         UTCTime
lastModified <- String -> [m UTCTime] -> m UTCTime
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object LastModified" ([m UTCTime] -> m UTCTime) -> [m UTCTime] -> m UTCTime
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m UTCTime]) -> [m UTCTime]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"LastModified" (Cursor -> [ErrorCode])
-> (ErrorCode -> m UTCTime) -> Cursor -> [m UTCTime]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| ErrorCode -> m UTCTime
forall a (m :: * -> *).
(ParseTime a, MonadThrow m) =>
ErrorCode -> m a
time
         ErrorCode
eTag <- String -> [ErrorCode] -> m ErrorCode
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object ETag" ([ErrorCode] -> m ErrorCode) -> [ErrorCode] -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [ErrorCode]) -> [ErrorCode]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"ETag"
         Integer
size <- String -> [m Integer] -> m Integer
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object Size" ([m Integer] -> m Integer) -> [m Integer] -> m Integer
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m Integer]) -> [m Integer]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"Size" (Cursor -> [ErrorCode])
-> (ErrorCode -> m Integer) -> Cursor -> [m Integer]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| ErrorCode -> m Integer
forall (m :: * -> *) a. (MonadThrow m, Num a) => ErrorCode -> m a
textReadInt
         StorageClass
storageClass <- String -> [m StorageClass] -> m StorageClass
forall (m :: * -> *) a. MonadThrow m => String -> [m a] -> m a
forceM String
"Missing object StorageClass" ([m StorageClass] -> m StorageClass)
-> [m StorageClass] -> m StorageClass
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [m StorageClass]) -> [m StorageClass]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Cursor -> [ErrorCode]
elContent ErrorCode
"StorageClass" (Cursor -> [ErrorCode])
-> (ErrorCode -> m StorageClass) -> Cursor -> [m StorageClass]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| StorageClass -> m StorageClass
forall (m :: * -> *) a. Monad m => a -> m a
return (StorageClass -> m StorageClass)
-> (ErrorCode -> StorageClass) -> ErrorCode -> m StorageClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCode -> StorageClass
parseStorageClass
         Maybe UserInfo
owner <- case Cursor
el Cursor -> (Cursor -> [m UserInfo]) -> [m UserInfo]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ ErrorCode -> Axis
Cu.laxElement ErrorCode
"Owner" Axis -> (Cursor -> m UserInfo) -> Cursor -> [m UserInfo]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m UserInfo
forall (m :: * -> *). MonadThrow m => Cursor -> m UserInfo
parseUserInfo of
                    (m UserInfo
x:[m UserInfo]
_) -> (UserInfo -> Maybe UserInfo) -> m UserInfo -> m (Maybe UserInfo)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just m UserInfo
x
                    [] -> Maybe UserInfo -> m (Maybe UserInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserInfo
forall a. Maybe a
Nothing
         ObjectInfo -> m ObjectInfo
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectInfo :: ErrorCode
-> UTCTime
-> ErrorCode
-> Integer
-> StorageClass
-> Maybe UserInfo
-> ObjectInfo
ObjectInfo{
                      objectKey :: ErrorCode
objectKey          = ErrorCode
key
                    , objectLastModified :: UTCTime
objectLastModified = UTCTime
lastModified
                    , objectETag :: ErrorCode
objectETag         = ErrorCode
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' :: (a -> b) -> m a -> m b
fmap' a -> b
f m a
ma = m a
ma m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

data ObjectMetadata
    = ObjectMetadata {
        ObjectMetadata -> Bool
omDeleteMarker         :: Bool
      , ObjectMetadata -> ErrorCode
omETag                 :: T.Text
      , ObjectMetadata -> UTCTime
omLastModified         :: UTCTime
      , ObjectMetadata -> Maybe ErrorCode
omVersionId            :: Maybe T.Text
-- TODO:
--      , omExpiration           :: Maybe (UTCTime, T.Text)
      , ObjectMetadata -> [(ErrorCode, ErrorCode)]
omUserMetadata         :: [(T.Text, T.Text)]
      , ObjectMetadata -> Maybe ErrorCode
omMissingUserMetadata  :: Maybe T.Text
      , ObjectMetadata -> Maybe ServerSideEncryption
omServerSideEncryption :: Maybe ServerSideEncryption
      }
    deriving (Int -> ObjectMetadata -> ShowS
[ObjectMetadata] -> ShowS
ObjectMetadata -> String
(Int -> ObjectMetadata -> ShowS)
-> (ObjectMetadata -> String)
-> ([ObjectMetadata] -> ShowS)
-> Show ObjectMetadata
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 :: RequestHeaders -> m ObjectMetadata
parseObjectMetadata RequestHeaders
h = Bool
-> ErrorCode
-> UTCTime
-> Maybe ErrorCode
-> [(ErrorCode, ErrorCode)]
-> Maybe ErrorCode
-> Maybe ServerSideEncryption
-> ObjectMetadata
ObjectMetadata
                        (Bool
 -> ErrorCode
 -> UTCTime
 -> Maybe ErrorCode
 -> [(ErrorCode, ErrorCode)]
 -> Maybe ErrorCode
 -> Maybe ServerSideEncryption
 -> ObjectMetadata)
-> m Bool
-> m (ErrorCode
      -> UTCTime
      -> Maybe ErrorCode
      -> [(ErrorCode, ErrorCode)]
      -> Maybe ErrorCode
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
`liftM` m Bool
deleteMarker
                        m (ErrorCode
   -> UTCTime
   -> Maybe ErrorCode
   -> [(ErrorCode, ErrorCode)]
   -> Maybe ErrorCode
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m ErrorCode
-> m (UTCTime
      -> Maybe ErrorCode
      -> [(ErrorCode, ErrorCode)]
      -> Maybe ErrorCode
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m ErrorCode
etag
                        m (UTCTime
   -> Maybe ErrorCode
   -> [(ErrorCode, ErrorCode)]
   -> Maybe ErrorCode
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m UTCTime
-> m (Maybe ErrorCode
      -> [(ErrorCode, ErrorCode)]
      -> Maybe ErrorCode
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m UTCTime
lastModified
                        m (Maybe ErrorCode
   -> [(ErrorCode, ErrorCode)]
   -> Maybe ErrorCode
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m (Maybe ErrorCode)
-> m ([(ErrorCode, ErrorCode)]
      -> Maybe ErrorCode -> Maybe ServerSideEncryption -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Maybe ErrorCode -> m (Maybe ErrorCode)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ErrorCode
versionId
--                        `ap` expiration
                        m ([(ErrorCode, ErrorCode)]
   -> Maybe ErrorCode -> Maybe ServerSideEncryption -> ObjectMetadata)
-> m [(ErrorCode, ErrorCode)]
-> m (Maybe ErrorCode
      -> Maybe ServerSideEncryption -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` [(ErrorCode, ErrorCode)] -> m [(ErrorCode, ErrorCode)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ErrorCode, ErrorCode)]
userMetadata
                        m (Maybe ErrorCode -> Maybe ServerSideEncryption -> ObjectMetadata)
-> m (Maybe ErrorCode)
-> m (Maybe ServerSideEncryption -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Maybe ErrorCode -> m (Maybe ErrorCode)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ErrorCode
missingUserMetadata
                        m (Maybe ServerSideEncryption -> ObjectMetadata)
-> m (Maybe ServerSideEncryption) -> m ObjectMetadata
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 (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-delete-marker" RequestHeaders
h of
                         Maybe String
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         Just String
"true" -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         Just String
"false" -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         Just String
x -> HeaderException -> m Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeaderException -> m Bool) -> HeaderException -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException (String
"Invalid x-amz-delete-marker " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x)
        etag :: m ErrorCode
etag = case ByteString -> ErrorCode
T.decodeUtf8 (ByteString -> ErrorCode) -> Maybe ByteString -> Maybe ErrorCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"ETag" RequestHeaders
h of
                 Just ErrorCode
x -> ErrorCode -> m ErrorCode
forall (m :: * -> *) a. Monad m => a -> m a
return ErrorCode
x
                 Maybe ErrorCode
Nothing -> HeaderException -> m ErrorCode
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeaderException -> m ErrorCode) -> HeaderException -> m ErrorCode
forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException String
"ETag missing"
        lastModified :: m UTCTime
lastModified = case ByteString -> String
B8.unpack (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> RequestHeaders -> Maybe ByteString
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 -> UTCTime -> m UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
                                      Maybe UTCTime
Nothing -> HeaderException -> m UTCTime
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeaderException -> m UTCTime) -> HeaderException -> m UTCTime
forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException (String
"Invalid Last-Modified: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ts)
                         Maybe String
Nothing -> HeaderException -> m UTCTime
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeaderException -> m UTCTime) -> HeaderException -> m UTCTime
forall a b. (a -> b) -> a -> b
$ String -> HeaderException
HeaderException String
"Last-Modified missing"
        versionId :: Maybe ErrorCode
versionId = ByteString -> ErrorCode
T.decodeUtf8 (ByteString -> ErrorCode) -> Maybe ByteString -> Maybe ErrorCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-version-id" RequestHeaders
h
        -- expiration = return undefined
        userMetadata :: [(ErrorCode, ErrorCode)]
userMetadata = (((ErrorCode, ErrorCode) -> Maybe (ErrorCode, ErrorCode))
 -> [(ErrorCode, ErrorCode)] -> [(ErrorCode, ErrorCode)])
-> [(ErrorCode, ErrorCode)]
-> ((ErrorCode, ErrorCode) -> Maybe (ErrorCode, ErrorCode))
-> [(ErrorCode, ErrorCode)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ErrorCode, ErrorCode) -> Maybe (ErrorCode, ErrorCode))
-> [(ErrorCode, ErrorCode)] -> [(ErrorCode, ErrorCode)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(ErrorCode, ErrorCode)]
ht (((ErrorCode, ErrorCode) -> Maybe (ErrorCode, ErrorCode))
 -> [(ErrorCode, ErrorCode)])
-> ((ErrorCode, ErrorCode) -> Maybe (ErrorCode, ErrorCode))
-> [(ErrorCode, ErrorCode)]
forall a b. (a -> b) -> a -> b
$
                       \(ErrorCode
k, ErrorCode
v) -> do ErrorCode
i <- ErrorCode -> ErrorCode -> Maybe ErrorCode
T.stripPrefix ErrorCode
"x-amz-meta-" ErrorCode
k
                                     (ErrorCode, ErrorCode) -> Maybe (ErrorCode, ErrorCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorCode
i, ErrorCode
v)
        missingUserMetadata :: Maybe ErrorCode
missingUserMetadata = ByteString -> ErrorCode
T.decodeUtf8 (ByteString -> ErrorCode) -> Maybe ByteString -> Maybe ErrorCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> RequestHeaders -> Maybe ByteString
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 -> ErrorCode
T.decodeUtf8 (ByteString -> ErrorCode) -> Maybe ByteString -> Maybe ErrorCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-amz-server-side-encryption" RequestHeaders
h of
                                 Just ErrorCode
x -> Maybe ServerSideEncryption -> m (Maybe ServerSideEncryption)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ServerSideEncryption -> m (Maybe ServerSideEncryption))
-> Maybe ServerSideEncryption -> m (Maybe ServerSideEncryption)
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Maybe ServerSideEncryption
forall (m :: * -> *).
MonadThrow m =>
ErrorCode -> m ServerSideEncryption
parseServerSideEncryption ErrorCode
x
                                 Maybe ErrorCode
Nothing -> Maybe ServerSideEncryption -> m (Maybe ServerSideEncryption)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ServerSideEncryption
forall a. Maybe a
Nothing

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

type LocationConstraint = T.Text

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

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