{-# 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
$cshowsPrec :: Int -> S3Authorization -> ShowS
showsPrec :: Int -> S3Authorization -> ShowS
$cshow :: S3Authorization -> String
show :: S3Authorization -> String
$cshowList :: [S3Authorization] -> ShowS
showList :: [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
$cshowsPrec :: Int -> RequestStyle -> ShowS
showsPrec :: Int -> RequestStyle -> ShowS
$cshow :: RequestStyle -> String
show :: RequestStyle -> String
$cshowList :: [RequestStyle] -> ShowS
showList :: [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
$c== :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
== :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
$c/= :: S3SignPayloadMode -> S3SignPayloadMode -> Bool
/= :: 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
$cshowsPrec :: Int -> S3SignPayloadMode -> ShowS
showsPrec :: Int -> S3SignPayloadMode -> ShowS
$cshow :: S3SignPayloadMode -> String
show :: S3SignPayloadMode -> String
$cshowList :: [S3SignPayloadMode] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS S3SignPayloadMode
readsPrec :: Int -> ReadS S3SignPayloadMode
$creadList :: ReadS [S3SignPayloadMode]
readList :: ReadS [S3SignPayloadMode]
$creadPrec :: ReadPrec S3SignPayloadMode
readPrec :: ReadPrec S3SignPayloadMode
$creadListPrec :: ReadPrec [S3SignPayloadMode]
readListPrec :: ReadPrec [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
$c== :: S3SignVersion -> S3SignVersion -> Bool
== :: S3SignVersion -> S3SignVersion -> Bool
$c/= :: S3SignVersion -> S3SignVersion -> Bool
/= :: 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
$cshowsPrec :: Int -> S3SignVersion -> ShowS
showsPrec :: Int -> S3SignVersion -> ShowS
$cshow :: S3SignVersion -> String
show :: S3SignVersion -> String
$cshowList :: [S3SignVersion] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS S3SignVersion
readsPrec :: Int -> ReadS S3SignVersion
$creadList :: ReadS [S3SignVersion]
readList :: ReadS [S3SignVersion]
$creadPrec :: ReadPrec S3SignVersion
readPrec :: ReadPrec S3SignVersion
$creadListPrec :: ReadPrec [S3SignVersion]
readListPrec :: ReadPrec [S3SignVersion]
Read, Typeable)

data S3Configuration qt
    = S3Configuration
       { forall qt. S3Configuration qt -> Protocol
s3Protocol :: Protocol
       , forall qt. S3Configuration qt -> ByteString
s3Endpoint :: B.ByteString
       , forall qt. S3Configuration qt -> Maybe ByteString
s3Region :: Maybe B.ByteString
       , forall qt. S3Configuration qt -> RequestStyle
s3RequestStyle :: RequestStyle
       , forall qt. S3Configuration qt -> Int
s3Port :: Int
       , forall qt. S3Configuration qt -> Maybe ServerSideEncryption
s3ServerSideEncryption :: Maybe ServerSideEncryption
       , forall qt. S3Configuration qt -> Bool
s3UseUri :: Bool
       , forall qt. S3Configuration qt -> NominalDiffTime
s3DefaultExpiry :: NominalDiffTime
       , forall qt. S3Configuration qt -> S3SignVersion
s3SignVersion :: S3SignVersion
       }
    deriving (Int -> S3Configuration qt -> ShowS
[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
$cshowsPrec :: forall qt. Int -> S3Configuration qt -> ShowS
showsPrec :: Int -> S3Configuration qt -> ShowS
$cshow :: forall qt. S3Configuration qt -> String
show :: S3Configuration qt -> String
$cshowList :: forall qt. [S3Configuration qt] -> ShowS
showList :: [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 :: forall qt. Protocol -> ByteString -> Bool -> S3Configuration qt
s3 Protocol
protocol ByteString
endpoint Bool
uri
    = S3Configuration
       { s3Protocol :: Protocol
s3Protocol = Protocol
protocol
       , s3Endpoint :: ByteString
s3Endpoint = ByteString
endpoint
       , s3Region :: Maybe ByteString
s3Region = Maybe ByteString
forall a. Maybe a
Nothing
       , 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 :: forall qt.
Protocol
-> ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt
s3v4 Protocol
protocol ByteString
endpoint Bool
uri S3SignPayloadMode
payload
    = S3Configuration
       { s3Protocol :: Protocol
s3Protocol = Protocol
protocol
       , s3Endpoint :: ByteString
s3Endpoint = ByteString
endpoint
       , s3Region :: Maybe ByteString
s3Region = Maybe ByteString
forall a. Maybe a
Nothing
       , 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 -> LocationConstraint
s3ErrorCode :: ErrorCode -- Error/Code
      , S3Error -> LocationConstraint
s3ErrorMessage :: T.Text -- Error/Message
      , S3Error -> Maybe LocationConstraint
s3ErrorResource :: Maybe T.Text -- Error/Resource
      , S3Error -> Maybe LocationConstraint
s3ErrorHostId :: Maybe T.Text -- Error/HostId
      , S3Error -> Maybe LocationConstraint
s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId
      , S3Error -> Maybe ByteString
s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding)
      , S3Error -> Maybe LocationConstraint
s3ErrorBucket :: Maybe T.Text -- Error/Bucket
      , S3Error -> Maybe LocationConstraint
s3ErrorEndpointRaw :: Maybe T.Text -- Error/Endpoint (i.e. correct bucket location)
      , S3Error -> Maybe ByteString
s3ErrorEndpoint :: Maybe B.ByteString -- Error/Endpoint without the bucket prefix
      }
    deriving (Int -> S3Error -> ShowS
[S3Error] -> ShowS
S3Error -> String
(Int -> S3Error -> ShowS)
-> (S3Error -> String) -> ([S3Error] -> ShowS) -> Show S3Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> S3Error -> ShowS
showsPrec :: Int -> S3Error -> ShowS
$cshow :: S3Error -> String
show :: S3Error -> String
$cshowList :: [S3Error] -> ShowS
showList :: [S3Error] -> ShowS
Show, Typeable)

instance C.Exception S3Error

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

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

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

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

instance Show S3Query where
    show :: S3Query -> String
show S3Query{Query
RequestHeaders
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
Method
s3QMethod :: S3Query -> Method
s3QBucket :: S3Query -> Maybe ByteString
s3QObject :: S3Query -> Maybe ByteString
s3QSubresources :: S3Query -> Query
s3QQuery :: S3Query -> Query
s3QContentType :: S3Query -> Maybe ByteString
s3QContentMd5 :: S3Query -> Maybe (Digest MD5)
s3QAmzHeaders :: S3Query -> RequestHeaders
s3QOtherHeaders :: S3Query -> RequestHeaders
s3QRequestBody :: S3Query -> Maybe RequestBody
s3QMethod :: Method
s3QBucket :: Maybe ByteString
s3QObject :: Maybe ByteString
s3QSubresources :: Query
s3QQuery :: Query
s3QContentType :: Maybe ByteString
s3QContentMd5 :: Maybe (Digest MD5)
s3QAmzHeaders :: RequestHeaders
s3QOtherHeaders :: RequestHeaders
s3QRequestBody :: Maybe RequestBody
..} = 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 :: forall qt.
S3Query -> S3Configuration qt -> SignatureData -> SignedQuery
s3SignQuery S3Query{Query
RequestHeaders
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
Method
s3QMethod :: S3Query -> Method
s3QBucket :: S3Query -> Maybe ByteString
s3QObject :: S3Query -> Maybe ByteString
s3QSubresources :: S3Query -> Query
s3QQuery :: S3Query -> Query
s3QContentType :: S3Query -> Maybe ByteString
s3QContentMd5 :: S3Query -> Maybe (Digest MD5)
s3QAmzHeaders :: S3Query -> RequestHeaders
s3QOtherHeaders :: S3Query -> RequestHeaders
s3QRequestBody :: S3Query -> Maybe RequestBody
s3QMethod :: Method
s3QBucket :: Maybe ByteString
s3QObject :: Maybe ByteString
s3QSubresources :: Query
s3QQuery :: Query
s3QContentType :: Maybe ByteString
s3QContentMd5 :: Maybe (Digest MD5)
s3QAmzHeaders :: RequestHeaders
s3QOtherHeaders :: RequestHeaders
s3QRequestBody :: Maybe RequestBody
..} S3Configuration{ s3SignVersion :: forall qt. S3Configuration qt -> S3SignVersion
s3SignVersion = S3SignVersion
S3SignV2, Bool
Int
Maybe ByteString
Maybe ServerSideEncryption
ByteString
NominalDiffTime
Protocol
RequestStyle
s3Protocol :: forall qt. S3Configuration qt -> Protocol
s3Endpoint :: forall qt. S3Configuration qt -> ByteString
s3Region :: forall qt. S3Configuration qt -> Maybe ByteString
s3RequestStyle :: forall qt. S3Configuration qt -> RequestStyle
s3Port :: forall qt. S3Configuration qt -> Int
s3ServerSideEncryption :: forall qt. S3Configuration qt -> Maybe ServerSideEncryption
s3UseUri :: forall qt. S3Configuration qt -> Bool
s3DefaultExpiry :: forall qt. S3Configuration qt -> NominalDiffTime
s3Protocol :: Protocol
s3Endpoint :: ByteString
s3Region :: Maybe ByteString
s3RequestStyle :: RequestStyle
s3Port :: Int
s3ServerSideEncryption :: Maybe ServerSideEncryption
s3UseUri :: Bool
s3DefaultExpiry :: NominalDiffTime
.. } SignatureData{UTCTime
AbsoluteTimeInfo
Credentials
signatureTimeInfo :: AbsoluteTimeInfo
signatureTime :: UTCTime
signatureCredentials :: Credentials
signatureTimeInfo :: SignatureData -> AbsoluteTimeInfo
signatureTime :: SignatureData -> UTCTime
signatureCredentials :: SignatureData -> Credentials
..}
    = 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
      -- This also implements anonymous queries.
      isanon :: Bool
isanon = Credentials -> Bool
isAnonymousCredentials Credentials
signatureCredentials 
      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 -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ RequestHeaders
s3QAmzHeaders RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. [a] -> [a] -> [a]
++ 
        if Bool
isanon 
          then []
          else ((ByteString, ByteString) -> (HeaderName, ByteString))
-> [(ByteString, ByteString)] -> RequestHeaders
forall a b. (a -> b) -> [a] -> [b]
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. Eq a => a -> [a] -> 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
_
                                        | Bool
isanon -> (Maybe (IO ByteString)
forall a. Maybe a
Nothing, [])
                                        | Bool
otherwise -> (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 a. a -> IO a
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
        | Bool
isanon = []
        | Bool
otherwise = 
                [ (ByteString
"Expires" :: B8.ByteString, UTCTime -> ByteString
fmtTimeEpochSeconds UTCTime
time)
                , (ByteString
"AWSAccessKeyId", Credentials -> ByteString
accessKeyID Credentials
signatureCredentials)
                , (ByteString
"SignatureMethod", ByteString
"HmacSHA256")
                , (ByteString
"Signature", ByteString
sig)] [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
iamTok
s3SignQuery sq :: S3Query
sq@S3Query{Query
RequestHeaders
Maybe ByteString
Maybe (Digest MD5)
Maybe RequestBody
Method
s3QMethod :: S3Query -> Method
s3QBucket :: S3Query -> Maybe ByteString
s3QObject :: S3Query -> Maybe ByteString
s3QSubresources :: S3Query -> Query
s3QQuery :: S3Query -> Query
s3QContentType :: S3Query -> Maybe ByteString
s3QContentMd5 :: S3Query -> Maybe (Digest MD5)
s3QAmzHeaders :: S3Query -> RequestHeaders
s3QOtherHeaders :: S3Query -> RequestHeaders
s3QRequestBody :: S3Query -> Maybe RequestBody
s3QMethod :: Method
s3QBucket :: Maybe ByteString
s3QObject :: Maybe ByteString
s3QSubresources :: Query
s3QQuery :: Query
s3QContentType :: Maybe ByteString
s3QContentMd5 :: Maybe (Digest MD5)
s3QAmzHeaders :: RequestHeaders
s3QOtherHeaders :: RequestHeaders
s3QRequestBody :: Maybe RequestBody
..} sc :: S3Configuration qt
sc@S3Configuration{ s3SignVersion :: forall qt. S3Configuration qt -> S3SignVersion
s3SignVersion = S3SignV4 S3SignPayloadMode
signpayload, Bool
Int
Maybe ByteString
Maybe ServerSideEncryption
ByteString
NominalDiffTime
Protocol
RequestStyle
s3Protocol :: forall qt. S3Configuration qt -> Protocol
s3Endpoint :: forall qt. S3Configuration qt -> ByteString
s3Region :: forall qt. S3Configuration qt -> Maybe ByteString
s3RequestStyle :: forall qt. S3Configuration qt -> RequestStyle
s3Port :: forall qt. S3Configuration qt -> Int
s3ServerSideEncryption :: forall qt. S3Configuration qt -> Maybe ServerSideEncryption
s3UseUri :: forall qt. S3Configuration qt -> Bool
s3DefaultExpiry :: forall qt. S3Configuration qt -> NominalDiffTime
s3Protocol :: Protocol
s3Endpoint :: ByteString
s3Region :: Maybe ByteString
s3RequestStyle :: RequestStyle
s3Port :: Int
s3ServerSideEncryption :: Maybe ServerSideEncryption
s3UseUri :: Bool
s3DefaultExpiry :: NominalDiffTime
.. } sd :: SignatureData
sd@SignatureData{UTCTime
AbsoluteTimeInfo
Credentials
signatureTimeInfo :: SignatureData -> AbsoluteTimeInfo
signatureTime :: SignatureData -> UTCTime
signatureCredentials :: SignatureData -> Credentials
signatureTimeInfo :: AbsoluteTimeInfo
signatureTime :: UTCTime
signatureCredentials :: Credentials
..}
    | Credentials -> Bool
isAnonymousCredentials Credentials
signatureCredentials =
      S3Query -> S3Configuration Any -> SignatureData -> SignedQuery
forall qt.
S3Query -> S3Configuration qt -> SignatureData -> SignedQuery
s3SignQuery S3Query
sq (S3Configuration qt
sc { s3SignVersion = S3SignV2 }) SignatureData
sd
    | Bool
otherwise = SignedQuery
      { sqMethod :: Method
sqMethod = Method
s3QMethod
      , sqProtocol :: Protocol
sqProtocol = Protocol
s3Protocol
      , sqHost :: ByteString
sqHost = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"." ([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 a b. (a -> b) -> Maybe a -> Maybe b
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 b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first 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 b. Integral b => NominalDiffTime -> b
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 -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> ByteString
s3ExtractRegion ByteString
s3Endpoint) Maybe ByteString
s3Region
                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 a. Eq a => a -> [a] -> 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 => 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
"="

-- | Extract a S3 region from the S3 endpoint. AWS encodes the region names
-- in the hostnames of endpoints in a way that makes this possible,
-- see: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>
-- For other S3 implementations, may instead need to specify s3Region.
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 a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
Atto.string ByteString
"-" Parser ByteString -> Parser ByteString -> Parser ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8]
r

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

s3BinaryResponseConsumer :: HTTPResponseConsumer a
                   -> IORef S3Metadata
                   -> HTTPResponseConsumer a
s3BinaryResponseConsumer :: forall a.
HTTPResponseConsumer a
-> IORef S3Metadata -> HTTPResponseConsumer a
s3BinaryResponseConsumer HTTPResponseConsumer a
inner IORef S3Metadata
metadata Response (ConduitM () ByteString (ResourceT IO) ())
resp = do
      let headerString :: HeaderName -> Maybe LocationConstraint
headerString = (ByteString -> LocationConstraint)
-> Maybe ByteString -> Maybe LocationConstraint
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> LocationConstraint
T.decodeUtf8 (Maybe ByteString -> Maybe LocationConstraint)
-> (HeaderName -> Maybe ByteString)
-> HeaderName
-> Maybe LocationConstraint
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 LocationConstraint
amzId2 = HeaderName -> Maybe LocationConstraint
headerString HeaderName
"x-amz-id-2"
      let requestId :: Maybe LocationConstraint
requestId = HeaderName -> Maybe LocationConstraint
headerString HeaderName
"x-amz-request-id"

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

type CanonicalUserId = T.Text

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

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

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

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

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

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

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

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

parseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption
parseServerSideEncryption :: forall (m :: * -> *).
MonadThrow m =>
LocationConstraint -> m ServerSideEncryption
parseServerSideEncryption LocationConstraint
"AES256" = ServerSideEncryption -> m ServerSideEncryption
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerSideEncryption
AES256
parseServerSideEncryption LocationConstraint
s = XmlException -> m ServerSideEncryption
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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]
++ LocationConstraint -> String
T.unpack LocationConstraint
s

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

type Bucket = T.Text

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

type Object = T.Text

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

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

parseObjectVersionInfo :: MonadThrow m => Cu.Cursor -> m ObjectVersionInfo
parseObjectVersionInfo :: forall (m :: * -> *). MonadThrow m => Cursor -> m ObjectVersionInfo
parseObjectVersionInfo Cursor
el
    = do LocationConstraint
key <- String -> [LocationConstraint] -> m LocationConstraint
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object Key" ([LocationConstraint] -> m LocationConstraint)
-> [LocationConstraint] -> m LocationConstraint
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [LocationConstraint]) -> [LocationConstraint]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Key"
         LocationConstraint
versionId <- String -> [LocationConstraint] -> m LocationConstraint
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object VersionId" ([LocationConstraint] -> m LocationConstraint)
-> [LocationConstraint] -> m LocationConstraint
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [LocationConstraint]) -> [LocationConstraint]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"IsLatest" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m Bool) -> Cursor -> [m Bool]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| LocationConstraint -> m Bool
forall (m :: * -> *). MonadThrow m => LocationConstraint -> m Bool
textReadBool
         let time :: LocationConstraint -> m a
time LocationConstraint
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
$ LocationConstraint -> String
T.unpack LocationConstraint
s) Maybe a -> Maybe a -> Maybe a
forall a. 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
$ LocationConstraint -> String
T.unpack LocationConstraint
s) of
                        Maybe a
Nothing -> XmlException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid time"
                        Just a
v -> a -> m a
forall a. 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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"LastModified" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m UTCTime) -> Cursor -> [m UTCTime]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| LocationConstraint -> m UTCTime
forall {a} {m :: * -> *}.
(ParseTime a, MonadThrow m) =>
LocationConstraint -> m a
time
         Maybe UserInfo
owner <- case Cursor
el Cursor -> (Cursor -> [m UserInfo]) -> [m UserInfo]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Axis
Cu.laxElement LocationConstraint
"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 a. a -> m a
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 -> LocationConstraint
elName Element
e LocationConstraint -> LocationConstraint -> Bool
forall a. Eq a => a -> a -> Bool
== LocationConstraint
"Version" ->
             do LocationConstraint
eTag <- String -> [LocationConstraint] -> m LocationConstraint
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object ETag" ([LocationConstraint] -> m LocationConstraint)
-> [LocationConstraint] -> m LocationConstraint
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [LocationConstraint]) -> [LocationConstraint]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Size" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m Integer) -> Cursor -> [m Integer]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| LocationConstraint -> m Integer
forall (m :: * -> *) a.
(MonadThrow m, Num a) =>
LocationConstraint -> 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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"StorageClass" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m StorageClass)
-> Cursor
-> [m StorageClass]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| StorageClass -> m StorageClass
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StorageClass -> m StorageClass)
-> (LocationConstraint -> StorageClass)
-> LocationConstraint
-> m StorageClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocationConstraint -> StorageClass
parseStorageClass
                ObjectVersionInfo -> m ObjectVersionInfo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectVersion{
                             oviKey :: LocationConstraint
oviKey          = LocationConstraint
key
                           , oviVersionId :: LocationConstraint
oviVersionId    = LocationConstraint
versionId
                           , oviIsLatest :: Bool
oviIsLatest     = Bool
isLatest
                           , oviLastModified :: UTCTime
oviLastModified = UTCTime
lastModified
                           , oviETag :: LocationConstraint
oviETag         = LocationConstraint
eTag
                           , oviSize :: Integer
oviSize         = Integer
size
                           , oviStorageClass :: StorageClass
oviStorageClass = StorageClass
storageClass
                           , oviOwner :: Maybe UserInfo
oviOwner        = Maybe UserInfo
owner
                           }
           XML.NodeElement Element
