S3-0.1.0.0: src/Network/S3.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-
Copyright (c) 2016-2019 Herbert Valerio Riedel <hvr@gnu.org>
This file is free software: you may copy, redistribute and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation, either version 3 of the License, or (at your
option) any later version.
This file is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program (see `LICENSE`). If not, see
<https://www.gnu.org/licenses/gpl-3.0.html>.
-}
-- |
-- Copyright: © Herbert Valerio Riedel 2016-2019
-- SPDX-License-Identifier: GPL-3.0-or-later
--
-- Simple lightweight S3 API implementation
--
-- This implementation has been tested succesfully against MinIO's, Dreamhost's, and AWS' S3 server implementations
--
-- == API Usage Example
--
-- The example below shows how to create, populate, list, and finally destroy a bucket again.
--
-- @
-- -- demo credentials for http://play.min.io/
-- let s3cfg = 'defaultS3Cfg' { 's3cfgBaseUrl' = \"https://play.min.io:9000\" }
-- creds = 'Credentials' \"Q3AM3UQ867SPQQA43P2F\" \"zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG\"
--
-- -- we'll create this bucket and delete it again
-- let testBucket = 'BucketId' "haskell-test-bucket-42"
--
-- 'withConnection' s3cfg $ \conn -> do
-- 'createBucket' conn creds testBucket Nothing
--
-- etag1 <- 'putObject' conn creds testBucket ('ObjKey' \"folder\/file1\") \"content1\" (CType \"text\/plain\") Nothing
-- etag2 <- 'putObject' conn creds testBucket ('ObjKey' \"file2\") \"content2\" (CType \"text\/plain\") Nothing
--
-- -- will list the key \"file2\" and the common-prefix \"folder\/\"
-- print =<< 'listObjects' conn creds testBucket 'nullObjKey' (Just \'\/\')
-- -- will list only the key \"folder\/file1\"
-- print =<< 'listObjects' conn creds testBucket ('ObjKey' \"folder\/\") (Just \'\/\')
-- -- will list the two keys \"folder\/file1\" and \"file2\" (and no common prefix)
-- print =<< 'listObjects' conn creds testBucket 'nullObjKey' Nothing
--
-- -- ...and now we remove the two objects we created above
-- 'deleteObject' conn creds testBucket ('ObjKey' \"folder\/file1\")
-- 'deleteObject' conn creds testBucket ('ObjKey' \"file2\")
--
-- 'deleteBucket' conn creds testBucket
-- @
--
module Network.S3
( -- * Operations on Buckets
BucketId(..)
, BucketInfo(..)
, Acl(..)
, listBuckets
, createBucket
, deleteBucket
, listObjects
, listObjectsFold
, listObjectsChunk
-- * Operations on Objects
-- ** Object keys
, ObjKey(..), isNullObjKey, nullObjKey
-- ** Object metadata
, ObjMetaInfo(..)
, CType(..), noCType
, ETag(..)
-- *** MD5 hashes
, MD5Val
, md5hash
, md5hex
, md5unhex
, md5ToSBS
, md5FromSBS
-- ** Operations
, putObject
, copyObject
, getObject
, deleteObject
-- ** Conditional operations
, Condition(..)
, putObjectCond
, getObjectCond
, deleteObjectCond
-- * Errors
, ErrorCode(..)
, ProtocolError(..)
-- * Authentication
, Credentials(..), noCredentials
-- * Connection handling
, S3Cfg(..), defaultS3Cfg
, SignatureVersion(..)
, Connection
, withConnection
, connect
, close
) where
import Internal
import Network.S3.Signature
import Network.S3.Types
import Network.S3.XML
import Control.Concurrent
import Control.Exception
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as BSS
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Short as TS
import Data.Time.Clock (getCurrentTime)
import qualified Network.Http.Client as HC
import qualified System.IO.Streams as Streams
import qualified Text.XML as X
-- | Protocol-level errors and exceptions
data ProtocolError
= ProtocolInconsistency String
| HttpFailure !SomeException
| UnexpectedResponse {- code -} !Int
{- message -} !ShortByteString
{- content-type -} !ShortByteString
{- body -} BL.ByteString
deriving (Show, Typeable, Generic)
instance Exception ProtocolError
-- | S3-level errors
data ErrorCode
= AccessDenied
| BucketAlreadyExists -- not owned by you
| BucketAlreadyOwnedByYou
| BucketNotEmpty
| MalformedXML
| NoSuchBucket
| NoSuchKey
| InvalidArgument
| InvalidDigest
| SignatureDoesNotMatch
| UnknownError !ShortText
deriving (Show, Typeable, Generic)
instance Exception ErrorCode
instance NFData ErrorCode
errorToErrorCode :: Error -> ErrorCode
errorToErrorCode (Error x) = case x of
"AccessDenied" -> AccessDenied
"BucketAlreadyExists" -> BucketAlreadyExists
"BucketAlreadyOwnedByYou" -> BucketAlreadyOwnedByYou
"BucketNotEmpty" -> BucketNotEmpty
"MalformedXML" -> MalformedXML
"NoSuchBucket" -> NoSuchBucket
"NoSuchKey" -> NoSuchKey
"InvalidArgument" -> InvalidArgument
"InvalidDigest" -> InvalidDigest
"SignatureDoesNotMatch" -> SignatureDoesNotMatch
_ -> UnknownError x
urlEncodeObjKey, urlEncodeObjKeyQry :: ObjKey -> ByteString
urlEncodeObjKey = urlEncode False . TS.toByteString . unObjKey
urlEncodeObjKeyQry = urlEncode True . TS.toByteString . unObjKey
s3'ObjKey :: X.LName -> Bool -> X.Element -> Either String ObjKey
s3'ObjKey ln False el = ObjKey <$> xsd'string (s3qname ln) el
s3'ObjKey ln True el = do
s <- xsd'string (s3qname ln) el
case TS.fromText <$> urlDecodeTextUtf8 s of
Just s' -> pure (ObjKey s')
Nothing -> Left ("<" <> showQN (X.elName el) <> "> failed to url-decode ObjKey")
objUrlPath :: BucketId -> ObjKey -> UrlPath
objUrlPath (BucketId bucketId) objkey = "/" <> BSS.fromShort bucketId <> "/" <> urlEncodeObjKey objkey
bucketUrlPath :: BucketId -> UrlPath
bucketUrlPath (BucketId bucketId) = "/" <> BSS.fromShort bucketId
withAWSHeaders :: Connection -> (AWSHeaders -> IO b) -> IO b
withAWSHeaders conn cont = do
now <- getCurrentTime
cont AWSHeaders
{ ahdrMethod = HC.GET
, ahdrUrlPath = "/"
, ahdrUrlQuery = mempty
, ahdrTimestamp = now
, ahdrContentType = noCType
, ahdrContentHashes = Nothing
, ahdrExtraHeaders = []
, ahdrSigType = s3cfgSigVersion $ s3connCfg conn
, ahdrHost = s3connHost conn
, ahdrRegion = s3cfgRegion $ s3connCfg conn
}
-- | List buckets owned by user
listBuckets :: Connection
-> Credentials
-> IO [BucketInfo]
listBuckets conn creds = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.GET
, ahdrUrlPath = "/"
}
(resp,mtmp) <- doHttpReqXml conn q HC.emptyBody
case HC.getStatusCode resp of
200 -> pure ()
_ -> throwUnexpectedXmlResp resp mtmp
case maybe (Left "empty body") parseXML mtmp of
Right (ListAllMyBucketsResult bs) -> pure bs
Left err -> throwProtoFail $ "ListAllMyBucketsResult: " <> err
-- | Create bucket
createBucket :: Connection
-> Credentials
-> BucketId
-> Maybe Acl
-> IO ()
createBucket conn creds bid macl = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.PUT
, ahdrUrlPath = bucketUrlPath bid
, ahdrExtraHeaders = hdrs
}
(resp, mtmp) <- doHttpReqXml conn q HC.emptyBody
case HC.getStatusCode resp of
200 -> pure ()
_ -> throwUnexpectedXmlResp resp mtmp
where
hdrs = case macl of
Nothing -> []
Just acl -> [("x-amz-acl", acl2str acl)]
-- | Delete bucket
--
-- __NOTE__: Most S3 implementations require the bucket to be empty before it can be deleted. See documentation of 'listObjectsFold' for a code example deleting a non-empty bucket.
deleteBucket :: Connection
-> Credentials
-> BucketId
-> IO ()
deleteBucket conn creds bid = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.DELETE
, ahdrUrlPath = bucketUrlPath bid
}
(resp, mtmp) <- doHttpReqXml conn q HC.emptyBody
case HC.getStatusCode resp of
204 -> pure ()
_ -> throwUnexpectedXmlResp resp mtmp
pure ()
----------------------------------------------------------------------------
-- | Represents a single-threaded HTTP channel to the S3 service
data Connection = S3Conn (MVar HC.Connection) !ByteString !S3Cfg
s3connCfg :: Connection -> S3Cfg
s3connCfg (S3Conn _ _ cfg) = cfg
s3connHost :: Connection -> ByteString
s3connHost (S3Conn _ h _) = h
-- | Simple single-connection 'bracket' style combinator over 'connect' and 'close'
--
-- If you need resource pool management you can use 'connect' in combination with packages such as [resource-pool](http://hackage.haskell.org/package/resource-pool).
withConnection :: S3Cfg -> (Connection -> IO a) -> IO a
withConnection cfg@S3Cfg{..} = bracket (connect cfg) close
-- | Create HTTP(s) connection based on 'S3Cfg'
connect :: S3Cfg -> IO Connection
connect cfg@S3Cfg{..} = do
c <- HC.establishConnection s3cfgBaseUrl
c' <- newMVar c
pure (S3Conn c' (cHost c) cfg)
-- | Close connection constructed via 'connect'
close :: Connection -> IO ()
close (S3Conn cref _ _) = withMVar cref HC.closeConnection
cHost :: HC.Connection -> ByteString
cHost c = HC.getHostname c (HC.buildRequest1 (pure ()))
-- low-level helper
doHttpReq :: Bool -> Connection -> HC.Request
-> (Streams.OutputStream Builder.Builder -> IO ())
-> IO (HC.Response, BL.ByteString)
doHttpReq isProtocol (S3Conn cref _ S3Cfg{..}) q body = withMVar cref $ \c -> do
when s3cfgDebug $ do
BS.putStrLn sep1
T.putStr (T.pack $ show q)
BS.putStrLn sep2
(resp,bs) <- handle exh $ do
() <- HC.sendRequest c q body
HC.receiveResponse c concatHandler
when s3cfgDebug $ do
T.putStr (T.pack $ show resp)
unless (BL.null bs) $ do
BS.putStrLn sep2
if isProtocol || HC.getStatusCode resp /= 200
then BL.putStrLn bs
else T.putStrLn (T.pack $ "[non-protocol body with size=" <> show (BL.length bs) <> "]")
BS.putStrLn sep3
pure (resp, bs)
where
sep1 = "/==========================================================================\\"
sep2 = "----------------------------------------------------------------------------"
sep3 = "\\==========================================================================/"
exh ex = throwIO (HttpFailure ex)
concatHandler :: HC.Response -> Streams.InputStream ByteString -> IO (HC.Response,BL.ByteString)
concatHandler res i1 = do
xs <- Streams.toList i1
return (res, BL.fromChunks xs)
doHttpReqXml :: Connection -> HC.Request
-> (Streams.OutputStream Builder.Builder -> IO ())
-> IO (HC.Response, Maybe X.Element)
doHttpReqXml cn rq body = do
(resp,bs) <- doHttpReq True cn rq body
case fromMaybe mempty $ HC.getHeader resp "content-type" of
ct | isXmlMimeType ct -> do
txt <- either (\_ -> throwProtoFail "failed to decode UTF-8 content from server") pure (TL.decodeUtf8' bs)
case X.parseXMLRoot txt of
Left _ -> throwProtoFail "received malformed XML response from server"
Right x -> pure (resp,Just $! X.rootElement x)
| HC.getStatusCode resp == 204 -> pure (resp, Nothing)
| HC.getStatusCode resp == 200, BL.null bs -> pure (resp, Nothing)
| otherwise -> throwUnexpectedResp resp bs
getCT :: HC.Response -> CType
getCT resp = case HC.getHeader resp "Content-Type" of
Nothing -> noCType
Just bs -> maybe noCType CType (TS.fromByteString bs)
-- c.f. RFC 7303
isXmlMimeType :: ByteString -> Bool
isXmlMimeType bs = case type_subtype of
"application/xml" -> True
"text/xml" -> True
_ -> False
where
type_subtype = BC8.map toLower $ BC8.takeWhile (not . \c -> isSpace c || c == ';') bs
throwUnexpectedResp :: HC.Response -> BL.ByteString -> IO a
throwUnexpectedResp resp bs
= case fromMaybe mempty $ HC.getHeader resp "Content-Type" of
ct | isXmlMimeType ct
, Right e <- decodeXML bs -> throwIO $! errorToErrorCode e
| otherwise -> genEx ct
where
genEx ct = throwIO $! UnexpectedResponse (HC.getStatusCode resp) (BSS.toShort $ HC.getStatusMessage resp) (BSS.toShort ct) bs
throwUnexpectedXmlResp :: HC.Response -> Maybe X.Element -> IO a
throwUnexpectedXmlResp resp Nothing
= throwIO $! UnexpectedResponse (HC.getStatusCode resp)
(BSS.toShort $ HC.getStatusMessage resp)
(maybe mempty BSS.toShort $ HC.getHeader resp "Content-Type")
mempty
throwUnexpectedXmlResp resp (Just x) = case parseXML x of
Right e -> throwIO $! errorToErrorCode e
Left _ -> genEx
where
genEx = throwIO $! UnexpectedResponse (HC.getStatusCode resp) (BSS.toShort $ HC.getStatusMessage resp) "application/xml" (TL.encodeUtf8 (X.serializeXMLDoc x))
throwProtoFail :: String -> IO a
throwProtoFail = throwIO . ProtocolInconsistency
----------------------------------------------------------------------------
{-
-- | Stream bucket listing of objects
listStreamAllObjects :: Connection -> Credentials -> BucketId -> ObjKey -> Maybe Char -> IO S3ListStream
listStreamAllObjects (S3Conn _ cfg) creds bid pfx0 delim0 = go isNullObjKey Nothing -- FIXME
where
go :: ObjKey -> Maybe Connection -> IO S3ListStream
go mmarker Nothing = do
res <- try $ connect cfg
case res of
Left e -> pure (S3ListEx e (go mmarker Nothing))
Right c -> go mmarker (Just c)
go mmarker (Just c) = do
res <- try $ listObjectsChunk c creds bid pfx0 mmarker delim0
case res of
Left e -> pure (S3ListEx e (go mmarker Nothing))
Right (nextMarker, objs, pfxs)
| not (TS.null nextMarker) -> do
pure $ S3ListFrag objs pfxs
(go nextMarker (Just c))
(close c)
| otherwise -> do
close c
if null objs
then pure S3ListDone
else pure $ S3ListFrag objs pfxs
(pure S3ListDone)
(pure ())
data S3ListStream
= S3ListFrag [ObjMetaInfo] [ObjKey] {- next -} (IO S3ListStream) {- terminate -} (IO ())
| S3ListEx SomeException {- retry -} (IO S3ListStream) {- terminates by default -}
| S3ListDone {- terminates by default -}
-}
-- | List all objects in a bucket
--
-- This operation may cause multiple HTTP requests to be issued
--
-- See also 'listObjectsChunk' and 'listObjectsFold'
listObjects :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ prefix
-> Maybe Char -- ^ delimiter
-> IO ([ObjMetaInfo],[ObjKey]) -- ^ @(objects, prefixes)@
listObjects conn creds bid pfx delim = go nullObjKey [] []
where
go marker acc1 acc2 = do
(marker', objs, pfxs) <- listObjectsChunk conn creds bid pfx delim marker 0
let acc1' = acc1 <> objs
acc2' = acc2 <> pfxs
case () of
_ | isNullObjKey marker' -> pure (acc1', acc2')
| otherwise -> go marker' acc1' acc2'
-- | Convenient 'foldM'-like object listing operation
--
-- Here's an usage example for iterating over the list of objects in
-- chunks of 100 objects and deleting those; and finally deleting the bucket:
--
-- > destroyBucket conn creds bid = do
-- > listObjectsFold conn creds bid nullObjKey Nothing 100 () $ \() objs [] ->
-- > forM_ objs $ \omi -> deleteObject conn creds bid (omiKey omi)
-- > deleteBucket conn creds bid
--
listObjectsFold :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ prefix
-> Maybe Char -- ^ delimiter
-> Word16 -- ^ max number of keys per iteration
-> a -- ^ initial value of accumulator argument to folding function
-> (a -> [ObjMetaInfo] -> [ObjKey] -> IO a) -- ^ folding function
-> IO a -- ^ returns final value of accumulator value
listObjectsFold conn creds bid pfx delim maxKeys acc0 lbody = go nullObjKey acc0
where
go marker acc = do
(marker', objs, pfxs) <- listObjectsChunk conn creds bid pfx delim marker maxKeys
acc' <- lbody acc objs pfxs
case () of
_ | isNullObjKey marker' -> pure acc'
| otherwise -> go marker' acc'
{-
listAllObjects conn creds bid pfx delim = listStreamAllObjects conn creds bid pfx delim >>= go 5 [] []
where
go :: Int -> [ObjMetaInfo] -> [ObjKey] -> S3ListStream -> IO ([ObjMetaInfo],[ObjKey])
go !_ acc acc' S3ListDone = evaluate (acc,acc')
go maxRetries acc acc' (S3ListEx ex retry)
| maxRetries > 1 = retry >>= go (maxRetries-1) acc acc'
| otherwise = do
_ <- throwProtoFail ("listAllObjects needed more than 5 retries (" <> show ex <> ")")
throwIO ex
go maxRetries acc acc' (S3ListFrag objs pfxs next _) =
go maxRetries (acc <> objs) (acc' <> pfxs) =<< next
-}
-- -- |
-- --
-- -- TODO: currently supports only non-paginated top-level folder
-- listObjectsFolder :: S3Cfg -> S3Connection -> IO [ObjMetaInfo]
-- listObjectsFolder s3cfg c = do
-- (nextMarker, objs, pfxs) <- listObjectsChunk s3cfg c isNullObjKey isNullObjKey (Just '/')
-- unless (nextMarker == isNullObjKey) $ throwProtoFail "listObjectsFolder"
-- pure $! objs
{-
<xsd:complexType name="ListBucketResult">
<xsd:sequence>
<xsd:element name="Metadata" type="tns:MetadataEntry" minOccurs="0" maxOccurs="unbounded"/>
<xsd:element name="Name" type="xsd:string"/>
<xsd:element name="Prefix" type="xsd:string"/>
<xsd:element name="Marker" type="xsd:string"/>
<xsd:element name="NextMarker" type="xsd:string" minOccurs="0"/>
<xsd:element name="MaxKeys" type="xsd:int"/>
<xsd:element name="Delimiter" type="xsd:string" minOccurs="0"/>
<xsd:element name="IsTruncated" type="xsd:boolean"/>
<xsd:element name="Contents" type="tns:ListEntry" minOccurs="0" maxOccurs="unbounded"/>
<xsd:element name="CommonPrefixes" type="tns:PrefixEntry" minOccurs="0" maxOccurs="unbounded"/>
</xsd:sequence>
</xsd:complexType>
-}
data MetadataEntry = MetadataEntry {-key-} ShortText {-value-} ShortText
deriving Show
pMetadataEntry :: P MetadataEntry
pMetadataEntry = MetadataEntry <$> one (s3_xsd'string "Name") <*> one (s3_xsd'string "Value")
data ListBucketResult = LBR
{ lbrMetadata :: [MetadataEntry]
, lbrName :: BucketId
, lbrPrefix :: ObjKey
, lbrMarker :: ObjKey
, lbrNextMarker :: Maybe ObjKey
, lbrMaxKeys :: Int32
, lbrDelimiter :: Maybe Char
, lbrIsTruncated :: Bool
, lbrEncodingTypeUrl:: Bool
, lbrContents :: [ObjMetaInfo]
, lbrCommonPrefixes :: [ObjKey]
} deriving Show
instance FromXML ListBucketResult where
tagFromXML _ = s3qname "ListBucketResult"
parseXML_ = withChildren $ do
lbrMetadata <- unbounded (parseXML' (s3qname "Metadata") (withChildren pMetadataEntry))
lbrName <- one (s3_xsd'string "Name")
-- we need this information early on as it affects the decoding of
-- ObjKey values; so let's read-ahead
tmp <- aheadMaybeOne ((== s3qname "EncodingType") . X.elName)
(s3_xsd'string "EncodingType")
lbrEncodingTypeUrl <- case tmp :: Maybe Text of
Just "url" -> pure True
Nothing -> pure False
Just _ -> failP "unsupported <EncodingType> encoutered"
lbrPrefix <- one (s3'ObjKey "Prefix" lbrEncodingTypeUrl)
lbrMarker <- one (s3'ObjKey "Marker" lbrEncodingTypeUrl)
lbrNextMarker <- maybeOne (s3'ObjKey "NextMarker" lbrEncodingTypeUrl)
lbrMaxKeys <- one (s3_xsd'int "MaxKeys")
lbrDelimiter <- fmap T.head <$> maybeOne (s3_xsd'string "Delimiter")
lbrIsTruncated <- one (s3_xsd'boolean "IsTruncated")
lbrContents <- unbounded (parseXML' (s3qname "Contents") $
withChildren (pObjMetaInfo lbrEncodingTypeUrl))
lbrCommonPrefixes <- unbounded (parseXML' (s3qname "CommonPrefixes") $
withChildren (pCommonPrefixes lbrEncodingTypeUrl))
pure LBR{..}
where
pCommonPrefixes urlEnc = one (s3'ObjKey "Prefix" urlEnc)
-- | Primitive operation for list objects
--
-- This operation corresponds to a single HTTP service request
--
-- The 'listObjectsChunk' and 'listObjects' operations build on this primitive building block.
listObjectsChunk :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ prefix (use 'isNullObjKey' if none)
-> Maybe Char -- ^ delimiter
-> ObjKey -- ^ marker (use 'isNullObjKey' if none)
-> Word16 -- ^ max-keys (set @0@ to use default which is usually @1000@)
-> IO (ObjKey,[ObjMetaInfo],[ObjKey]) -- ^ @(next-marker, objects, prefixes)@
listObjectsChunk conn creds bid pfx delim marker maxKeys = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.GET
, ahdrUrlPath = bucketUrlPath bid
, ahdrUrlQuery = urlq
}
(resp,mtmp) <- doHttpReqXml conn q HC.emptyBody
case HC.getStatusCode resp of
200 -> pure ()
_ -> throwUnexpectedXmlResp resp mtmp
LBR{..} <- case maybe (Left "empty body") parseXML mtmp of
Right lbr -> pure (lbr :: ListBucketResult)
Left err -> throwProtoFail $ "ListObjects: " <> err
let nextMarker' | lbrIsTruncated = fromMaybe nullObjKey (max (omiKey <$> last lbrContents) (last lbrCommonPrefixes))
| otherwise = nullObjKey
nextMarker | lbrIsTruncated = fromMaybe nextMarker' lbrNextMarker
| otherwise = nullObjKey
unless (lbrIsTruncated /= isNullObjKey nextMarker) $
throwProtoFail "NextMarker and isTruncated inconsistent"
unless (nextMarker == nextMarker') $
throwProtoFail "NextMarker inconsistent" -- should never happen
evaluate (force (nextMarker,lbrContents,lbrCommonPrefixes))
where
-- we could use max-keys=, but unfortunately AWS S3 doesn't appear
-- to support pureing more than 1000 entries (which is the
-- default anyway)
-- NB: keep this alphabetically sorted
qryparms = mconcat
[ [ "delimiter=" <> urlEncode True (BC8.singleton d) | Just d <- [delim] ]
, [ "encoding-type=url" | s3cfgEncodingUrl (s3connCfg conn) ]
, [ "marker=" <> urlEncodeObjKeyQry marker | not (isNullObjKey marker) ]
, [ "max-keys=" <> BC8.pack (show maxKeys) | maxKeys > 0 ]
, [ "prefix=" <> urlEncodeObjKeyQry pfx | not (isNullObjKey pfx) ]
]
urlq | null qryparms = mempty
| otherwise = "?" <> BC8.intercalate "&" qryparms
-- | Access permissions (aka /Canned ACLs/)
--
-- This has different meanings depending on whether it's set for buckets or objects
--
-- The owner of an entity has always full read & write access
--
-- For buckets, read access denotes the ability to list objects
data Acl = AclPrivate
| AclPublicRead
| AclPublicReadWrite
| AclPublicAuthenticatedRead
deriving (Show,Typeable,Generic)
instance NFData Acl
acl2str :: Acl -> ByteString
acl2str acl = case acl of
AclPrivate -> "private"
AclPublicRead -> "public-read"
AclPublicReadWrite -> "public-read-write"
AclPublicAuthenticatedRead -> "authenticated-read"
data CopyObjectResult = CopyObjectResult
{ _corLastModified :: UTCTime
, corETag :: ETag
} deriving Show
instance FromXML CopyObjectResult where
tagFromXML _ = s3qname "CopyObjectResult"
parseXML_ = withChildren $
CopyObjectResult <$> one (s3_xsd'dateTime "LastModified")
<*> (mkETag <$> one (s3_xsd'string "ETag"))
-- | Copy Object
copyObject :: Connection
-> Credentials
-> BucketId
-> ObjKey
-> (BucketId,ObjKey) -- ^ source object to copy
-> Maybe Acl
-> IO ETag
copyObject conn creds bid objkey (srcBid,srcObjKey) macl = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.PUT
, ahdrUrlPath = objUrlPath bid objkey
, ahdrExtraHeaders = hdrs
}
-- TODO: forM_ mcond setConditionHeader
(resp, mtmp) <- doHttpReqXml conn q HC.emptyBody
case (HC.getStatusCode resp,mtmp) of
(200,Just x) | Right v <- parseXML x -> pure (corETag v)
_ -> throwUnexpectedXmlResp resp mtmp
where
hdrs = ("x-amz-copy-source", objUrlPath srcBid srcObjKey)
: case macl of
Nothing -> []
Just acl -> [("x-amz-acl", acl2str acl)]
-- | @PUT@ Object
putObject :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ Object key
-> BL.ByteString -- ^ Object payload data
-> CType -- ^ @content-type@ (e.g. @application/binary@); see also 'noCType'
-> Maybe Acl
-> IO ETag
putObject conn creds bid objkey objdata ctype macl
= fromMaybe undefined <$> putObjectX conn creds bid objkey objdata ctype macl Nothing
putObjectCond :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ Object key
-> BL.ByteString -- ^ Object payload data
-> CType -- ^ @content-type@ (e.g. @application/binary@); see also 'noCType'
-> Maybe Acl
-> Condition
-> IO (Maybe ETag)
putObjectCond conn creds bid objkey objdata ctype macl cond
= putObjectX conn creds bid objkey objdata ctype macl (Just cond)
-- common codepath
putObjectX :: Connection
-> Credentials
-> BucketId
-> ObjKey
-> BL.ByteString
-> CType
-> Maybe Acl
-> Maybe Condition
-> IO (Maybe ETag)
putObjectX conn creds bid objkey objdata ctype macl mcond = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $ do
setAWSRequest creds awsh
{ ahdrMethod = HC.PUT
, ahdrUrlPath = objUrlPath bid objkey
, ahdrContentType = ctype
, ahdrContentHashes = Just (md5,sha256,BL.length objdata)
, ahdrExtraHeaders = hdrs
}
-- sadly, `setHeader "Last-Modified" ...` doesn't seem have any effect
forM_ mcond setConditionHeader
(resp, bs) <- doHttpReq True conn q (bsBody objdata)
case HC.getStatusCode resp of
200 -> case mkETag <$> HC.getHeader resp "ETag" of
Just x -> pure (Just x)
Nothing -> throwProtoFail "ETag"
412 | Just _ <- mcond -> pure Nothing
_ -> throwUnexpectedResp resp bs
where
hdrs = case macl of
Nothing -> []
Just acl -> [("x-amz-acl", acl2str acl)]
md5 = md5hash objdata
sha256 = sha256hash objdata
bsBody :: BL.ByteString -> Streams.OutputStream Builder.Builder -> IO ()
bsBody bs = Streams.write (Just (Builder.lazyByteString bs))
-- | @GET@ Object
getObject :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ Object key
-> IO (ETag, CType, BL.ByteString)
getObject conn creds bid objkey = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.GET
, ahdrUrlPath = objUrlPath bid objkey
}
(resp, bs) <- doHttpReq False conn q HC.emptyBody
case HC.getStatusCode resp of
200 -> case mkETag <$> HC.getHeader resp "ETag" of
Just x -> pure (x, getCT resp, bs)
Nothing -> throwProtoFail "ETag"
_ -> throwUnexpectedResp resp bs
getObjectCond :: Connection
-> Credentials
-> BucketId
-> ObjKey -- ^ Object key
-> Condition
-> IO (Maybe (ETag, CType, BL.ByteString))
getObjectCond conn creds bid objkey cond = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $ do
setAWSRequest creds awsh
{ ahdrMethod = HC.GET
, ahdrUrlPath = objUrlPath bid objkey
}
setConditionHeader cond
(resp, bs) <- doHttpReq False conn q HC.emptyBody
case HC.getStatusCode resp of
200 -> case mkETag <$> HC.getHeader resp "ETag" of
Just x -> pure $ Just (x, getCT resp, bs)
Nothing -> throwProtoFail "ETag"
304 | IfNotMatch _ <- cond -> pure Nothing
| IfNotExists <- cond -> pure Nothing
412 | IfMatch _ <- cond -> pure Nothing
| IfExists <- cond -> pure Nothing -- non-sensical
_ -> throwUnexpectedResp resp bs
-- | @DELETE@ Object
deleteObject :: Connection -> Credentials -> BucketId -> ObjKey -> IO ()
deleteObject conn creds bid objkey = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $
setAWSRequest creds awsh
{ ahdrMethod = HC.DELETE
, ahdrUrlPath = objUrlPath bid objkey
}
(resp, bs) <- doHttpReq True conn q HC.emptyBody
case HC.getStatusCode resp of
204 -> pure ()
_ -> throwUnexpectedResp resp bs
deleteObjectCond :: Connection -> Credentials -> BucketId -> ObjKey -> Condition -> IO Bool
deleteObjectCond conn creds bid objkey cond = withAWSHeaders conn $ \awsh -> do
let q = HC.buildRequest1 $ do
setAWSRequest creds awsh
{ ahdrMethod = HC.DELETE
, ahdrUrlPath = objUrlPath bid objkey
}
setConditionHeader cond
(resp, bs) <- doHttpReq True conn q HC.emptyBody
case HC.getStatusCode resp of
204 -> pure True
412 -> pure False
_ -> throwUnexpectedResp resp bs
-- | Bucket metadata reported by 'listBuckets'
data BucketInfo = BucketInfo !BucketId !UTCTime
deriving (Show,Typeable,Generic)
instance NFData BucketInfo
instance FromXML BucketInfo where
tagFromXML _ = s3qname "Bucket"
parseXML_ = withChildren $
BucketInfo <$> one (s3_xsd'string "Name")
<*> one (s3_xsd'dateTime "CreationDate")
pObjMetaInfo :: Bool -> P ObjMetaInfo
pObjMetaInfo urlEnc = do
omiKey <- one (s3'ObjKey "Key" urlEnc)
omiLastModified <- one (s3_xsd'dateTime "LastModified")
omiEtag <- mkETag <$> one (s3_xsd'string "ETag")
-- -- sometimes the reported MD5 is computed over chunks, in
-- -- which case the etag has a "-<num>" suffix. For now, we just
-- -- map those to the special zero MD5 as we can't do anything
-- -- sensible with it anyway (but we may want to be able to
-- -- detect that the MD5 reported was not a proper MD5)
omiSize <- one (s3_xsd'long "Size")
let sc = \case
"DEEP_ARCHIVE" -> Just ()
"GLACIER" -> Just ()
"INTELLIGENT_TIERING"-> Just ()
"ONEZONE_IA" -> Just ()
"REDUCED_REDUNDANCY" -> Just ()
"STANDARD" -> Just ()
"STANDARD_IA" -> Just ()
"UNKNOWN" -> Just ()
_ -> Nothing -- FIXME
let s3_storageClass = s3_xsd'enum "StorageClass" sc -- StorageClass / TODO
-- NB: some implementations have (optional) <Owner> and
-- (mandatory) <StorageClass> swapped in their schema
-- (i.e. <StorageClass> not being last); so we tolerate both
-- orderings
msc <- maybeOne s3_storageClass
(own,()) <- case msc of
Nothing -> (,) <$> (Just <$> one parseXML) <*> one s3_storageClass
Just sc' -> (,) <$> maybeOne parseXML <*> pure sc'
let omiOwnerId = fmap ownerID own
pure $! (OMI {..})
----------------------------------------------------------------------------
data Owner = Owner { ownerID :: ShortText
, _ownerDisplayName :: Maybe ShortText
} deriving Show
instance FromXML Owner where
tagFromXML _ = s3qname "Owner"
parseXML_ = withChildren $
Owner <$> one (s3_xsd'string "ID")
<*> maybeOne (s3_xsd'string "DisplayName")
newtype ListAllMyBucketsResult = ListAllMyBucketsResult [BucketInfo]
instance FromXML ListAllMyBucketsResult where
tagFromXML _ = s3qname "ListAllMyBucketsResult"
parseXML_ = withChildren $ do
_ <- one pure -- owner; todo
ListAllMyBucketsResult <$> one (fmap unBuckets . parseXML)
newtype Buckets = Buckets { unBuckets :: [BucketInfo] }
instance FromXML Buckets where
tagFromXML _ = s3qname "Buckets"
parseXML_ = withChildren $ Buckets <$> unbounded parseXML
----------------------------------------------------------------------------
newtype Error = Error ShortText
deriving Show
{- NB: The <Error> response element has no namespace and its schema is not openly documented; the first sub-element is always a <Code> text-element.
<Error>
<Code>BucketNotEmpty</Code>
<BucketName>hstest1</BucketName>
<RequestId>tx000000000000002d08a23-005b80213f-5893fff-us-east-1-iad1</RequestId>
<HostId>5893fff-us-east-1-iad1-us-east-1</HostId>
</Error>
-}
instance FromXML Error where
tagFromXML _ = X.unqual "Error"
parseXML_ = withChildren $ do
code <- one (xsd'string (X.unqual "Code"))
void unboundedAny -- skip the rest
pure (Error code)