e | Element -> LocationConstraint
elName Element
e LocationConstraint -> LocationConstraint -> Bool
forall a. Eq a => a -> a -> Bool
== LocationConstraint
"DeleteMarker" ->
             ObjectVersionInfo -> m ObjectVersionInfo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DeleteMarker{
                             oviKey :: LocationConstraint
oviKey          = LocationConstraint
key
                           , oviVersionId :: LocationConstraint
oviVersionId    = LocationConstraint
versionId
                           , oviIsLatest :: Bool
oviIsLatest     = Bool
isLatest
                           , oviLastModified :: UTCTime
oviLastModified = UTCTime
lastModified
                           , oviOwner :: Maybe UserInfo
oviOwner        = Maybe UserInfo
owner
                           }
           Node
_ -> XmlException -> m ObjectVersionInfo
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 -> LocationConstraint
elName = Name -> LocationConstraint
XML.nameLocalName (Name -> LocationConstraint)
-> (Element -> Name) -> Element -> LocationConstraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
XML.elementName
      fmap' :: Monad m => (a -> b) -> m a -> m b
      fmap' :: forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' a -> b
f m a
ma = m a
ma m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
forall a. a -> m a
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 -> LocationConstraint
objectKey          :: T.Text
      , ObjectInfo -> UTCTime
objectLastModified :: UTCTime
      , ObjectInfo -> LocationConstraint
objectETag         :: T.Text
      , ObjectInfo -> Integer
objectSize         :: Integer
      , ObjectInfo -> StorageClass
objectStorageClass :: StorageClass
      , ObjectInfo -> Maybe UserInfo
objectOwner        :: Maybe UserInfo
      }
    deriving (Int -> ObjectInfo -> ShowS
[ObjectInfo] -> ShowS
ObjectInfo -> String
(Int -> ObjectInfo -> ShowS)
-> (ObjectInfo -> String)
-> ([ObjectInfo] -> ShowS)
-> Show ObjectInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ObjectInfo -> ShowS
showsPrec :: Int -> ObjectInfo -> ShowS
$cshow :: ObjectInfo -> String
show :: ObjectInfo -> String
$cshowList :: [ObjectInfo] -> ShowS
showList :: [ObjectInfo] -> ShowS
Show)

parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo
parseObjectInfo :: forall (m :: * -> *). MonadThrow m => Cursor -> m ObjectInfo
parseObjectInfo Cursor
el
    = do LocationConstraint
key <- String -> [LocationConstraint] -> m LocationConstraint
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object Key" ([LocationConstraint] -> m LocationConstraint)
-> [LocationConstraint] -> m LocationConstraint
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [LocationConstraint]) -> [LocationConstraint]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Key"
         let time :: LocationConstraint -> m a
time LocationConstraint
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
$ LocationConstraint -> String
T.unpack LocationConstraint
s) Maybe a -> Maybe a -> Maybe a
forall a. 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
$ LocationConstraint -> String
T.unpack LocationConstraint
s) of
                        Maybe a
Nothing -> XmlException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (XmlException -> m a) -> XmlException -> m a
forall a b. (a -> b) -> a -> b
$ String -> XmlException
XmlException String
"Invalid time"
                        Just a
v -> a -> m a
forall a. 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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"LastModified" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m UTCTime) -> Cursor -> [m UTCTime]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| LocationConstraint -> m UTCTime
forall {a} {m :: * -> *}.
(ParseTime a, MonadThrow m) =>
LocationConstraint -> m a
time
         LocationConstraint
eTag <- String -> [LocationConstraint] -> m LocationConstraint
forall (m :: * -> *) a. MonadThrow m => String -> [a] -> m a
force String
"Missing object ETag" ([LocationConstraint] -> m LocationConstraint)
-> [LocationConstraint] -> m LocationConstraint
forall a b. (a -> b) -> a -> b
$ Cursor
el Cursor -> (Cursor -> [LocationConstraint]) -> [LocationConstraint]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"Size" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m Integer) -> Cursor -> [m Integer]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| LocationConstraint -> m Integer
forall (m :: * -> *) a.
(MonadThrow m, Num a) =>
LocationConstraint -> 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]
$/ LocationConstraint -> Cursor -> [LocationConstraint]
elContent LocationConstraint
"StorageClass" (Cursor -> [LocationConstraint])
-> (LocationConstraint -> m StorageClass)
-> Cursor
-> [m StorageClass]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| StorageClass -> m StorageClass
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StorageClass -> m StorageClass)
-> (LocationConstraint -> StorageClass)
-> LocationConstraint
-> m StorageClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocationConstraint -> StorageClass
parseStorageClass
         Maybe UserInfo
owner <- case Cursor
el Cursor -> (Cursor -> [m UserInfo]) -> [m UserInfo]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ LocationConstraint -> Axis
Cu.laxElement LocationConstraint
"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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserInfo
forall a. Maybe a
Nothing
         ObjectInfo -> m ObjectInfo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ObjectInfo{
                      objectKey :: LocationConstraint
objectKey          = LocationConstraint
key
                    , objectLastModified :: UTCTime
objectLastModified = UTCTime
lastModified
                    , objectETag :: LocationConstraint
objectETag         = LocationConstraint
eTag
                    , objectSize :: Integer
objectSize         = Integer
size
                    , objectStorageClass :: StorageClass
objectStorageClass = StorageClass
storageClass
                    , objectOwner :: Maybe UserInfo
objectOwner        = Maybe UserInfo
owner
                    }
    where
      fmap' :: Monad m => (a -> b) -> m a -> m b
      fmap' :: forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
fmap' a -> b
f m a
ma = m a
ma m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
forall a. a -> m a
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 -> LocationConstraint
omETag                 :: T.Text
      , ObjectMetadata -> UTCTime
omLastModified         :: UTCTime
      , ObjectMetadata -> Maybe LocationConstraint
omVersionId            :: Maybe T.Text
-- TODO:
--      , omExpiration           :: Maybe (UTCTime, T.Text)
      , ObjectMetadata -> [(LocationConstraint, LocationConstraint)]
omUserMetadata         :: [(T.Text, T.Text)]
      , ObjectMetadata -> Maybe LocationConstraint
omMissingUserMetadata  :: Maybe T.Text
      , ObjectMetadata -> Maybe ServerSideEncryption
omServerSideEncryption :: Maybe ServerSideEncryption
      }
    deriving (Int -> ObjectMetadata -> ShowS
[ObjectMetadata] -> ShowS
ObjectMetadata -> String
(Int -> ObjectMetadata -> ShowS)
-> (ObjectMetadata -> String)
-> ([ObjectMetadata] -> ShowS)
-> Show ObjectMetadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ObjectMetadata -> ShowS
showsPrec :: Int -> ObjectMetadata -> ShowS
$cshow :: ObjectMetadata -> String
show :: ObjectMetadata -> String
$cshowList :: [ObjectMetadata] -> ShowS
showList :: [ObjectMetadata] -> ShowS
Show)

parseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata
parseObjectMetadata :: forall (m :: * -> *).
MonadThrow m =>
RequestHeaders -> m ObjectMetadata
parseObjectMetadata RequestHeaders
h = Bool
-> LocationConstraint
-> UTCTime
-> Maybe LocationConstraint
-> [(LocationConstraint, LocationConstraint)]
-> Maybe LocationConstraint
-> Maybe ServerSideEncryption
-> ObjectMetadata
ObjectMetadata
                        (Bool
 -> LocationConstraint
 -> UTCTime
 -> Maybe LocationConstraint
 -> [(LocationConstraint, LocationConstraint)]
 -> Maybe LocationConstraint
 -> Maybe ServerSideEncryption
 -> ObjectMetadata)
-> m Bool
-> m (LocationConstraint
      -> UTCTime
      -> Maybe LocationConstraint
      -> [(LocationConstraint, LocationConstraint)]
      -> Maybe LocationConstraint
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
`liftM` m Bool
deleteMarker
                        m (LocationConstraint
   -> UTCTime
   -> Maybe LocationConstraint
   -> [(LocationConstraint, LocationConstraint)]
   -> Maybe LocationConstraint
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m LocationConstraint
-> m (UTCTime
      -> Maybe LocationConstraint
      -> [(LocationConstraint, LocationConstraint)]
      -> Maybe LocationConstraint
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m LocationConstraint
etag
                        m (UTCTime
   -> Maybe LocationConstraint
   -> [(LocationConstraint, LocationConstraint)]
   -> Maybe LocationConstraint
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m UTCTime
-> m (Maybe LocationConstraint
      -> [(LocationConstraint, LocationConstraint)]
      -> Maybe LocationConstraint
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` m UTCTime
lastModified
                        m (Maybe LocationConstraint
   -> [(LocationConstraint, LocationConstraint)]
   -> Maybe LocationConstraint
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m (Maybe LocationConstraint)
-> m ([(LocationConstraint, LocationConstraint)]
      -> Maybe LocationConstraint
      -> Maybe ServerSideEncryption
      -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Maybe LocationConstraint -> m (Maybe LocationConstraint)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocationConstraint
versionId
--                        `ap` expiration
                        m ([(LocationConstraint, LocationConstraint)]
   -> Maybe LocationConstraint
   -> Maybe ServerSideEncryption
   -> ObjectMetadata)
-> m [(LocationConstraint, LocationConstraint)]
-> m (Maybe LocationConstraint
      -> Maybe ServerSideEncryption -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` [(LocationConstraint, LocationConstraint)]
-> m [(LocationConstraint, LocationConstraint)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(LocationConstraint, LocationConstraint)]
userMetadata
                        m (Maybe LocationConstraint
   -> Maybe ServerSideEncryption -> ObjectMetadata)
-> m (Maybe LocationConstraint)
-> m (Maybe ServerSideEncryption -> ObjectMetadata)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Maybe LocationConstraint -> m (Maybe LocationConstraint)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocationConstraint
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         Just String
"true" -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         Just String
"false" -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                         Just String
x -> HeaderException -> m Bool
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 LocationConstraint
etag = case ByteString -> LocationConstraint
T.decodeUtf8 (ByteString -> LocationConstraint)
-> Maybe ByteString -> Maybe LocationConstraint
forall a b. (a -> b) -> Maybe a -> Maybe b
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 LocationConstraint
x -> LocationConstraint -> m LocationConstraint
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LocationConstraint
x
                 Maybe LocationConstraint
Nothing -> HeaderException -> m LocationConstraint
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (HeaderException -> m LocationConstraint)
-> HeaderException -> m LocationConstraint
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
                                      Maybe UTCTime
Nothing -> HeaderException -> m UTCTime
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 LocationConstraint
versionId = ByteString -> LocationConstraint
T.decodeUtf8 (ByteString -> LocationConstraint)
-> Maybe ByteString -> Maybe LocationConstraint
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: [(LocationConstraint, LocationConstraint)]
userMetadata = (((LocationConstraint, LocationConstraint)
  -> Maybe (LocationConstraint, LocationConstraint))
 -> [(LocationConstraint, LocationConstraint)]
 -> [(LocationConstraint, LocationConstraint)])
-> [(LocationConstraint, LocationConstraint)]
-> ((LocationConstraint, LocationConstraint)
    -> Maybe (LocationConstraint, LocationConstraint))
-> [(LocationConstraint, LocationConstraint)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((LocationConstraint, LocationConstraint)
 -> Maybe (LocationConstraint, LocationConstraint))
-> [(LocationConstraint, LocationConstraint)]
-> [(LocationConstraint, LocationConstraint)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(LocationConstraint, LocationConstraint)]
ht (((LocationConstraint, LocationConstraint)
  -> Maybe (LocationConstraint, LocationConstraint))
 -> [(LocationConstraint, LocationConstraint)])
-> ((LocationConstraint, LocationConstraint)
    -> Maybe (LocationConstraint, LocationConstraint))
-> [(LocationConstraint, LocationConstraint)]
forall a b. (a -> b) -> a -> b
$
                       \(LocationConstraint
k, LocationConstraint
v) -> do LocationConstraint
i <- LocationConstraint
-> LocationConstraint -> Maybe LocationConstraint
T.stripPrefix LocationConstraint
"x-amz-meta-" LocationConstraint
k
                                     (LocationConstraint, LocationConstraint)
-> Maybe (LocationConstraint, LocationConstraint)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocationConstraint
i, LocationConstraint
v)
        missingUserMetadata :: Maybe LocationConstraint
missingUserMetadata = ByteString -> LocationConstraint
T.decodeUtf8 (ByteString -> LocationConstraint)
-> Maybe ByteString -> Maybe LocationConstraint
forall a b. (a -> b) -> Maybe a -> Maybe b
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 -> LocationConstraint
T.decodeUtf8 (ByteString -> LocationConstraint)
-> Maybe ByteString -> Maybe LocationConstraint
forall a b. (a -> b) -> Maybe a -> Maybe b
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 LocationConstraint
x -> Maybe ServerSideEncryption -> m (Maybe ServerSideEncryption)
forall a. a -> m a
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
$ LocationConstraint -> Maybe ServerSideEncryption
forall (m :: * -> *).
MonadThrow m =>
LocationConstraint -> m ServerSideEncryption
parseServerSideEncryption LocationConstraint
x
                                 Maybe LocationConstraint
Nothing -> Maybe ServerSideEncryption -> m (Maybe ServerSideEncryption)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ServerSideEncryption
forall a. Maybe a
Nothing

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

type LocationConstraint = T.Text

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

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