packages feed

do-spaces (empty) → 0.1.0

raw patch · 44 files changed

+5028/−0 lines, 44 filesdep +basedep +base16-bytestringdep +bytestring

Dependencies added: base, base16-bytestring, bytestring, case-insensitive, conduit, conduit-extra, config-ini, containers, cryptonite, do-spaces, exceptions, extra, filepath, generic-lens, hspec, http-client-tls, http-conduit, http-types, memory, microlens, microlens-ghc, mime-types, mtl, resourcet, text, time, transformers, xml-conduit

Files

+ CHANGELOG.org view
@@ -0,0 +1,4 @@+#+TITLE: Changelog++* v0.1+Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Rory Tyler Hayford++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Rory Tyler Hayford nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.org view
@@ -0,0 +1,73 @@+#+TITLE: do-spaces++* About+  ~do-spaces~ is a Haskell library providing complete bindings to DigitalOcean's Spaces API, an Amazon s3-compatible object storage service. It offers bindings for:+   - object CRUD+   - bucket CRUD+   - bucket and object ACLs+   - bucket lifecycles+   - bucket CORS configuration++* Usage+~Network.DO.Spaces~ exposes the types and actions requires to make transactions through the Spaces API. The first step is to configure a client by supplying your credentials and a region:+#+begin_src haskell+someTransaction = do+    mySpaces <- newSpaces NewYork (FromFile "~/.spaces-secrets" Nothing)+    runSpaces mySpaces $ ...+#+end_src+There are a few options for supplying your credentials. See ~newSpaces~ in ~Network.DO.Spaces~ for more details.++~Network.DO.Spaces~ exposes several convenience actions for common transactions. These are simple wrappers around instances of the ~Action~ typeclass. Each of the actions must be run via ~runSpaces~ with a ~Spaces~ client configuration. If more granular control is required, especially in the case of actions which take several optional parameters (e.g., ~ListBucket~), you can directly import the ~Action~ instance, construct it, and run it with ~runAction~. These are available from the ~Network.DO.Spaces.Actions~ module.++Each action returns a ~SpacesResponse~ record with two fields. The optional ~metadata~ field contains information about the response. The data returned from the transaction can be accessed through the polymorphic ~result~ field. Retention of metadata and response information can be configured in ~runAction~, but all of the convenience actions exported from ~Network.DO.Spaces~ keep metadata.++A small example:++#+begin_src haskell+{-# LANGUAGE DataKinds #-}    +{-# LANGUAGE TypeApplications #-}    +    +import Data.Sequence         ( Seq )+import Data.Generics.Product ( HasField(field) )+import Lens.Micro -- or whatever compatible lens library you fancy+import Network.DO.Spaces++myObjects :: IO (Seq ObjectInfo)+myObjects = do+    -- Load your credentials configuration from environment variables+    spaces <- newSpaces Singapore (FromEnv Nothing)+    -- Use the @mkBucket@ smart constructor, which will validate the name you provide+    -- and ensure it conforms to Spaces API specifications+    bucket <- mkBucket "my-real-bucket"+    -- List the contents of your bucket. @listBucket@ will list all entries until the+    -- Spaces limit of 1,000. There are several variants of this action in+    -- "Network.DO.Spaces" with different options +    response <- runSpaces spaces $ listBucket bucket+    -- See the note about accessing record fields below+    return $ response ^. field @"result" . field @"objects"++#+end_src++** A note about records+Many transactions available through the Spaces API feature the same parameters. This necessitates dealing with duplicate fields in records that represent these transactions. For example, nearly every ~Action~ instance has a ~bucket~ field. I am not a fan of certain approaches to dealing with this problem: I am /highly/ averse to using pseudo-Hungarian Notation as record field prefixes, and I do not like using the leading-underscore name mangling approach in lenses. My personal preference is using the ~generic-lens~ package, and the library uses this internally along with ~DuplicateRecordFields~ etc.... There are a few options available when you use this library:++*** Use ~generic-lens~ with ~OverloadedLabels~+This is my personal preference. Note that I did *not* use the overloaded labels in the library itself, due to the (necessary) orphan ~IsLabel~ instance in ~generic-lens~. If you'd like to see an example of this, refer to the ~io-tests~ directory in this repository.++*** Use ~generic-lens~ with ~field~+This is the approach that the library uses internally, along with punning and wildcards; requires ~DataKinds~ and ~TypeApplications~ to use ~field~.++*** Use ~getField~+You can import ~getField~ from ~GHC.Records~ and use that to access record fields. Unfortunately, ~setField~ still hasn't been implemented in GHC.++*** Use the record selectors+Record selectors can be accessed by importing the relevant module directly, as they are not exported from ~Network.DO.Spaces~. You might want to import different types qualified, due to the aforementioned proliferation of record field duplication.++* But why?+Spaces is nominally compatible with existing Amazon S3 SDKs and clients, so it might seem redundant to create a dedicated client library for the service. DigitalOcean's endpoints and regions are different from Amazon's, however, requiring a stringly-typed region when configuring clients. True to form, Amazon client libraries written in Haskell (e.g., ~Amazonka~) tend to use an ADT to represent regions, precluding their use with Spaces. Furthermore, using an entire Amazon client might be overkill for an application that only requires the s3 functionality, unnecessarily requiring a heavyweight dependency.++* Testing+There are two test suites: a suite that tests pure functionality as well as one that runs actual IO transactions against DigitalOcean's Spaces API. *Run the latter suite at your own risk*. See ~Main.hs~ for a full disclaimer, but in short: running the full IO tests can cause irretrievable harm to the data in your Spaces account and may incur charges on your DigitalOcean account. Caveat emptor!++* License+  This library is distributed under the BSD three-clause license
+ do-spaces.cabal view
@@ -0,0 +1,148 @@+cabal-version:      3.0+name:               do-spaces+version:            0.1.0+synopsis:           DigitalOcean Spaces API bindings+description:        See the README at https://gitlab.com/ngua/do-spaces-hs+license:            BSD-3-Clause+license-file:       LICENSE+author:             Rory Tyler Hayford+maintainer:         rory.hayford@protonmail.com+copyright:          (c) Rory Tyler Hayford, 2021+homepage:           https://gitlab.com/ngua/do-spaces-hs+bug-reports:        https://gitlab.com/ngua/do-spaces-hs/-/issues+tested-with:        GHC ==8.8.4 || ==8.10.4+category:           Network+extra-source-files:+  README.org+  CHANGELOG.org+  tests/data/*.xml+  io-tests/creds.conf+  io-tests/creds.conf.skel++source-repository head+  type:     git+  location: https://gitlab.com/ngua/do-spaces-hs.git++common common-options+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++common common-extensions+  default-extensions: OverloadedStrings++flag test-io+  description: Run the full IO tests (requires Spaces subscription)+  default:     False++library+  import:           common-options, common-extensions+  build-depends:+    , base               >=4.13    && <5+    , base16-bytestring+    , bytestring         >=0.9+    , case-insensitive   >=1.0     && <1.3+    , conduit            ^>=1.3+    , conduit-extra      ^>=1.3+    , config-ini         ^>=0.2+    , containers         ^>=0.6+    , cryptonite         >=0.25    && <0.29+    , exceptions         ^>=0.10+    , extra              >=1.6     && <1.8+    , filepath           ^>=1.4+    , generic-lens       >=1.1     && <2.2+    , http-client-tls    ^>=0.3.5+    , http-conduit       ^>=2.3+    , http-types         ^>=0.12+    , memory             >=0.14    && <0.16+    , microlens          >=0.4.10  && <0.4.13+    , mime-types         >=0.1.0.7 && <0.1.1+    , mtl                ^>=2.2+    , text               ^>=1.2+    , time               >=1.8     && <1.12+    , transformers       ^>=0.5+    , xml-conduit        >=1.8.0.1 && <1.10++  exposed-modules:+    Network.DO.Spaces+    Network.DO.Spaces.Actions+    Network.DO.Spaces.Actions.CopyObject+    Network.DO.Spaces.Actions.CreateBucket+    Network.DO.Spaces.Actions.DeleteBucket+    Network.DO.Spaces.Actions.DeleteBucketCORS+    Network.DO.Spaces.Actions.DeleteBucketLifecycle+    Network.DO.Spaces.Actions.DeleteObject+    Network.DO.Spaces.Actions.GetBucketACLs+    Network.DO.Spaces.Actions.GetBucketCORS+    Network.DO.Spaces.Actions.GetBucketLifecycle+    Network.DO.Spaces.Actions.GetBucketLocation+    Network.DO.Spaces.Actions.GetObject+    Network.DO.Spaces.Actions.GetObjectACLs+    Network.DO.Spaces.Actions.GetObjectInfo+    Network.DO.Spaces.Actions.ListAllBuckets+    Network.DO.Spaces.Actions.ListBucket+    Network.DO.Spaces.Actions.SetBucketACLs+    Network.DO.Spaces.Actions.SetBucketCORS+    Network.DO.Spaces.Actions.SetBucketLifecycle+    Network.DO.Spaces.Actions.SetObjectACLs+    Network.DO.Spaces.Actions.UploadMultipart+    Network.DO.Spaces.Actions.UploadObject+    Network.DO.Spaces.Request+    Network.DO.Spaces.Types+    Network.DO.Spaces.Utils++  hs-source-dirs:   src+  default-language: Haskell2010++test-suite tests+  import:           common-options, common-extensions+  type:             exitcode-stdio-1.0+  hs-source-dirs:   tests+  build-depends:+    , base              >=4.13   && <5+    , bytestring        >=0.9+    , case-insensitive  >=1.0    && <1.3+    , conduit           ^>=1.3+    , conduit-extra     ^>=1.3+    , containers        ^>=0.6+    , do-spaces+    , generic-lens      >=1.1    && <2.2+    , hspec             >=2.0    && <3.0+    , http-client-tls   ^>=0.3.5+    , http-conduit      ^>=2.3+    , http-types        ^>=0.12+    , microlens         >=0.4.10 && <0.4.13+    , mtl               ^>=2.2+    , resourcet         ^>=1.2+    , text              ^>=1.2+    , time              >=1.8    && <1.12++  main-is:          Main.hs+  default-language: Haskell2010++test-suite io-tests+  import:           common-options, common-extensions++  if !flag(test-io)+    buildable: False++  type:             exitcode-stdio-1.0+  hs-source-dirs:   io-tests+  build-depends:+    , base           >=4.13   && <5+    , bytestring     >=0.9+    , conduit        ^>=1.3+    , conduit-extra  ^>=1.3+    , do-spaces+    , exceptions     ^>=0.10+    , extra          >=1.6    && <1.8+    , generic-lens   >=1.1    && <2.2+    , hspec          >=2.0    && <3.0+    , http-types     ^>=0.12+    , microlens      >=0.4.10 && <0.4.13+    , microlens-ghc  >=0.4.10 && <0.4.13+    , text           ^>=1.2+    , time           >=1.8    && <1.12++  main-is:          Main.hs+  default-language: Haskell2010
+ io-tests/Main.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- WARNING+-- Run at your own risk!+--+-- Running the tests in this module requires an active Digital Ocean spaces+-- subscription, and may incur any of the following:+--+--      * charges billed to your DO account+--      * the application of rate-limiting or other limits to your account+--      * overage in data transfer or concurrent active spaces, resulting in+--        charges or penalties+--      * the creation of extraneous spaces/buckets in your subscription+--      * data loss or corruption+--+-- To run:+--      * copy ./creds.conf.skel to ./creds.conf+--      * replace the dummy values with your active Spaces access and+--        secret keys, a region slug, and the name of an existing bucket+--        to use for certain object CRUD operations+--      * do not add any additional fields, whitespace, quotes, etc... or+--        parsing the credentials file will fail+--      * run @cabal test@ with @-f test-io@+--+-- The tests will create buckets and attempt to delete them. In the event+-- that bucket deletion fails, you will have to clean them up manually.+-- Similarly, the default bucket provided in the "bucket" field of the+-- credentials file will be used to test certain object CRUD functionality.+-- Although the tests will attempt to delete any objects created, you may+-- need to delete them manually if this fails+--+module Main where++import           Conduit+                 ( (.|)+                 , runConduitRes+                 , sinkList+                 , sourceFile+                 , sourceLazy+                 )++import           Control.Exception          ( bracket, throwIO )+import           Control.Monad              ( void )+import           Control.Monad.Catch        ( MonadCatch(catch)+                                            , MonadThrow(throwM)+                                            )+import           Control.Monad.IO.Class     ( MonadIO(liftIO) )++import qualified Data.ByteString.Char8      as C+import qualified Data.ByteString.Lazy.Char8 as LC+import           Data.Coerce                ( coerce )+import qualified Data.Conduit.Binary        as CB+import           Data.Generics.Labels       ()+import qualified Data.Text                  as T+import           Data.Text                  ( Text )+import qualified Data.Text.Encoding         as T+import           Data.Time.Clock.POSIX      ( getPOSIXTime )++import           Lens.Micro+import           Lens.Micro.GHC             ()++import           Network.DO.Spaces+import           Network.DO.Spaces.Utils    ( slugToRegion )+import qualified Network.HTTP.Types         as H++import           System.Time.Extra          ( sleep )++import           Test.Hspec++main :: IO ()+main = sequence_ [ bucketCreateDelete+                 , bucketActions+                 , objectCreateDelete+                 , objectActions+                 , multipart+                 ]++objectActions :: IO ()+objectActions = do+    (bucket, spaces) <- readConf+    hspec . around withTestObject $ do+        describe "Network.DO.Spaces.Actions.GetObjectInfo"+            . it "retrieves object information"+            $ \object -> do+                info <- retry404 20 . runSpaces spaces+                    $ getObjectInfo bucket object+                (info ^. #result . #contentType) `shouldBe` "text/plain"+                (info ^. #result . #contentLength) `shouldBe` 18++        describe "Network.DO.Spaces.Actions.CopyObject"+            . it "copies an existing object to a new object"+            $ \object -> do+                destObject <- nameWithEpoch mkObject "test-object-copy-"+                copied <- runSpaces spaces+                    $ copyObjectWithin bucket object destObject+                getStatus copied `shouldBe` Just 200+                deleted <- retry404 20 . runSpaces spaces+                    $ deleteObject bucket destObject+                getStatus deleted `shouldBe` Just 204++        describe "Network.DO.Spaces.Actions.GetObject"+            . it "retrieves object data"+            $ \object -> do+                gotten <- runSpaces spaces $ getObject bucket object+                (gotten ^. #result . #objectData)+                    `shouldBe` "hello from haskell"+  where+    withTestObject = bracket uploadTestObject deleteTestObject++    uploadTestObject = do+        (bucket, spaces) <- readConf+        object <- nameWithEpoch mkObject "test-object-"+        void . runSpaces spaces+            $ uploadObject (Just "text/plain") bucket object body+        return object+      where+        body = sourceLazy "hello from haskell"++    deleteTestObject object = do+        (bucket, spaces) <- readConf+        void . runSpaces spaces $ deleteObject bucket object++multipart :: IO ()+multipart = do+    (bucket, spaces) <- readConf+    object <- nameWithEpoch mkObject "test-multipart-"+    hspec+        . after_ (cleanup spaces bucket object)+        . describe "Network.DO.Spaces.multipartObject"+        . it "uploads a multipart object"+        $ do+            mp <- runSpaces spaces+                $ multipartObject Nothing bucket object 5242880 body+            getStatus mp `shouldBe` Just 200+            (mp ^. #result . #object) `shouldBe` object+  where+    cleanup spaces bucket object =+        void . retry404 20 . runSpaces spaces $ deleteObject bucket object++    body = sourceLazy $ LC.replicate 10485760 'f'++objectCreateDelete :: IO ()+objectCreateDelete = do+    (bucket, spaces) <- readConf+    object <- nameWithEpoch mkObject "test-object-"+    hspec+        . context "Network.DO.Spaces.Actions Object CRUD"+        . it "creates, reads, and deletes a new Object"+        $ do+            created+                <- runSpaces spaces $ uploadObject Nothing bucket object body+            getStatus created `shouldBe` Just 200++            deleted+                <- retry404 20 . runSpaces spaces $ deleteObject bucket object+            getStatus deleted `shouldBe` Just 204+            (deleted ^. #result) `shouldBe` ()+  where+    body = sourceLazy "hello from haskell"++bucketActions :: IO ()+bucketActions = do+    (bucket, spaces) <- readConf+    hspec $ do+        describe "Network.DO.Spaces.Actions.GetBucketLocation"+            . it "retrieves a bucket's location"+            $ do+                location <- runSpaces spaces $ getBucketLocation bucket+                getStatus location `shouldBe` Just 200+                (location ^. #result . #locationConstraint)+                    `shouldBe` (spaces ^. #region)++        describe "Network.DO.Spaces.Actions.ListAllBuckets"+            . it "lists account owner's buckets"+            $ do+                allBuckets <- runSpaces spaces listAllBuckets+                (allBuckets ^.. #result . #buckets . each . #name)+                    `shouldContain` [ bucket ]++bucketCreateDelete :: IO ()+bucketCreateDelete = do+    (_, spaces) <- readConf+    bucket <- nameWithEpoch mkBucket "do-spaces-test-"+    hspec+        . context "Network.DO.Spaces.Actions Bucket CRUD"+        . it "creates, reads, and deletes a new bucket"+        $ do+            created <- runSpaces spaces $ createBucket bucket Nothing Nothing+            getStatus created `shouldBe` Just 200+            (created ^. #result) `shouldBe` ()++            deleted <- retry404 20 . runSpaces spaces $ deleteBucket bucket+            getStatus deleted `shouldBe` Just 204+            (deleted ^. #result) `shouldBe` ()++-- A crude (yet effective) mechanism to ensure that 404s are retried (up to a+-- limit), necessary when creating a new Bucket for testing+retry404 :: (MonadCatch m, MonadIO m)+         => Int+         -> m (SpacesResponse a)+         -> m (SpacesResponse a)+retry404 maxRetries action = loop 0+  where+    loop n = catch @_ @ClientException action (catch404 n)++    catch404 n e@(HTTPStatus s _)+        | H.statusCode s == 404, n < maxRetries = liftIO (sleep 1)+            >> loop (n + 1)+        | otherwise = throwM e++    catch404 _ e                  = throwM e++-- Makes a Bucket or Object name by appending the current epoch time to a base name;+-- this provides some mechanism to avoid name clashes when creating new buckets,+-- which must be unique across all users within a given region. It also helps ensure+-- that new Objects created during testing won't overwrite existing ones in the+-- default Bucket provided in the credentials configuration+nameWithEpoch :: MonadIO m => (Text -> m a) -> Text -> m a+nameWithEpoch f base = f . (base <>) . T.pack . show @Integer . round+    =<< liftIO getPOSIXTime++readConf :: IO (Bucket, Spaces)+readConf = do+    contents <- runConduitRes+        $ sourceFile "./io-tests/creds.conf" .| CB.lines .| sinkList+    case getVal <$> contents of+        [ a, s, r, b ] -> do+            let access = coerce a+                secret = coerce s+            region <- slugToRegion $ T.decodeUtf8 r+            bucket <- mkBucket $ T.decodeUtf8 b+            spaces <- newSpaces region (Explicit access secret)+            return (bucket, spaces)+        _              -> throwIO . userError+            $ mconcat [ "io-tests: Credentials must consist of "+                      , "exactly four lines, in the order "+                      , "'access', 'secret', 'region', 'bucket'"+                      , "with each key separated from its "+                      , "value with '=', without whitespace "+                      , "See ./creds.conf.skel"+                      ]+  where+    getVal = snd . C.splitAt 7++getStatus :: SpacesResponse a -> Maybe Int+getStatus = (^? #metadata . _Just . #status . to H.statusCode)
+ io-tests/creds.conf view
@@ -0,0 +1,4 @@+access=EUTZTPU7IKRELWXQ4SQW+secret=qW4cL9oE34II4uFVWnSjE8DMr6exxqJBlim9AjDHqkM+region=sgp1+bucket=tiengnam-sg
+ io-tests/creds.conf.skel view
@@ -0,0 +1,4 @@+access=REPLACEME+secret=REPLACEME+region=REPLACEME+bucket=REPLACEME
+ src/Network/DO/Spaces.hs view
@@ -0,0 +1,543 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Network.DO.Spaces+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+-- Interacting with DigitalOcean's Spaces API, a (largely) s3-compatible object+-- storage platform. This module exports actions to create a 'Spaces' client+-- configuration as well as several convenience actions. Most of the transactions+-- exposed through the Spaces REST API are supported here, including CRUD operations+-- on buckets and objects, bucket CORS configuration, and manipulating ACLs.+--+-- See the README in this repository for more information on using this library+--+module Network.DO.Spaces+    ( runSpaces+    , newSpaces+      -- * Convenience actions+      -- $conv+      -- ** Object operations+    , uploadObject+    , multipartObject+    , uploadFile+    , getObject+    , getObjectSinkFile+    , getObjectInfo+    , copyObject+    , copyObjectWithin+    , overwriteObject+    , deleteObject+    , getObjectACLs+    , setObjectACLs+      -- ** Bucket operations+    , createBucket+    , deleteBucket+    , getBucketLocation+    , listAllBuckets+    , listBucket+    , listBucketGrouped+    , listBucketRec+    , getBucketCORS+    , deleteBucketCORS+    , setBucketCORS+    , getBucketACLs+    , setBucketACLs+    , getBucketLifecycleRules+    , setBucketLifecycleRules+    , deleteBucketLifecycleRules+      -- * Re-exports+    , Spaces+    , SpacesResponse+    , SpacesMetadata+    , MonadSpaces+    , Bucket+    , mkBucket+    , Object+    , mkObject+    , Region(..)+    , AccessKey(..)+    , SecretKey(..)+    , CredentialSource(..)+    , Profile+    , CORSRule+    , mkCORSRule+    , Grant(..)+    , Grantee(..)+    , Permission(..)+    , LifecycleID+    , mkLifecycleID+    , SpacesException+    , ClientException(..)+    , APIException(..)+    ) where++import           Conduit+                 ( (.|)+                 , await+                 , decodeUtf8C+                 , runConduit+                 , runConduitRes+                 , sinkFileCautious+                 , sinkLazy+                 , sourceFile+                 , sourceLazy+                 , withSourceFile+                 , yield+                 )++import           Control.Monad               ( void )+import           Control.Monad.Catch         ( MonadThrow(throwM) )+import           Control.Monad.Catch.Pure    ( MonadCatch(catch) )+import           Control.Monad.IO.Class      ( MonadIO(liftIO) )+import           Control.Monad.Reader.Class  ( ask )++import           Data.Bifunctor              ( Bifunctor(bimap) )+import           Data.Bool                   ( bool )+import qualified Data.ByteString.Char8       as C+import qualified Data.ByteString.Lazy        as LB+import           Data.Coerce                 ( coerce )+import           Data.Conduit.Binary         ( sinkLbs )+import           Data.Conduit.List           ( consume )+import           Data.Foldable               ( asum )+import           Data.Generics.Product       ( HasField(field) )+import qualified Data.Ini.Config             as I+import           Data.Maybe                  ( fromMaybe )+import           Data.Sequence               ( Seq )+import qualified Data.Text                   as T+import           Data.Text                   ( Text )+import qualified Data.Text.Encoding          as T+import qualified Data.Text.Lazy              as LT++import           Lens.Micro                  ( (<&>), (^.) )++import           Network.DO.Spaces.Actions+import           Network.DO.Spaces.Types+import           Network.DO.Spaces.Utils     ( defaultUploadHeaders )+import           Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) )+import           Network.HTTP.Client.TLS     ( getGlobalManager )+import           Network.Mime+                 ( MimeType+                 , defaultMimeMap+                 , defaultMimeType+                 , mimeByExt+                 )++import           System.Environment          ( lookupEnv )+import qualified System.FilePath             as F++-- | Perform a transaction using your 'Spaces' client configuration. Note that+-- this does /not/ perform any exception handling; if caught at the lower level,+-- exceptions are generally re-thrown as 'SpacesException's+--+-- To run a 'SpacesT' action with arguments in the opposite order, you can use+-- 'runSpacesT' directly+runSpaces :: Spaces -> SpacesT m a -> m a+runSpaces = flip runSpacesT++-- | Create a new 'Spaces' in a given 'Region' while specifying a method to retrieve+-- your credentials:+--+-- 'FromFile' expects a configuration file in the same format as AWS credentials+-- files, with the same field names. For example:+--+-- > [default]+-- > aws_access_key_id=AKIAIOSFODNN7EXAMPLE+-- > aws_secret_access_key=wJalrXUtnFEMI/K7MDENG/bPxRfiCYEXAMPLEKEY+--+-- 'FromEnv' will look up the following environment variables to find your+-- keys:  @AWS_ACCESS_KEY_ID@ , @SPACES_ACCESS_KEY_ID@ , @SPACES_ACCESS_KEY@+-- for the 'AccessKey', and  @AWS_SECRET_ACCESS_KEY@ , @SPACES_SECRET_ACCESS_KEY@+-- , and @SPACES_SECRET_KEY@ for your 'SecretKey'. Alternatively, you can directly+-- specify the environment variables to consult.+--+-- You can also choose to provide both keys yourself with 'Explicit'+--+newSpaces+    :: (MonadThrow m, MonadIO m) => Region -> CredentialSource -> m Spaces+newSpaces region cs = do+    manager <- liftIO getGlobalManager+    (accessKey, secretKey) <- liftIO $ source cs+    return Spaces { .. }+  where+    source (Explicit ak sk) = return (ak, sk)+    source (FromEnv (Just (akEnv, skEnv))) =+        ensureKeys =<< (,) <$> lookupKey akEnv <*> lookupKey skEnv+    source (FromEnv Nothing) = do+        ak <- lookupKeys [ "AWS_ACCESS_KEY_ID"+                         , "SPACES_ACCESS_KEY_ID"+                         , "SPACES_ACCESS_KEY"+                         ]+        sk <- lookupKeys [ "AWS_SECRET_ACCESS_KEY"+                         , "SPACES_SECRET_ACCESS_KEY"+                         , "SPACES_SECRET_KEY"+                         ]+        ensureKeys (ak, sk)++    source (FromFile fp profile) = do+        contents <- LT.toStrict+            <$> runConduitRes (sourceFile fp .| decodeUtf8C .| sinkLazy)+        case I.parseIniFile contents parseConf of+            Left _   ->+                throwM $ ConfigurationError "Failed to read credentials file"+            Right ks -> return+                $ bimap (coerce . T.encodeUtf8) (coerce . T.encodeUtf8) ks+      where+        parseConf = I.section (fromMaybe "default" profile)+            $ (,) <$> I.field "aws_access_key_id"+            <*> I.field "aws_secret_access_key"++    throwMissingKeys k = throwM . ConfigurationError $ "Missing " <> k++    lookupKeys xs = asum <$> sequence (lookupEnv <$> xs)++    lookupKey = lookupEnv . T.unpack++    ensureKeys = \case+        (Just a, Just s) -> return (mkKey AccessKey a, mkKey SecretKey s)+        (Just _, _)      -> throwMissingKeys "secret key"+        (_, Just _)      -> throwMissingKeys "access key"+        (_, _)           -> throwMissingKeys "secret and access keys"++    mkKey f = f . C.pack++-- | Upload an 'Object' within a single request+uploadObject :: MonadSpaces m+             => Maybe MimeType+             -> Bucket+             -> Object+             -> BodyBS m+             -> m (SpacesResponse UploadObject)+uploadObject contentType bucket object rbody = do+    body <- RequestBodyLBS <$> runConduit (rbody .| sinkLbs)+    runAction KeepMetadata+              UploadObject { optionalHeaders = defaultUploadHeaders, .. }++-- | Initiate and complete a multipart upload, using default 'UploadHeaders'.+-- If a 'SpacesException' is thrown while performing the transaction, an attempt+-- will be made to runSpaces a 'CancelMultipart' request, and the exception will be+-- rethrown+multipartObject+    :: MonadSpaces m+    => Maybe MimeType+    -> Bucket+    -> Object+    -> Int+    -> BodyBS m+    -> m (SpacesResponse CompleteMultipart)+multipartObject contentType bucket object size body+    | size < 5242880 = throwM+        $ InvalidRequest "multipartObject: Chunk size must be greater than/equal to 5MB"+    | otherwise = do+        session <- beginMultipart <&> (^. field @"result" . field @"session")+        catch @_ @SpacesException (run session) $ \e -> do+            void . runAction NoMetadata $ CancelMultipart session+            throwM e+  where+    run session = completeMultipart session+        =<< runConduit (body .| inChunks .| putPart session .| consume)++    beginMultipart = runAction NoMetadata+                               BeginMultipart+                               { optionalHeaders = defaultUploadHeaders, .. }++    completeMultipart session tags = runAction KeepMetadata+        $ CompleteMultipart session (zip [ 1 .. ] tags)++    putPart session = go 1+      where+        go n = await >>= \case+            Nothing -> return ()+            Just v  -> do+                spaces <- ask+                etag <- liftIO+                    $ runSpaces spaces+                                (runAction NoMetadata+                                 $ UploadPart session n (RequestBodyLBS v))+                    <&> (^. field @"result" . field @"etag")+                yield etag >> go (n + 1)++    inChunks = loop 0 []+      where+        loop n chunk = await >>= maybe (yieldChunk chunk) go+          where+            go bs = bool (loop len newChunk)+                         (yieldChunk newChunk >> loop 0 [])+                         (size <= len)+              where+                len      = C.length bs + n++                newChunk = bs : chunk++        yieldChunk = yield . LB.fromChunks . reverse++-- | Upload a file's contents as an 'Object'. This will attempt to set the+-- correct 'Network.Mime.MimeType' based on the file extension+uploadFile :: forall m.+           MonadSpaces m+           => Bucket+           -> Object+           -> FilePath+           -> m (SpacesResponse UploadObject)+uploadFile bucket object fp = withSourceFile @_ @m fp $ \body ->+    uploadObject (Just mtype) bucket object body+  where+    mtype =+        mimeByExt defaultMimeMap defaultMimeType . T.pack $ F.takeFileName fp++-- | Get information about an 'Object' (does not retrieve the body of the object)+getObjectInfo+    :: MonadSpaces m => Bucket -> Object -> m (SpacesResponse GetObjectInfo)+getObjectInfo bucket object = runAction KeepMetadata GetObjectInfo { .. }++-- | Get an 'Object' (retrieves the actual body of the object)+getObject :: MonadSpaces m => Bucket -> Object -> m (SpacesResponse GetObject)+getObject bucket object = runAction KeepMetadata GetObject { .. }++-- | Get an 'Object'\'s data and write it to the provided 'FilePath'+getObjectSinkFile :: MonadSpaces m => Bucket -> Object -> FilePath -> m ()+getObjectSinkFile bucket object fp = do+    objectData <- getObject bucket object+        <&> (^. field @"result" . field @"objectData")+    runConduitRes $ sourceLazy objectData .| sinkFileCautious fp++-- | Copy an 'Object' from one 'Bucket' to another; this chooses a number of+-- defaults to represent the most common cases and avoid a preponderance of+-- parameters. 'Object's are copied using default ACLs with the COPY metadata+-- directive.+--+-- If you'd like to use a specfic 'CannedACL' or 'MetadataDirective', use+-- 'CopyObject' directly with 'runAction'+copyObject :: MonadSpaces m+           => Bucket -- ^ Source 'Bucket'+           -> Bucket -- ^ Destination 'Bucket'+           -> Object -- ^ Source 'Object'+           -> Object -- ^ Destination 'Object'+           -> m (SpacesResponse CopyObject)+copyObject srcBucket destBucket srcObject destObject =+    runAction KeepMetadata CopyObject { .. }+  where+    acl               = Nothing++    metadataDirective = Copy++-- | Copy an 'Object' within the same 'Bucket', using defaults for the+-- 'MetadataDirective' and 'CannedACL'+copyObjectWithin :: MonadSpaces m+                 => Bucket+                 -> Object -- ^ Source 'Object'+                 -> Object -- ^ Destination 'Object'+                 -> m (SpacesResponse CopyObject)+copyObjectWithin srcBucket srcObject destObject =+    runAction KeepMetadata CopyObject { .. }+  where+    acl               = Nothing++    metadataDirective = Copy++    destBucket        = srcBucket++-- | Copy an 'Object' to itself, overwriting its associated metadata+overwriteObject+    :: MonadSpaces m => Bucket -> Object -> m (SpacesResponse CopyObject)+overwriteObject srcBucket srcObject = runAction KeepMetadata CopyObject { .. }+  where+    acl               = Nothing++    metadataDirective = Copy++    destBucket        = srcBucket++    destObject        = srcObject++-- | Delete a single 'Object'+deleteObject+    :: MonadSpaces m => Bucket -> Object -> m (SpacesResponse DeleteObject)+deleteObject bucket object = runAction KeepMetadata DeleteObject { .. }++-- | Get an 'Object'\'s Access Control Lists+getObjectACLs+    :: MonadSpaces m => Bucket -> Object -> m (SpacesResponse GetObjectACLs)+getObjectACLs bucket object = runAction KeepMetadata GetObjectACLs { .. }++-- | Set an 'Object'\'s Access Control Lists+setObjectACLs :: MonadSpaces m+              => Bucket+              -> Object+              -> Owner+              -> [Grant]+              -> m (SpacesResponse SetObjectACLs)+setObjectACLs bucket object owner acls =+    runAction KeepMetadata SetObjectACLs { .. }++-- | Create a new 'Bucket'+createBucket :: MonadSpaces m+             => Bucket+             -> Maybe Region -- ^ Overrides the 'Region' in your 'Spaces'+                             -- configuration+             -> Maybe CannedACL+             -> m (SpacesResponse CreateBucket)+createBucket bucket region acl = runAction KeepMetadata CreateBucket { .. }++-- | Delete a 'Bucket'+deleteBucket :: MonadSpaces m => Bucket -> m (SpacesResponse DeleteBucket)+deleteBucket bucket = runAction KeepMetadata DeleteBucket { .. }++-- | Get the location ('Region') of a 'Bucket'+getBucketLocation+    :: MonadSpaces m => Bucket -> m (SpacesResponse GetBucketLocation)+getBucketLocation bucket = runAction KeepMetadata GetBucketLocation { .. }++-- | List every 'Bucket' associated with your Spaces account+listAllBuckets :: MonadSpaces m => m (SpacesResponse ListAllBuckets)+listAllBuckets = runAction KeepMetadata ListAllBuckets++-- | List the 'Object's of a 'Bucket', without grouping, delimiting, or limiting+-- the keys (i.e. list all 'Object's non-hierarchically, up to the Spaces limit)+listBucket :: MonadSpaces m => Bucket -> m (SpacesResponse ListBucket)+listBucket bucket = runAction KeepMetadata ListBucket { .. }+  where+    delimiter = Nothing++    marker    = Nothing++    maxKeys   = Nothing++    prefix    = Nothing++-- | List the 'Object's of a 'Bucket', using a delimiter and prefix to group+-- objects. For example @\/@ can be used as a delimiter to treat objects as+-- directories within the bucket, which can further be combined with a text+-- prefix+listBucketGrouped :: MonadSpaces m+                  => Bucket+                  -> Char -- ^ Delimiter+                  -> Text -- ^ Prefix used to group object keys+                  -> m (SpacesResponse ListBucket)+listBucketGrouped bucket delimiter prefix =+    runAction KeepMetadata+              ListBucket+              { delimiter = Just delimiter, prefix = Just prefix, .. }+  where+    maxKeys = Nothing++    marker  = Nothing++-- | Recursively list /all/ 'Object's in a 'Bucket', calling 'ListBucket' until+-- @isTruncated@ is @False@. This operation may take some time, depending on the+-- total number of objects in your bucket+listBucketRec :: MonadSpaces m => Bucket -> m (Seq ObjectInfo)+listBucketRec bucket = go mempty Nothing+  where+    go os marker = do+        listed <- runAction NoMetadata+            $ ListBucket+            { delimiter = Nothing, maxKeys = Nothing, prefix = Nothing, .. }+        let r           = listed ^. field @"result"+            isTruncated = r ^. field @"isTruncated"+            objects     = r ^. field @"objects"+            nextMarker  = r ^. field @"nextMarker"+        case nextMarker of+            Just _+                | isTruncated -> go (os <> objects) nextMarker+                | otherwise -> return $ os <> objects+            Nothing -> return $ os <> objects++-- | Get the 'CORSRule's configured for a given 'Bucket'+getBucketCORS :: MonadSpaces m => Bucket -> m (SpacesResponse GetBucketCORS)+getBucketCORS bucket = runAction KeepMetadata $ GetBucketCORS { .. }++-- | Set 'CORSRule's for a given 'Bucket'+setBucketCORS :: MonadSpaces m+              => Bucket+              -> [CORSRule]+              -> m (SpacesResponse SetBucketCORS)+setBucketCORS bucket rules = runAction KeepMetadata $ SetBucketCORS { .. }++-- | Delete the existing configured 'CORSRule's for a given 'Bucket'+deleteBucketCORS+    :: MonadSpaces m => Bucket -> m (SpacesResponse DeleteBucketCORS)+deleteBucketCORS bucket = runAction KeepMetadata $ DeleteBucketCORS { .. }++-- | Get a 'Bucket'\'s Access Control Lists+getBucketACLs :: MonadSpaces m => Bucket -> m (SpacesResponse GetBucketACLs)+getBucketACLs bucket = runAction KeepMetadata $ GetBucketACLs { .. }++-- | Set a 'Bucket'\'s Access Control Lists. Spaces only allows a limited subset+-- of s3 ACLs at the moment. It may be preferable to use a 'CannedACL' when+-- creating new resources rather than using this action, which is provided+-- for the sake of completeness.+--+-- Note that to allow public read-only access to your bucket, you /must/+-- simultaneously set full owner control.+setBucketACLs :: MonadSpaces m+              => Bucket+              -> [Grant]+              -> Owner+              -> m (SpacesResponse SetBucketACLs)+setBucketACLs bucket acls owner =+    runAction KeepMetadata $ SetBucketACLs { .. }++-- | Get a 'Bucket'\'s 'LifecycleRule' configuration . Note that unless you+-- have explicitly configured lifecycle rules, this will fail with a 404+-- status and an error code of @NoSuchLifecycleConfiguration@+getBucketLifecycleRules+    :: MonadSpaces m => Bucket -> m (SpacesResponse GetBucketLifecycle)+getBucketLifecycleRules bucket =+    runAction KeepMetadata $ GetBucketLifecycle { .. }++-- | Set a 'Bucket'\'s 'LifecycleRule' configuration+setBucketLifecycleRules :: MonadSpaces m+                        => Bucket+                        -> [LifecycleRule]+                        -> m (SpacesResponse SetBucketLifecycle)+setBucketLifecycleRules bucket rules =+    runAction KeepMetadata $ SetBucketLifecycle { .. }++-- | Delete a 'Bucket'\'s 'LifecycleRule' configuration+deleteBucketLifecycleRules+    :: MonadSpaces m => Bucket -> m (SpacesResponse DeleteBucketLifecycle)+deleteBucketLifecycleRules bucket =+    runAction KeepMetadata $ DeleteBucketLifecycle { .. }+--+-- $conv+-- The following are convenience actions. In most cases, each action is the same+-- as applying 'runAction' to a type that implements the 'Action' typeclass.+-- Information about the response is retained ('SpacesMetadata') in each action.+-- For instance:+--+-- > deleteBucket myBucket+--+-- is the equivalent of+--+-- > runAction KeepMetadata DeleteBucket { bucket = myBucket }+--+-- All of the underlying instances of 'Action' are exposed and can be imported from+-- "Network.DO.Spaces.Actions" and its sub-modules. The convenience actions exposed+-- in the present module attempt to choose sane defaults where applicable.+--+-- The only major exception to the above are actions which involve uploading object+-- data to Spaces. In the case of 'uploadObject', the action converts its 'BodyBS'+-- argument to a 'RequestBodyLBS'. Should you choose to directly construct+-- 'UploadObject', you must do this manually. 'multipartObject' is more complicated,+-- and takes care of chunking the request body, sending each individual request,+-- and completing the multipart request+--+-- In addition to convenience wrappers around 'Action' instances, this module exports+-- several actions which may be of use, including sinking remote 'Object' data into+-- a file, uploading the contents of a file as an 'Object', and recursively listing+-- the entire contents of a 'Bucket'+--+--+--+--
+ src/Network/DO/Spaces/Actions.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Network.DO.Spaces.Actions+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+-- This module re-exports the 'Action' instances in the modules below it+--+module Network.DO.Spaces.Actions+    ( runAction+    , parseErrorResponse+      -- * Re-exports+    , module M+    ) where++import           Conduit+                 ( (.|)+                 , runConduit+                 )++import           Control.Monad                                   ( when )+import           Control.Monad.Catch+                 ( MonadThrow+                 , throwM+                 )+import           Control.Monad.IO.Class+                 ( MonadIO(liftIO)+                 )++import           Data.Conduit.Binary                             ( sinkLbs )+import           Data.Function                                   ( (&) )+import           Data.Time+                 ( getCurrentTime+                 )++import           Network.DO.Spaces.Actions.CopyObject            as M+import           Network.DO.Spaces.Actions.CreateBucket          as M+import           Network.DO.Spaces.Actions.DeleteBucket          as M+import           Network.DO.Spaces.Actions.DeleteBucketCORS      as M+import           Network.DO.Spaces.Actions.DeleteBucketLifecycle as M+import           Network.DO.Spaces.Actions.DeleteObject          as M+import           Network.DO.Spaces.Actions.GetBucketACLs         as M+import           Network.DO.Spaces.Actions.GetBucketCORS         as M+import           Network.DO.Spaces.Actions.GetBucketLifecycle    as M+import           Network.DO.Spaces.Actions.GetBucketLocation     as M+import           Network.DO.Spaces.Actions.GetObject             as M+import           Network.DO.Spaces.Actions.GetObjectACLs         as M+import           Network.DO.Spaces.Actions.GetObjectInfo         as M+import           Network.DO.Spaces.Actions.ListAllBuckets        as M+import           Network.DO.Spaces.Actions.ListBucket            as M+import           Network.DO.Spaces.Actions.SetBucketACLs         as M+import           Network.DO.Spaces.Actions.SetBucketCORS         as M+import           Network.DO.Spaces.Actions.SetBucketLifecycle    as M+import           Network.DO.Spaces.Actions.SetObjectACLs         as M+import           Network.DO.Spaces.Actions.UploadMultipart       as M+import           Network.DO.Spaces.Actions.UploadObject          as M+import           Network.DO.Spaces.Request+                 ( finalize+                 , mkAuthorization+                 , mkStringToSign+                 , newSpacesRequest+                 )+import           Network.DO.Spaces.Types+                 ( APIException(..)+                 , Action(..)+                 , ClientException(HTTPStatus)+                 , MonadSpaces+                 , RawResponse(..)+                 , SpacesResponse(..)+                 , WithMetadata(NoMetadata, KeepMetadata)+                 )+import           Network.DO.Spaces.Utils+                 ( getResponseMetadata+                 , handleMaybe+                 , xmlDocCursor+                 , xmlElemError+                 )+import           Network.HTTP.Client.Conduit                     ( withResponse+                                                                 )+import qualified Network.HTTP.Conduit                            as H+import qualified Network.HTTP.Types                              as H+import           Network.HTTP.Types                              ( Status )++import qualified Text.XML.Cursor                                 as X+import           Text.XML.Cursor+                 ( ($/)+                 , (&/)+                 )++-- | Run an instance of 'Action', receiving a 'ConsumedResponse'. The retention+-- of 'Network.DO.Spaces.Types.SpacesMetadata' can be controlled by passing a+-- 'Network.DO.Spaces.Types.WithMetadata' constructor+runAction :: forall a m.+          (MonadSpaces m, Action m a)+          => WithMetadata+          -> a+          -> m (SpacesResponse a)+runAction withMD action = do+    now <- liftIO getCurrentTime+    reqBuilder <- buildRequest action+    req <- newSpacesRequest reqBuilder now+    let stringToSign = mkStringToSign req+        auth         = mkAuthorization req stringToSign+        finalized    = finalize req auth++    withResponse @_ @m finalized $ \resp -> do+        let status   = resp & H.responseStatus+            body     = resp & H.responseBody+            headers  = resp & H.responseHeaders+            metadata = case withMD of+                NoMetadata   -> Nothing+                KeepMetadata -> Just $ getResponseMetadata status raw+            raw      = RawResponse { .. }++        when ((status & H.statusCode) >= 300)+            $ handleMaybe (parseErrorResponse status) raw >>= \case+                Just apiErr -> throwM apiErr+                Nothing     -> throwM . HTTPStatus status+                    =<< runConduit (body .| sinkLbs)++        result <- consumeResponse @_ @a raw+        return SpacesResponse { .. }++parseErrorResponse+    :: (MonadThrow m, MonadIO m) => Status -> RawResponse m -> m APIException+parseErrorResponse status raw = do+    cursor <- xmlDocCursor raw+    code <- X.force (xmlElemError "Code")+        $ cursor $/ X.laxElement "Code" &/ X.content+    requestID <- X.force (xmlElemError "RequestId")+        $ cursor $/ X.laxElement "RequestId" &/ X.content+    hostID <- X.force (xmlElemError "HostId")+        $ cursor $/ X.laxElement "HostId" &/ X.content+    return APIException { .. }+
+ src/Network/DO/Spaces/Actions/CopyObject.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.CopyObject+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.CopyObject+    ( MetadataDirective(..)+    , CopyObject(..)+    , CopyObjectResponse(..)+    ) where++import           Control.Monad           ( when )+import           Control.Monad.Catch     ( MonadThrow(throwM) )+import           Control.Monad.Reader    ( MonadReader(ask) )++import qualified Data.ByteString.Char8   as C+import qualified Data.CaseInsensitive    as CI+import           Data.Char               ( toUpper )+import           Data.Coerce             ( coerce )+import           Data.Maybe              ( catMaybes )+import qualified Data.Text.Encoding      as T+import           Data.Time               ( UTCTime )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket(Bucket)+                 , CannedACL+                 , ClientException(InvalidRequest)+                 , ETag+                 , Method(PUT)+                 , MonadSpaces+                 , Object(Object)+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils+                 ( bshow+                 , etagP+                 , lastModifiedP+                 , showCannedACL+                 , xmlDocCursor+                 )++-- | Whether the 'Object'\'s metadata should be copied or replaced. Replace is+-- required to copy an object to itself+data MetadataDirective = Copy | Replace+    deriving ( Show, Eq, Generic )++-- | Copy and 'Object' from one 'Bucket' to another. Both buckets must+-- be in the same region+data CopyObject = CopyObject+    { srcBucket         :: Bucket+    , destBucket        :: Bucket+    , srcObject         :: Object+    , destObject        :: Object+    , metadataDirective :: MetadataDirective+    , acl               :: Maybe CannedACL+    }+    deriving ( Show, Eq, Generic )++data CopyObjectResponse =+    CopyObjectResponse { etag :: ETag, lastModified :: UTCTime }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m CopyObject where+    type ConsumedResponse CopyObject = CopyObjectResponse++    buildRequest CopyObject { .. } = do+        when (and [ srcObject == destObject, metadataDirective == Copy ])+            . throwM+            . InvalidRequest+            $ mconcat [ "CopyObject: "+                      , "Object cannot be copied to itself unless "+                      , "REPLACE directive is specified"+                      ]+        spaces <- ask+        return SpacesRequestBuilder+               { object         = Just destObject+               , bucket         = Just destBucket+               , method         = Just PUT+               , body           = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , overrideRegion = Nothing+               , ..+               }+      where+        headers = [ ( CI.mk "x-amz-copy-source"+                    , mconcat [ "/"+                              , T.encodeUtf8 $ coerce srcBucket+                              , "/"+                              , T.encodeUtf8 $ coerce srcObject+                              ]+                    )+                  , ( CI.mk "x-amz-metadata-directive"+                    , C.map toUpper $ bshow metadataDirective+                    )+                  ]+            <> catMaybes [ (CI.mk "x-amz-acl", ) . showCannedACL <$> acl ]++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        CopyObjectResponse <$> etagP cursor <*> lastModifiedP cursor
+ src/Network/DO/Spaces/Actions/CreateBucket.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.CreateBucket+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.CreateBucket+    ( CreateBucket(..)+    , CreateBucketResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import qualified Data.CaseInsensitive    as CI+import           Data.Maybe              ( catMaybes )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , CannedACL+                 , Method(PUT)+                 , MonadSpaces+                 , Region+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( showCannedACL )++-- | Create a new, empty 'Bucket'+data CreateBucket = CreateBucket+    { bucket :: Bucket -- ^ The name of the new 'Bucket' to create+    , region :: Maybe Region+    , acl    :: Maybe CannedACL+      -- ^ The 'CannedACL' to use; defaults to+      -- 'Network.DO.Spaces.Types.CannedACL.Private'+    }+    deriving ( Show, Eq, Generic )++type CreateBucketResponse = ()++instance MonadSpaces m => Action m CreateBucket where+    type ConsumedResponse CreateBucket = CreateBucketResponse++    buildRequest CreateBucket { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Just PUT+               , overrideRegion = region+               , body           = Nothing+               , object         = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , ..+               }+      where+        headers = catMaybes [ (CI.mk "x-amz-acl", ) . showCannedACL <$> acl ]++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/DeleteBucket.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.DeleteBucket+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.DeleteBucket+    ( DeleteBucket(..)+    , DeleteBucketResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Method(DELETE)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )++-- | Delete a single 'Bucket'. Note that it must be empty+data DeleteBucket = DeleteBucket+    { bucket :: Bucket -- ^ The name of the 'Bucket' to delete+    }+    deriving ( Show, Eq, Generic )++type DeleteBucketResponse = ()++instance MonadSpaces m => Action m DeleteBucket where+    type ConsumedResponse DeleteBucket = DeleteBucketResponse++    buildRequest DeleteBucket { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { method         = Just DELETE+               , bucket         = Just bucket+               , body           = Nothing+               , object         = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , headers        = mempty+               , overrideRegion = Nothing+               , ..+               }++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/DeleteBucketCORS.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.DeleteBucketCORS+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.DeleteBucketCORS+    ( DeleteBucketCORS(..)+    , DeleteBucketCORSResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Method(DELETE)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )+import qualified Network.HTTP.Types      as H++-- | Delete all of a 'Bucket'\'s configured 'Network.DO.Spaces.Types.CORSRule's+data DeleteBucketCORS = DeleteBucketCORS { bucket :: Bucket }+    deriving ( Show, Eq, Generic )++type DeleteBucketCORSResponse = ()++instance MonadSpaces m => Action m DeleteBucketCORS where+    type ConsumedResponse DeleteBucketCORS = DeleteBucketCORSResponse++    buildRequest DeleteBucketCORS { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Just DELETE+               , body           = Nothing+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "cors" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/DeleteBucketLifecycle.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetBucketLifecycle+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.DeleteBucketLifecycle+    ( DeleteBucketLifecycle(..)+    , DeleteBucketLifecycleResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Method(DELETE)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )+import qualified Network.HTTP.Types      as H++data DeleteBucketLifecycle = DeleteBucketLifecycle { bucket :: Bucket }+    deriving ( Show, Eq, Generic )++type DeleteBucketLifecycleResponse = ()++instance MonadSpaces m => Action m DeleteBucketLifecycle where+    type ConsumedResponse DeleteBucketLifecycle = DeleteBucketLifecycleResponse++    buildRequest DeleteBucketLifecycle { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Just DELETE+               , body           = Nothing+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "lifecycle" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/DeleteObject.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.DeleteObject+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.DeleteObject+    ( DeleteObject(..)+    , DeleteObjectResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Method(DELETE)+                 , MonadSpaces+                 , Object+                 , SpacesRequestBuilder(..)+                 )++-- | Delete a single 'Object'+data DeleteObject = DeleteObject { bucket :: Bucket, object :: Object }+    deriving ( Show, Eq, Generic )++type DeleteObjectResponse = ()++instance MonadSpaces m => Action m DeleteObject where+    type ConsumedResponse DeleteObject = DeleteObjectResponse++    buildRequest DeleteObject { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Just DELETE+               , body           = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , headers        = mempty+               , overrideRegion = Nothing+               , ..+               }++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/GetBucketACLs.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetBucketACLs+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetBucketACLs+    ( GetBucketACLs(..)+    , GetBucketACLsResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( ACLResponse+                 , Action(..)+                 , Bucket+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( aclP, xmlDocCursor )+import qualified Network.HTTP.Types      as H++-- | Get the full Access Control List associated with a 'Bucket'+data GetBucketACLs = GetBucketACLs { bucket :: Bucket }+    deriving ( Show, Eq, Generic )++type GetBucketACLsResponse = ACLResponse++instance MonadSpaces m => Action m GetBucketACLs where+    type ConsumedResponse GetBucketACLs = GetBucketACLsResponse++    buildRequest GetBucketACLs { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Nothing+               , body           = Nothing+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "acl" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse raw = aclP =<< xmlDocCursor raw
+ src/Network/DO/Spaces/Actions/GetBucketCORS.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetBucketCORS+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetBucketCORS+    ( GetBucketCORS(..)+    , GetBucketCORSResponse(..)+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )+import qualified Data.CaseInsensitive    as CI+import           Data.Maybe              ( mapMaybe )+import           Data.Sequence           ( Seq )+import qualified Data.Sequence           as S+import qualified Data.Text               as T+import qualified Data.Text.Encoding      as T++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , CORSRule(..)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 , mkCORSRule+                 )+import           Network.DO.Spaces.Utils ( xmlDocCursor, xmlElemError )+import qualified Network.HTTP.Types      as H++import           Text.Read               ( readMaybe )+import qualified Text.XML.Cursor         as X+import           Text.XML.Cursor         ( ($/), (&/), (&|) )++-- | Get the 'CORSRule's associated with a 'Bucket'+data GetBucketCORS = GetBucketCORS { bucket :: Bucket }+    deriving ( Show, Eq, Generic )++data GetBucketCORSResponse = GetBucketCORSResponse { rules :: Seq CORSRule }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m GetBucketCORS where+    type ConsumedResponse GetBucketCORS = GetBucketCORSResponse++    buildRequest GetBucketCORS { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Nothing+               , body           = Nothing+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "cors" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        GetBucketCORSResponse . S.fromList+            <$> sequence (cursor $/ X.laxElement "CORSRule" &| ruleP)+      where+        ruleP c = do+            allowedOrigin <- X.force (xmlElemError "AllowedOrigin")+                $ c $/ X.laxElement "AllowedOrigin" &/ X.content++            mkCORSRule allowedOrigin+                       (mapMaybe (readMaybe . T.unpack) allowedMethods)+                       (CI.mk . T.encodeUtf8 <$> allowedHeaders)+          where+            allowedHeaders = c $/ X.laxElement "AllowedHeader" &/ X.content++            allowedMethods = c $/ X.laxElement "AllowedMethod" &/ X.content
+ src/Network/DO/Spaces/Actions/GetBucketLifecycle.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetBucketLifecycle+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetBucketLifecycle+    ( GetBucketLifecycle(..)+    , GetBucketLifecycleResponse(..)+    ) where++import           Control.Monad           ( join )+import           Control.Monad.Catch     ( MonadThrow(throwM) )+import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )+import           Data.Coerce             ( coerce )+import           Data.Maybe              ( listToMaybe )+import qualified Data.Text               as T++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , ClientException(InvalidXML)+                 , LifecycleExpiration(AfterDays, OnDate)+                 , LifecycleID(LifecycleID)+                 , LifecycleRule(..)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils+                 ( xmlDocCursor+                 , xmlElemError+                 , xmlMaybeElem+                 , xmlUTCTime+                 )+import qualified Network.HTTP.Types      as H++import           Text.Read               ( readMaybe )+import qualified Text.XML                as X+import qualified Text.XML.Cursor         as X+import           Text.XML.Cursor         ( ($/), (&/), (&|) )+import           Text.XML.Cursor.Generic ( Cursor )++-- | Get the 'LifecycleRule' configuration for a 'Bucket'. Note that unless+-- you have explicitly configured lifecycle rules, this will fail with a 404+-- status and an error code of @NoSuchLifecycleConfiguration@+data GetBucketLifecycle = GetBucketLifecycle { bucket :: Bucket }+    deriving ( Show, Eq, Generic )++data GetBucketLifecycleResponse =+    GetBucketLifecycleResponse { rules :: [LifecycleRule] }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m GetBucketLifecycle where+    type ConsumedResponse GetBucketLifecycle = GetBucketLifecycleResponse++    buildRequest GetBucketLifecycle { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Nothing+               , body           = Nothing+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "lifecycle" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        GetBucketLifecycleResponse+            <$> sequence (cursor $/ X.laxElement "Rule" &| ruleP)++ruleP :: MonadThrow m => Cursor X.Node -> m LifecycleRule+ruleP c = do+    id' <- X.force (xmlElemError "ID")+        $ c $/ X.laxElement "ID" &/ X.content &| coerce+    enabled <- X.forceM (xmlElemError "Status")+        $ c $/ X.laxElement "Status" &/ X.content &| readStatus+    return LifecycleRule { .. }+  where+    prefix = xmlMaybeElem c "Prefix"++    abortIncomplete = join . listToMaybe+        $ c $/ X.laxElement "AbortIncompleteMultipartUpload" &| abortP++    expiration = join . sequence . listToMaybe+        $ c $/ X.laxElement "Expiration" &| expiresP++    abortP c' = X.forceM (xmlElemError "DaysAfterInitiation")+        $ c' $/ X.laxElement "DaysAfterInitiation" &/ X.content+        &| (readMaybe . T.unpack)++    readStatus = \case+        "Enabled"  -> return True+        "Disabled" -> return False+        _          -> throwM $ InvalidXML "GetBucketLifecycle: invalid Status"++    -- TODO find a less hideous way of doing this+    expiresP (X.node -> X.NodeElement (X.Element _ _ elems)) = case elems of+        (_ : el : _) -> case el of+            X.NodeElement (X.Element (X.nameLocalName -> name) _ _)+                | name == "Days" -> AfterDays+                    <$> (readMaybe . T.unpack . mconcat+                         $ (X.fromNode el $/ X.content))+                | name == "Date" -> OnDate+                    <$> (xmlUTCTime @Maybe . mconcat+                         $ (X.fromNode el $/ X.content))+            _ -> throwInvalidExpires+        _            -> throwInvalidExpires++    expiresP _ = throwInvalidExpires++    throwInvalidExpires =+        throwM $ InvalidXML "GetBucketLifecycle: invalid Expiration"
+ src/Network/DO/Spaces/Actions/GetBucketLocation.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetBucketLocation+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetBucketLocation+    ( GetBucketLocation(..)+    , GetBucketLocationResponse(..)+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )+import qualified Data.Text               as T++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , MonadSpaces+                 , Region(..)+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( slugToRegion+                                         , xmlDocCursor+                                         , xmlElemError+                                         )+import qualified Network.HTTP.Types      as H++import qualified Text.XML.Cursor         as X+import           Text.XML.Cursor         ( ($.//), (&/), (&|) )++-- | Query the location (the 'Region') of a 'Bucket'+data GetBucketLocation = GetBucketLocation+    { bucket :: Bucket+      -- ^ The name of the 'Bucket' whose location you'd like to retrieve+    }+    deriving ( Show, Eq, Generic )++data GetBucketLocationResponse = GetBucketLocationResponse+    { locationConstraint :: Region+      -- ^ The 'Region' of the queried 'Bucket'+    }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m GetBucketLocation where+    type ConsumedResponse GetBucketLocation = GetBucketLocationResponse++    buildRequest GetBucketLocation { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Nothing+               , body           = Nothing+               , object         = Nothing+               , headers        = mempty+               , overrideRegion = Nothing+               , queryString    = Nothing+               , subresources   = Just+                     $ H.toQuery [ ( "location" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        GetBucketLocationResponse+            <$> (X.forceM (xmlElemError "LocationConstraint")+                 $ cursor $.// X.laxElement "LocationConstraint" &/ X.content+                 &| (slugToRegion . T.strip))
+ src/Network/DO/Spaces/Actions/GetObject.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetObject+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetObject+    ( GetObject(..)+    , GetObjectResponse(..)+    ) where++import           Conduit                 ( (.|), runConduit )++import           Control.Monad.Reader    ( MonadReader(ask) )++import qualified Data.ByteString.Lazy    as LB+import           Data.Conduit.Binary     ( sinkLbs )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , MonadSpaces+                 , Object+                 , ObjectMetadata+                 , RawResponse(..)+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( lookupObjectMetadata )++-- | Retrieve an 'Object' along with its associated metadata. The object's data+-- is read into a lazy 'LB.ByteString'+data GetObject = GetObject { bucket :: Bucket, object :: Object }+    deriving ( Show, Eq, Generic )++data GetObjectResponse = GetObjectResponse+    { objectMetadata :: ObjectMetadata, objectData :: LB.ByteString }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m GetObject where+    type ConsumedResponse GetObject = GetObjectResponse++    buildRequest GetObject { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Nothing+               , body           = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , overrideRegion = Nothing+               , headers        = mempty+               , ..+               }++    consumeResponse raw@RawResponse { .. } = GetObjectResponse+        <$> lookupObjectMetadata raw+        <*> runConduit (body .| sinkLbs)
+ src/Network/DO/Spaces/Actions/GetObjectACLs.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetObjectACLs+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetObjectACLs+    ( GetObjectACLs(..)+    , GetObjectACLsResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( ACLResponse+                 , Action(..)+                 , Bucket+                 , MonadSpaces+                 , Object+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( aclP, xmlDocCursor )+import qualified Network.HTTP.Types      as H++-- | Get the full Access Control List associated with a 'Bucket'+data GetObjectACLs = GetObjectACLs { bucket :: Bucket, object :: Object }+    deriving ( Show, Eq, Generic )++type GetObjectACLsResponse = ACLResponse++instance MonadSpaces m => Action m GetObjectACLs where+    type ConsumedResponse GetObjectACLs = GetObjectACLsResponse++    buildRequest GetObjectACLs { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Nothing+               , body           = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "acl" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse raw = aclP =<< xmlDocCursor raw
+ src/Network/DO/Spaces/Actions/GetObjectInfo.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetObjectInfo+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.GetObjectInfo+    ( GetObjectInfo(..)+    , GetObjectInfoResponse+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Method(HEAD)+                 , MonadSpaces+                 , Object+                 , ObjectMetadata(..)+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( lookupObjectMetadata )++-- | Get information about an 'Object'; the response does not contain the+-- object itself+data GetObjectInfo = GetObjectInfo { bucket :: Bucket, object :: Object }+    deriving ( Show, Eq, Generic )++type GetObjectInfoResponse = ObjectMetadata++instance MonadSpaces m => Action m GetObjectInfo where+    type ConsumedResponse GetObjectInfo = GetObjectInfoResponse++    buildRequest GetObjectInfo { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Just HEAD+               , body           = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , headers        = mempty+               , overrideRegion = Nothing+               , ..+               }++    consumeResponse = lookupObjectMetadata
+ src/Network/DO/Spaces/Actions/ListAllBuckets.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.ListAllBuckets+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.ListAllBuckets+    ( ListAllBuckets(..)+    , ListAllBucketsResponse(..)+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.Coerce             ( coerce )+import           Data.Sequence           ( Seq )+import qualified Data.Sequence           as S++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket(Bucket)+                 , BucketInfo(..)+                 , MonadSpaces+                 , Owner(..)+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils+                 ( ownerP+                 , xmlDocCursor+                 , xmlElemError+                 , xmlUTCTime+                 )++import qualified Text.XML.Cursor         as X+import           Text.XML.Cursor         ( ($/), (&/), (&|) )++-- | List all of your 'Bucket's withing the 'Network.DO.Spaces.Region' you have configured+data ListAllBuckets = ListAllBuckets+    deriving ( Show, Eq, Generic )++data ListAllBucketsResponse =+    ListAllBucketsResponse { owner :: Owner, buckets :: Seq BucketInfo }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m ListAllBuckets where+    type ConsumedResponse ListAllBuckets = ListAllBucketsResponse++    buildRequest _ = do+        spaces <- ask+        return SpacesRequestBuilder+               { body           = Nothing+               , method         = Nothing+               , object         = Nothing+               , queryString    = Nothing+               , subresources   = Nothing+               , bucket         = Nothing+               , headers        = mempty+               , overrideRegion = Nothing+               , ..+               }++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        owner <- X.forceM (xmlElemError "Owner")+            $ cursor $/ X.laxElement "Owner" &| ownerP+        bs <- X.force (xmlElemError "Buckets")+            $ cursor $/ X.laxElement "Buckets" &| bucketsP+        return ListAllBucketsResponse { buckets = S.fromList bs, .. }+      where+        bucketsP c = X.forceM (xmlElemError "Bucket") . sequence+            $ c $/ X.laxElement "Bucket" &| bucketInfoP++        bucketInfoP c = do+            name <- X.force (xmlElemError "Name")+                $ c $/ X.laxElement "Name" &/ X.content &| coerce+            creationDate <- X.forceM (xmlElemError "Creation date")+                $ c $/ X.laxElement "CreationDate" &/ X.content &| xmlUTCTime+            return BucketInfo { .. }
+ src/Network/DO/Spaces/Actions/ListBucket.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.ListBucket+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.ListBucket+    ( ListBucket(..)+    , ListBucketResponse(..)+    ) where++import           Control.Monad           ( when )+import           Control.Monad.Catch     ( MonadThrow(throwM) )+import           Control.Monad.Extra     ( orM )+import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )+import qualified Data.ByteString.Char8   as C+import           Data.Coerce             ( coerce )+import           Data.Sequence           ( Seq )+import qualified Data.Sequence           as S+import           Data.Text               ( Text )+import qualified Data.Text.Encoding      as T++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket(Bucket)+                 , ClientException(InvalidRequest)+                 , MonadSpaces+                 , Object(..)+                 , ObjectInfo(..)+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils+                 ( bshow+                 , etagP+                 , isTruncP+                 , lastModifiedP+                 , ownerP+                 , xmlDocCursor+                 , xmlElemError+                 , xmlInt+                 , xmlMaybeElem+                 , xmlNum+                 )+import qualified Network.HTTP.Types      as H++import qualified Text.XML.Cursor         as X+import           Text.XML.Cursor         ( ($/), (&/), (&|) )++-- | List the contents ('Object's) of a 'Bucket'+data ListBucket = ListBucket+    { bucket    :: Bucket+    , delimiter :: Maybe Char -- ^ Character used to group keys+    , marker    :: Maybe Object+      -- ^ The 'Object' to start with when listing the bucket's contents+    , maxKeys   :: Maybe Int+      -- ^ Max number of 'Object's to return, between 0 and 1,000 (inclusive)+    , prefix    :: Maybe Text+      -- ^ String value to group keys. Only objects whose names begin with the+      -- prefix are returned+    }+    deriving ( Show, Eq, Generic )++data ListBucketResponse = ListBucketResponse+    { bucket      :: Bucket+    , prefix      :: Maybe Text -- ^ The 'Object' prefix, if supplied as a query param+    , marker      :: Maybe Object+      -- ^ An 'Object' indicating where the list of 'Object's begin; 'Nothing'+      -- denotes the beginning of the list+    , nextMarker  :: Maybe Object+      -- ^ The 'Object' that should be used as the @marker@ query param in+      -- subsequent requests+    , maxKeys     :: Int+      -- ^ Maximum number of 'ObjectInfo's to include; based on request parameter+      -- of the same name+    , isTruncated :: Bool+      -- ^ Indicates whether the response contains all possible 'Object's+    , objects     :: Seq ObjectInfo+    }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m ListBucket where+    type ConsumedResponse ListBucket = ListBucketResponse++    buildRequest ListBucket { .. } = do+        when (Just True == orM [ (< 0) <$> maxKeys, (> 1000) <$> maxKeys ])+            . throwM+            $ InvalidRequest "ListBucket: maxKeys must be >= 0 && <= 1000"+        spaces <- ask++        return SpacesRequestBuilder+               { bucket         = Just bucket+               , body           = Nothing+               , object         = Nothing+               , method         = Nothing+               , headers        = mempty+               , subresources   = Nothing+               , overrideRegion = Nothing+               , ..+               }+      where+        queryString = Just+            $ H.toQuery [ ("delimiter" :: ByteString, ) . C.singleton+                          <$> delimiter+                        , ("marker", ) . T.encodeUtf8 . unObject <$> marker+                        , ("max-keys", ) . bshow <$> maxKeys+                        , ("prefix", ) . T.encodeUtf8 <$> prefix+                        ]++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        bucket <- X.force (xmlElemError "Name")+            $ cursor $/ X.laxElement "Name" &/ X.content &| coerce+        maxKeys <- xmlNum "MaxKeys" cursor+        isTruncated <- isTruncP cursor+        objects <- S.fromList+            <$> sequence (cursor $/ X.laxElement "Contents" &| objectInfoP)+        let prefix     = xmlMaybeElem cursor "Prefix"+            marker     = coerce <$> xmlMaybeElem cursor "Marker"+            nextMarker = coerce <$> xmlMaybeElem cursor "NextMarker"+        return ListBucketResponse { .. }+      where+        objectInfoP c = do+            object <- X.force (xmlElemError "Key")+                $ c $/ X.laxElement "Key" &/ X.content &| coerce+            lastModified <- lastModifiedP c+            etag <- etagP c+            size <- X.forceM (xmlElemError "Size")+                $ c $/ X.laxElement "Size" &/ X.content &| xmlInt+            owner <- X.forceM (xmlElemError "Owner")+                $ c $/ X.laxElement "Owner" &| ownerP+            return ObjectInfo { .. }
+ src/Network/DO/Spaces/Actions/SetBucketACLs.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.SetBucketACLs+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.SetBucketACLs+    ( SetBucketACLs(..)+    , SetBucketACLsResponse+    ) where++import           Control.Monad.Reader        ( MonadReader(ask) )++import           Data.ByteString             ( ByteString )++import           GHC.Generics                ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Grant(..)+                 , Method(PUT)+                 , MonadSpaces+                 , Owner+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils     ( writeACLSetter )+import           Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) )+import qualified Network.HTTP.Types          as H++data SetBucketACLs = SetBucketACLs+    { bucket :: Bucket+    , acls   :: [Grant]+    , owner  :: Owner -- ^ The bucket owner+    }+    deriving ( Show, Eq, Generic )++type SetBucketACLsResponse = ()++instance MonadSpaces m => Action m SetBucketACLs where+    type ConsumedResponse SetBucketACLs = SetBucketACLsResponse++    buildRequest sba@SetBucketACLs { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Just PUT+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , body           = Just . RequestBodyLBS $ writeACLSetter sba+               , subresources   = Just+                     $ H.toQuery [ ( "acl" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/SetBucketCORS.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.SetBucketCORS+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+{-# OPTIONS_GHC -Wno-unused-imports #-}++module Network.DO.Spaces.Actions.SetBucketCORS+    ( SetBucketCORSResponse+    , SetBucketCORS(..)+    ) where++import           Control.Monad.Reader    ( MonadReader(ask) )++import           Data.ByteString         ( ByteString )+import qualified Data.CaseInsensitive    as CI+import qualified Data.Text               as T+import qualified Data.Text.Encoding      as T++import           GHC.Generics            ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , CORSRule(..)+                 , Method(PUT)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils ( mkNode, tshow )+import           Network.HTTP.Conduit    ( RequestBody(RequestBodyLBS) )+import qualified Network.HTTP.Types      as H++import qualified Text.XML                as X++-- | Set a 'Bucket'\'s 'CORSRule's+data SetBucketCORS = SetBucketCORS { bucket :: Bucket, rules :: [CORSRule] }+    deriving ( Show, Eq, Generic )++type SetBucketCORSResponse = ()++instance MonadSpaces m => Action m SetBucketCORS where+    type ConsumedResponse SetBucketCORS = SetBucketCORSResponse++    buildRequest SetBucketCORS { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Just PUT+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "cors" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }+      where+        body = Just . RequestBodyLBS . X.renderLBS X.def+            $ X.Document prologue root mempty++        prologue = X.Prologue mempty Nothing mempty++        root = X.Element "CORSConfiguration" mempty (ruleNode <$> rules)++        ruleNode CORSRule { .. } = X.NodeElement . X.Element "CORSRule" mempty+            $ mconcat [ [ mkNode "AllowedOrigin" allowedOrigin ]+                      , mkNode "AllowedHeader" . T.decodeUtf8 . CI.original+                        <$> allowedHeaders+                      , mkNode "AllowedMethod" . tshow <$> allowedMethods+                      ]++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/SetBucketLifecycle.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.GetBucketLifecycle+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.SetBucketLifecycle+    ( SetBucketLifecycle(..)+    , SetBucketLifecycleResponse+    ) where++import           Control.Monad.Reader        ( MonadReader(ask) )++import           Data.ByteString             ( ByteString )+import           Data.Coerce                 ( coerce )+import qualified Data.Text                   as T+import           Data.Time.Format.ISO8601    ( iso8601Show )++import           GHC.Generics                ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , LifecycleExpiration(AfterDays, OnDate)+                 , LifecycleID(LifecycleID)+                 , LifecycleRule(..)+                 , Method(PUT)+                 , MonadSpaces+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils     ( mkNode, tshow )+import           Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) )+import qualified Network.HTTP.Types          as H++import qualified Text.XML                    as X++-- | Configure the 'LifecycleRule's for a 'Bucket'+data SetBucketLifecycle =+    SetBucketLifecycle { bucket :: Bucket, rules :: [LifecycleRule] }+    deriving ( Show, Eq, Generic )++type SetBucketLifecycleResponse = ()++instance MonadSpaces m => Action m SetBucketLifecycle where+    type ConsumedResponse SetBucketLifecycle = SetBucketLifecycleResponse++    buildRequest SetBucketLifecycle { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , method         = Just PUT+               , object         = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "lifecycle" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }+      where+        body = Just . RequestBodyLBS . X.renderLBS X.def+            $ X.Document prologue root mempty++        prologue = X.Prologue mempty Nothing mempty++        root = X.Element name mempty (rulesNode <$> rules)+          where+            name = X.Name "LifecycleConfiguration"+                          (Just "http://s3.amazonaws.com/doc/2006-03-01/")+                          Nothing++        rulesNode LifecycleRule { .. } =+            X.NodeElement $ X.Element "Rule" mempty nodes+          where+            nodes = [ mkNode "ID" (coerce id')+                    , mkNode "Status" (showEnabled enabled)+                    ]+                <> foldMap (pure . mkNode "Prefix") prefix+                <> foldMap (pure . mkExpireNode) expiration+                <> foldMap (pure . mkAbortNode) abortIncomplete++            showEnabled = \case+                True  -> "Enabled"+                False -> "Disabled"++            mkExpireNode conf = X.NodeElement+                $ X.Element "Expiration" mempty (pure $ mkExNodes conf)+              where+                mkExNodes (AfterDays days) = mkNode "Days" (tshow days)+                mkExNodes (OnDate date)    =+                    mkNode "Date" (T.pack $ iso8601Show date)++            mkAbortNode days = X.NodeElement+                $ X.Element "AbortIncompleteMultipartUpload"+                            mempty+                            [ mkNode "DaysAfterInitiation" (tshow days) ]++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/SetObjectACLs.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.SetObjectACLs+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.SetObjectACLs+    ( SetObjectACLs(..)+    , SetObjectACLsResponse+    ) where++import           Control.Monad.Reader        ( MonadReader(ask) )++import           Data.ByteString             ( ByteString )++import           GHC.Generics                ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , Grant(..)+                 , Method(PUT)+                 , MonadSpaces+                 , Object+                 , Owner+                 , SpacesRequestBuilder(..)+                 )+import           Network.DO.Spaces.Utils     ( writeACLSetter )+import           Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) )+import qualified Network.HTTP.Types          as H++-- | Get the full Access Control List associated with a 'Bucket'+data SetObjectACLs = SetObjectACLs+    { bucket :: Bucket+    , object :: Object+    , owner  :: Owner -- ^ The object owner+    , acls   :: [Grant]+    }+    deriving ( Show, Eq, Generic )++type SetObjectACLsResponse = ()++instance MonadSpaces m => Action m SetObjectACLs where+    type ConsumedResponse SetObjectACLs = SetObjectACLsResponse++    buildRequest soa@SetObjectACLs { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Just PUT+               , body           = Just . RequestBodyLBS $ writeACLSetter soa+               , overrideRegion = Nothing+               , queryString    = Nothing+               , headers        = mempty+               , subresources   = Just+                     $ H.toQuery [ ( "acl" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }++    consumeResponse _ = return ()
+ src/Network/DO/Spaces/Actions/UploadMultipart.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.UploadMultipart+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.UploadMultipart+    ( BeginMultipart(..)+    , BeginMultipartResponse(..)+    , UploadPart(..)+    , UploadPartResponse(..)+    , ListParts(..)+    , Part(..)+    , ListPartsResponse(..)+    , UploadID+    , CancelMultipart(..)+    , MultipartSession(..)+    , CancelMultipartResponse+    , CompleteMultipart(..)+    , CompleteMultipartResponse(..)+    ) where++import           Control.Monad.Catch         ( MonadThrow(throwM) )+import           Control.Monad.Reader        ( MonadReader(ask) )+import           Control.Monad.Trans.Maybe   ( MaybeT(runMaybeT) )++import           Data.ByteString             ( ByteString )+import qualified Data.CaseInsensitive        as CI+import           Data.Generics.Product       ( HasField(field) )+import           Data.Sequence               ( Seq )+import qualified Data.Sequence               as S+import           Data.Text                   ( Text )+import           Data.Time                   ( UTCTime )++import           GHC.Generics                ( Generic )++import           Lens.Micro                  ( (^.), (^?) )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , ClientException(OtherError)+                 , ETag+                 , Method(POST, DELETE, PUT)+                 , MonadSpaces+                 , Object+                 , SpacesRequestBuilder(..)+                 , UploadHeaders+                 )+import           Network.DO.Spaces.Utils+                 ( bucketP+                 , etagP+                 , isTruncP+                 , lastModifiedP+                 , lookupHeader+                 , mkNode+                 , objectP+                 , quote+                 , readEtag+                 , renderUploadHeaders+                 , tshow+                 , xmlDocCursor+                 , xmlElemError+                 , xmlNum+                 )+import           Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) )+import qualified Network.HTTP.Types          as H+import           Network.Mime                ( MimeType )++import qualified Text.XML                    as X+import qualified Text.XML.Cursor             as X+import           Text.XML.Cursor             ( ($/), (&/), (&|) )++-- | A single part of a multipart upload session. Returned when querying 'ListParts'+data Part = Part+    { partNumber   :: Int+    , lastModified :: UTCTime+    , etag         :: ETag+    , size         :: Int -- ^ Size in bytes+    }+    deriving ( Show, Eq, Generic )++data MultipartSession = MultipartSession+    { bucket   :: Bucket+    , object   :: Object+    , uploadID :: UploadID --+    }+    deriving ( Show, Eq, Generic )++-- | A unique ID assigned to a multipart upload session+type UploadID = Text++-- | Initiate a multipart upload session+data BeginMultipart = BeginMultipart+    { bucket          :: Bucket+    , object          :: Object+    , optionalHeaders :: UploadHeaders+    , contentType     :: Maybe MimeType+    }+    deriving ( Show, Eq, Generic )++newtype BeginMultipartResponse =+    BeginMultipartResponse { session :: MultipartSession }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m BeginMultipart where+    type (ConsumedResponse BeginMultipart) = BeginMultipartResponse++    buildRequest BeginMultipart { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Just POST+               , body           = Nothing+               , overrideRegion = Nothing+               , queryString    = Nothing+               , subresources   = Just+                     $ H.toQuery [ ( "uploads" :: ByteString+                                   , Nothing :: Maybe ByteString+                                   )+                                 ]+               , ..+               }+      where+        headers = maybe id+                        (\ct -> (:) (CI.mk "Content-Type", ct))+                        contentType+                        (renderUploadHeaders optionalHeaders)++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        object <- objectP cursor+        bucket <- bucketP cursor+        uploadID <- X.force (xmlElemError "UploadId")+            $ cursor $/ X.laxElement "UploadId" &/ X.content+        return $ BeginMultipartResponse { session = MultipartSession { .. } }++data UploadPart = UploadPart+    { session :: MultipartSession, partNumber :: Int, body :: RequestBody }+    deriving ( Generic )++data UploadPartResponse = UploadPartResponse { etag :: ETag }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m UploadPart where+    type (ConsumedResponse UploadPart) = UploadPartResponse++    buildRequest UploadPart { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = session ^? field @"bucket"+               , object         = session ^? field @"object"+               , body           = Just body+               , method         = Just PUT+               , overrideRegion = Nothing+               , subresources   = Nothing+               , headers        = mempty+               , queryString    = Just+                     $ H.toQuery [ ("partNumber" :: Text, tshow partNumber)+                                 , ("uploadId", session ^. field @"uploadID")+                                 ]+               , ..+               }++    consumeResponse raw =+        runMaybeT (UploadPartResponse+                   <$> (readEtag =<< lookupHeader raw "etag"))+        >>= \case+            Nothing -> throwM $ OtherError "Missing/malformed headers"+            Just r  -> return r++-- | Complete a multipart session+data CompleteMultipart = CompleteMultipart+    { session :: MultipartSession+    , parts   :: [(Int, ETag)]+      -- ^ The part numbers and 'ETag's of each uploaded part+    }+    deriving ( Show, Eq, Generic )++data CompleteMultipartResponse = CompleteMultipartResponse+    { location :: Text+    , bucket   :: Bucket+    , object   :: Object+    , etag     :: ETag+      -- ^ The MD5 hash of the final object, i.e. all of the cumulative+      -- uploaded parts+    }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m CompleteMultipart where+    type ConsumedResponse CompleteMultipart = CompleteMultipartResponse++    buildRequest CompleteMultipart { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = session ^? field @"bucket"+               , object         = session ^? field @"object"+               , method         = Just POST+               , overrideRegion = Nothing+               , subresources   = Nothing+               , headers        = mempty+               , queryString    = Just+                     $ H.toQuery [ ( "uploadId" :: Text+                                   , session ^. field @"uploadID"+                                   )+                                 ]+               , ..+               }+      where+        body               = Just . RequestBodyLBS . X.renderLBS X.def+            $ X.Document prologue root mempty++        prologue           = X.Prologue mempty Nothing mempty++        root               =+            X.Element "CompleteMultipartUpload" mempty (partNode <$> parts)++        partNode (n, etag) = X.NodeElement+            $ X.Element "Part"+                        mempty+                        [ mkNode "PartNumber" (tshow n)+                        , mkNode "ETag" (quote etag)+                        ]++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        bucket <- bucketP cursor+        location <- X.force (xmlElemError "Location")+            $ cursor $/ X.laxElement "Location" &/ X.content+        object <- objectP cursor+        etag <- etagP cursor+        return CompleteMultipartResponse { .. }++-- | Cancel an active multipart upload session+newtype CancelMultipart = CancelMultipart { session :: MultipartSession }+    deriving ( Show, Eq, Generic )++type CancelMultipartResponse = ()++instance MonadSpaces m => Action m CancelMultipart where+    type (ConsumedResponse CancelMultipart) = CancelMultipartResponse++    buildRequest CancelMultipart { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = session ^? field @"bucket"+               , object         = session ^? field @"object"+               , method         = Just DELETE+               , body           = Nothing+               , overrideRegion = Nothing+               , headers        = mempty+               , subresources   = Nothing+               , queryString    = Just+                     $ H.toQuery [ ( "uploadId" :: Text+                                   , session ^. field @"uploadID"+                                   )+                                 ]+               , ..+               }++    consumeResponse _ = return ()++-- | List all of the 'Part's of a multipart upload session+newtype ListParts = ListParts { session :: MultipartSession }+    deriving ( Show, Eq, Generic )++data ListPartsResponse = ListPartsResponse+    { bucket         :: Bucket+    , object         :: Object+    , uploadID       :: UploadID+    , parts          :: Seq Part+    , partMarker     :: Int+      -- ^ Part number marking the beginning of the list+    , nextPartMarker :: Int+      -- ^ If truncated, the list location where the next response will begin+    , maxParts       :: Int+    , isTruncated    :: Bool+    }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m ListParts where+    type (ConsumedResponse ListParts) = ListPartsResponse++    buildRequest ListParts { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = session ^? field @"bucket"+               , object         = session ^? field @"object"+               , method         = Nothing+               , body           = Nothing+               , overrideRegion = Nothing+               , subresources   = Nothing+               , headers        = mempty+               , queryString    = Just+                     $ H.toQuery [ ( "uploadId" :: Text+                                   , session ^. field @"uploadID"+                                   )+                                 ]+               , ..+               }++    consumeResponse raw = do+        cursor <- xmlDocCursor raw+        bucket <- bucketP cursor+        object <- objectP cursor+        uploadID <- X.force (xmlElemError "UploadId")+            $ cursor $/ X.laxElement "UploadId" &/ X.content+        isTruncated <- isTruncP cursor+        maxParts <- xmlNum "MaxParts" cursor+        parts <- S.fromList+            <$> sequence (cursor $/ X.laxElement "Part" &| partP)+        partMarker <- xmlNum "PartNumberMarker" cursor+        nextPartMarker <- xmlNum "NextPartNumberMarker" cursor++        return ListPartsResponse { .. }+      where+        partP c = Part <$> xmlNum "PartNumber" c+            <*> lastModifiedP c+            <*> etagP c+            <*> xmlNum "Size" c
+ src/Network/DO/Spaces/Actions/UploadObject.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Actions.UploadObject+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+module Network.DO.Spaces.Actions.UploadObject+    ( UploadObject(..)+    , UploadObjectResponse(..)+    ) where++import           Control.Monad.Catch       ( MonadThrow(throwM) )+import           Control.Monad.Reader      ( MonadReader(ask) )+import           Control.Monad.Trans.Maybe ( MaybeT(runMaybeT) )++import qualified Data.CaseInsensitive      as CI++import           GHC.Generics              ( Generic )++import           Network.DO.Spaces.Types+                 ( Action(..)+                 , Bucket+                 , ClientException(OtherError)+                 , ETag+                 , Method(PUT)+                 , MonadSpaces+                 , Object+                 , SpacesRequestBuilder(..)+                 , UploadHeaders(..)+                 )+import           Network.DO.Spaces.Utils+                 ( lookupHeader+                 , readContentLen+                 , readEtag+                 , renderUploadHeaders+                 )+import           Network.HTTP.Conduit      ( RequestBody )+import           Network.Mime              ( MimeType )++-- | Upload a single object to Spaces. The maximum size for a single PUT request+-- is 5 GB+data UploadObject = UploadObject+    { bucket          :: Bucket+    , object          :: Object+    , body            :: RequestBody+    , optionalHeaders :: UploadHeaders+    , contentType     :: Maybe MimeType+    }+    deriving ( Generic )++data UploadObjectResponse = UploadObjectResponse+    { etag          :: ETag+    , contentLength :: Int -- ^ Length in bytes+    }+    deriving ( Show, Eq, Generic )++instance MonadSpaces m => Action m UploadObject where+    type ConsumedResponse UploadObject = UploadObjectResponse++    buildRequest UploadObject { .. } = do+        spaces <- ask+        return SpacesRequestBuilder+               { bucket         = Just bucket+               , object         = Just object+               , method         = Just PUT+               , body           = Just body+               , queryString    = Nothing+               , subresources   = Nothing+               , overrideRegion = Nothing+               , ..+               }+      where+        headers = maybe id+                        (\ct -> (:) (CI.mk "Content-Type", ct))+                        contentType+                        (renderUploadHeaders optionalHeaders)++    consumeResponse raw = do+        resp <- runMaybeT+            $ UploadObjectResponse <$> (readEtag =<< lookupHeader' "etag")+            <*> (readContentLen =<< lookupHeader' "Content-Length")+        case resp of+            Just r  -> return r+            Nothing -> throwM $ OtherError "Missing/malformed headers"+      where+        lookupHeader' = lookupHeader raw
+ src/Network/DO/Spaces/Request.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Network.DO.Spaces.Request+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+-- Low-level implementations of Spaces REST transactions. You should not import+-- this module directly, but should instead use the higher-level interface exposed+-- by "Network.DO.Spaces.Actions" and its submodules+--+module Network.DO.Spaces.Request+    ( newSpacesRequest+    , mkSignature+    , mkStringToSign+    , mkAuthorization+    , finalize+    ) where++import           Control.Monad.Catch             ( MonadThrow )++import           Crypto.Hash                     ( SHA256, hashlazy )+import           Crypto.MAC.HMAC                 ( hmac )++import           Data.Bifunctor                  ( first )+import           Data.ByteArray                  ( convert )+import           Data.ByteString                 ( ByteString )+import qualified Data.ByteString.Base16          as B16+import qualified Data.ByteString.Char8           as C+import qualified Data.ByteString.Lazy            as LB+import qualified Data.CaseInsensitive            as CI+import           Data.Coerce                     ( coerce )+import           Data.Function                   ( (&) )+import           Data.Generics.Product           ( HasField(field) )+import           Data.Generics.Product.Positions ( HasPosition(position) )+import           Data.List                       ( sort )+import           Data.Maybe                      ( fromMaybe )+import qualified Data.Text                       as T+import           Data.Time+                 ( UTCTime+                 , defaultTimeLocale+                 , formatTime+                 )++import           Lens.Micro                      ( (^.) )++import           Network.DO.Spaces.Types+import           Network.DO.Spaces.Utils+                 ( bodyLBS+                 , regionSlug+                 , toLowerBS+                 )+import           Network.HTTP.Client.Conduit     ( Request+                                                 , RequestBody(RequestBodyLBS)+                                                 )+import qualified Network.HTTP.Client.Conduit     as H+import           Network.HTTP.Types              ( Header, Query, QueryItem )+import qualified Network.HTTP.Types              as H++-- | Extract the 'Request' from a 'SpacesRequest' and set the requisite+-- @Authorization@ header+finalize :: SpacesRequest -> Authorization -> Request+finalize sr auth = req { H.requestHeaders = authHeader : reqHeaders }+  where+    authHeader = (CI.mk "authorization", uncompute auth)++    req        = sr ^. field @"request"++    reqHeaders = req & H.requestHeaders++-- | Create a new 'SpacesRequest' from a 'SpacesRequestBuilder', performing the+-- necessary computations and setting the appropriate default headers+newSpacesRequest+    :: MonadThrow m => SpacesRequestBuilder -> UTCTime -> m SpacesRequest+newSpacesRequest SpacesRequestBuilder { .. } time = do+    req <- H.parseRequest+        $ mconcat [ show reqMethod+                  , " "+                  , "https://"+                  , maybe mempty ((<> ".") . T.unpack . coerce) bucket+                  , regionSlug+                    $ fromMaybe (spaces ^. field @"region") overrideRegion+                  , "."+                  , "digitaloceanspaces.com/"+                  , maybe mempty (T.unpack . coerce) object+                  ]+    payload <- bodyLBS reqBody+    let payloadHash      = hashHex payload+        newHeaders       = overrideReqHeaders req payloadHash time+        request          = req+            { H.requestHeaders = headers <> newHeaders+            , H.queryString    =+                  maybe mempty (H.renderQuery True) subresources+                  <> maybe mempty (H.renderQuery False) queryString+            , H.requestBody    = reqBody+            }+        canonicalRequest = mkCanonicalized (fromMaybe mempty subresources)+                                           (fromMaybe mempty queryString)+                                           request+                                           payloadHash+    return+        $ SpacesRequest+        { method = reqMethod, headers = headers <> newHeaders, .. }+  where+    reqMethod = fromMaybe GET method++    reqBody   = fromMaybe (RequestBodyLBS LB.empty) body++-- | Canonicalize a 'Request'+mkCanonicalized :: Query -- ^ Subresources+                -> Query  -- ^ Query string+                -> Request+                -> Hashed  -- ^ The hashed 'RequestBody'+                -> Canonicalized Request+mkCanonicalized subresources query request payloadHash = Canonicalized+    $ C.intercalate "\n"+                    [ request & H.method+                    , request & H.path+                    , renderSubresources subresources+                      <> H.renderQuery False query+                    , request+                      & H.requestHeaders+                      & canonicalizeHeaders+                      & unCanonicalized+                    , request & H.requestHeaders & joinHeaderNames+                    , uncompute payloadHash+                    ]++-- | This is required to encode the subresources query string correctly in the+-- canonical request. Empty query keys require a trailing @=@, which are not+-- included with 'H.renderQuery'+renderSubresources :: Query -> ByteString+renderSubresources = C.intercalate "&" . fmap renderQueryItem . sort+  where+    renderQueryItem :: QueryItem -> ByteString+    renderQueryItem (k, Nothing) = k <> "="+    renderQueryItem (k, Just v)  = k <> "=" <> v++-- | Generate a t'StringToSign'+mkStringToSign :: SpacesRequest -> StringToSign+mkStringToSign req@SpacesRequest { .. } = StringToSign+    $ C.intercalate "\n"+                    [ "AWS4-HMAC-SHA256"+                    , fmtAmzTime time+                    , mkCredentials req & uncompute+                    , canonicalRequest+                      & coerce+                      & LB.fromStrict+                      & hashHex+                      & uncompute+                    ]++-- | Generate a t'Signature'+mkSignature :: SpacesRequest -> StringToSign -> Signature+mkSignature SpacesRequest { .. } str = Signature+    . B16.encode+    . keyedHash (uncompute str)+    . keyedHash "aws4_request"+    . keyedHash "s3"+    . keyedHash (spaces ^. field @"region" & regionSlug)+    . keyedHash (fmtAmzDate time)+    $ "AWS4" <> (spaces ^. field @"secretKey" & coerce)++-- | Create an t'Authorization' corresponding to the required AWS v4+-- @Authorization@ header+mkAuthorization :: SpacesRequest -> StringToSign -> Authorization+mkAuthorization req@SpacesRequest { .. } str = Authorization+    $ C.concat [ "AWS4-HMAC-SHA256 Credential="+                 <> spaces ^. field @"accessKey" . position @1+                 <> "/"+                 <> uncompute cred+               , ", SignedHeaders=" <> joinHeaderNames headers+               , ", Signature=" <> uncompute sig+               ]+  where+    cred = mkCredentials req++    sig  = mkSignature req str++-- | Create t'Credentials' containing your 'AccessKey' and the request 'Region'+mkCredentials :: SpacesRequest -> Credentials+mkCredentials SpacesRequest { .. } = Credentials+    $ C.intercalate "/"+                    [ fmtAmzDate time+                    , spaces ^. field @"region" & regionSlug+                    , "s3"+                    , "aws4_request"+                    ]++-- | Required to override @http-client@ automatically setting the Content-Length header and+-- setting obligatory headers for AWS v4 API requests+overrideReqHeaders+    :: Request+    -> Hashed   -- ^ The SHA256 hash of the request body; required in AWS v4+    -> UTCTime+    -> [Header]+overrideReqHeaders req hb time = (req & H.requestHeaders) <> newHeaders+  where+    newHeaders = [ (CI.mk "host", req & H.host)+                 , (CI.mk "x-amz-content-sha256", uncompute hb)+                 , (CI.mk "x-amz-date", fmtAmzTime time)+                 ]++-- | Canonicalize @['Header']@s+canonicalizeHeaders :: [Header] -> Canonicalized [Header]+canonicalizeHeaders = Canonicalized+    . C.unlines+    . fmap (\(n, v) -> n <> ":" <> v)+    . sort+    . fmap (first (toLowerBS . CI.original))++joinHeaderNames :: [Header] -> ByteString+joinHeaderNames =+    C.intercalate ";" . sort . fmap (toLowerBS . CI.original . fst)++fmtAmzDate :: UTCTime -> ByteString+fmtAmzDate = C.pack . formatTime defaultTimeLocale "%Y%m%d"++fmtAmzTime :: UTCTime -> ByteString+fmtAmzTime = C.pack . formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ"++keyedHash :: ByteString -> ByteString -> ByteString+keyedHash bs k = convert $ hmac @_ @_ @SHA256 k bs++hashHex :: LB.ByteString -> Hashed+hashHex = Hashed . B16.encode . convert . hashlazy @SHA256
+ src/Network/DO/Spaces/Types.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Network.DO.Spaces.Types+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Network.DO.Spaces.Types+    ( -- * Spaces+      SpacesT(..)+    , runSpacesT+    , Spaces(..)+    , MonadSpaces+    , Action(..)+    , CredentialSource(..)+    , Profile+    , AccessKey(..)+    , SecretKey(..)+      -- * Buckets and Objects+    , Object(..)+    , mkObject+    , Bucket(..)+    , mkBucket+    , BucketInfo(..)+    , OwnerID(..)+    , DisplayName+    , Owner(..)+    , ObjectInfo(..)+    , ObjectMetadata(..)+    , ETag+      -- * Requests and responses+    , SpacesRequest(..)+    , SpacesResponse(..)+    , SpacesRequestBuilder(..)+    , SpacesMetadata(..)+    , WithMetadata(..)+    , RawResponse(..)+    , BodyBS+    , Method(..)+    , Region(..)+    , CacheControl+    , ContentDisposition+    , ContentEncoding+    , UserMetadata+    , UploadHeaders(..)+    , CannedACL(..)+    , CORSRule(..)+    , mkCORSRule+    , Grant(..)+    , Permission(..)+    , Grantee(..)+    , ACLResponse(..)+    , LifecycleRule(..)+    , LifecycleExpiration(..)+    , LifecycleID(..)+    , mkLifecycleID+      -- ** Signature calculation+    , Canonicalized(..)+    , Computed(..)+    , StringToSign+    , Hashed+    , Signature+    , Credentials+    , Authorization+    , uncompute+      -- * Exceptions+    , SpacesException+    , ClientException(..)+    , APIException(..)+    , Days+    ) where++import           Conduit                      ( ConduitT, MonadUnliftIO )++import           Control.Exception+                 ( Exception(toException, fromException)+                 , SomeException+                 )+import           Control.Monad.Catch          ( MonadCatch+                                              , MonadThrow(throwM)+                                              )+import           Control.Monad.IO.Class       ( MonadIO )+import           Control.Monad.Reader         ( MonadReader+                                              , ReaderT(ReaderT, runReaderT)+                                              )++import           Data.ByteString              ( ByteString )+import qualified Data.ByteString.Char8        as C+import qualified Data.ByteString.Lazy         as LB+import qualified Data.CaseInsensitive         as CI+import           Data.Char                    ( isAlpha, isDigit, toLower )+import           Data.Containers.ListUtils    ( nubOrd )+import           Data.Data                    ( Typeable )+import qualified Data.Generics.Product.Fields as GL+import           Data.Ix                      ( inRange )+import           Data.Kind                    ( Type )+import           Data.Text                    ( Text )+import qualified Data.Text                    as T+import           Data.Time                    ( UTCTime )+import           Data.Typeable                ( cast )+import           Data.Word                    ( Word16 )++import           GHC.Generics                 ( Generic )++import           Network.HTTP.Client.Conduit+                 ( HasHttpManager(..)+                 , Manager+                 , Request+                 , RequestBody+                 )+import           Network.HTTP.Types           ( Header, HeaderName, Query )+import           Network.HTTP.Types.Status    ( Status )+import           Network.Mime                 ( MimeType )++newtype SpacesT m a = SpacesT (ReaderT Spaces m a)+    deriving ( Generic, Functor, Applicative, Monad, MonadIO, MonadThrow+             , MonadCatch, MonadReader Spaces, MonadUnliftIO )++runSpacesT :: SpacesT m a -> Spaces -> m a+runSpacesT (SpacesT x) = runReaderT x++type MonadSpaces m =+    (MonadReader Spaces m, MonadIO m, MonadUnliftIO m, MonadCatch m)++-- | A client for interacting with the DO Spaces API+data Spaces = Spaces+    { accessKey :: AccessKey -- ^ Your DO Spaces access key+    , secretKey :: SecretKey -- ^ Your DO Spaces secret key+    , region    :: Region -- ^ The DO region+    , manager   :: Manager -- ^ HTTP 'Manager'+    }+    deriving ( Generic )++instance HasHttpManager Spaces where+    getHttpManager = manager++data SpacesRequest = SpacesRequest+    { request          :: Request -- ^ The actual HTTP 'Request'+    , spaces           :: Spaces -- ^ Your 'Spaces' configuration+    , headers          :: [Header]+      -- ^ Obligatory 'Header's that will be added to the request+    , method           :: Method -- ^ The HTTP 'Method'+    , payloadHash      :: Hashed+      -- ^ The SHA256 hash of the 'RequestBody' contents+    , canonicalRequest :: Canonicalized Request+      -- ^ The canonicalized HTTP 'Request'+    , time             :: UTCTime+    }+    deriving ( Generic )++data SpacesRequestBuilder = SpacesRequestBuilder+    { spaces         :: Spaces+    , body           :: Maybe RequestBody+    , method         :: Maybe Method+    , headers        :: [Header]+    , bucket         :: Maybe Bucket+    , object         :: Maybe Object+    , queryString    :: Maybe Query+    , subresources   :: Maybe Query+    , overrideRegion :: Maybe Region+      -- ^ Certain operations, currently only 'Network.DO.Spaces.CreateBucket',+      -- should be able to override the region configured in the 'Spaces'+      -- client+    }+    deriving ( Generic )++-- | DO regions where Spaces is available (only a subset of all regions)+data Region+    = NewYork -- ^ NYC3+    | Amsterdam -- ^ AMS3+    | SanFrancisco  -- ^ SFO3+    | Singapore -- ^ SGP1+    | Frankfurt -- ^ FRA1+    deriving ( Show, Eq, Generic )++-- | HTTP request methods, to avoid using @http-client@'s stringly-typed @Method@+-- synonym+data Method = GET | POST | PUT | DELETE | HEAD+    deriving ( Show, Eq, Generic, Ord, Read )++-- | The name of a single storage bucket+newtype Bucket = Bucket { unBucket :: Text }+    deriving ( Show, Eq, Generic )++-- | Smart constructor for 'Bucket's; names must conform to the following rules:+--+--      * They must be between 3 and 63 characters in length+--      * They may only contain lowercase letters, digits, dots, and hyphens+--      * They must begin and end in a number or letter+-- See more at:+-- <https://docs.aws.amazon.com/AmazonS3/latest/userguide/bucketnamingrules.html>.+--+-- This function ensures that names are valid and will also convert the 'Text'+-- to lowercase+mkBucket :: MonadThrow m => Text -> m Bucket+mkBucket t+    | not $ inRange (3, 63) len =+        bucketErr "Name must be between 3-63 characters"+    | not $ T.all (or . okChars) t = bucketErr+        $ mconcat [ "Names may only consist of "+                  , "lowercase letters, digits, dots, and hyphens"+                  ]+    -- Yes, partial. But the length of the Text has already been+    -- established and using uncons/unsnoc would be redundant+    | T.head t `elem` [ '.', '-' ] =+        bucketErr "Name must begin with a letter or digit"+    | T.last t+        `elem` [ '.', '-' ] = bucketErr "Name must end with a letter or digit"+    | otherwise = return . Bucket $ T.map toLower t+  where+    len         = T.length t++    -- isAlphaNum may select non-ASCII digits, but isDigit doesn't.+    -- It's better to check isDigit and isAlpha separately+    okChars c = [ ('.' ==), ('-' ==), isDigit, isAlpha ] <*> [ c ]++    bucketErr e = throwM . OtherError $ "Bucket: " <> e++-- | Information about a single 'Bucket'+data BucketInfo = BucketInfo { name :: Bucket, creationDate :: UTCTime }+    deriving ( Show, Eq, Generic )++-- | The name of a \"key\", in AWS parlance+newtype Object = Object { unObject :: Text }+    deriving ( Show, Eq, Generic )++-- | Smart constructor for 'Object's; names must not be empty+mkObject :: MonadThrow m => Text -> m Object+mkObject "" = throwM . OtherError $ "Object: Name must not be empty"+mkObject x  = return $ Object x++-- | Information about a single 'Object', returned when listing a 'Bucket'\'s+-- contents+data ObjectInfo = ObjectInfo+    { object       :: Object+    , lastModified :: UTCTime+    , etag         :: ETag+    , size         :: Int -- ^ Size in bytes+    , owner        :: Owner+    }+    deriving ( Show, Eq, Generic )++-- | Metadata returned when querying information about an 'Object'+data ObjectMetadata = ObjectMetadata+    { contentLength :: Int -- ^ length in bytes+    , contentType   :: MimeType+    , etag          :: ETag+    , lastModified  :: UTCTime+    }+    deriving ( Show, Eq, Generic )++-- | The resource owner+data Owner = Owner { id' :: OwnerID, displayName :: DisplayName }+    deriving ( Show, Eq, Generic )++-- | The ID of an 'Owner'; also serves as a display name in Spaces+newtype OwnerID = OwnerID { unOwnerID :: Int }+    deriving ( Show, Eq, Generic, Num )++-- | The display name is always equivalent to the owner's ID; Spaces includes+-- it for AWS compatibility+type DisplayName = OwnerID++-- | MD5 hash of an 'Object'+type ETag = Text++-- | Optional headers when uploading objects+data UploadHeaders = UploadHeaders+    { acl                :: Maybe CannedACL+    , cacheControl       :: Maybe CacheControl+    , contentDisposition :: Maybe ContentDisposition+    , contentEncoding    :: Maybe ContentEncoding+    , metadata           :: UserMetadata+    }+    deriving ( Show, Eq, Generic )++-- | @Cache-Control@ request header value+type CacheControl = Text++-- | @Content-Disposition@ request header value+type ContentDisposition = Text++-- | @Content-Encoding@ request header value+type ContentEncoding = Text++-- | Arbitrary key-value pairs supplied by the user, for use in @PUT@ or @POST@+-- requests. Each pair expands into @x-amz-meta-*@, e.g.+-- @x-amz-meta-s3cmd-attrs: uid:1000/gname:asb...@+type UserMetadata = [(Text, Text)]++-- | Cross-origin resource sharing rules+data CORSRule = CORSRule+    { allowedOrigin  :: Text+    , allowedMethods :: [Method]+    , allowedHeaders :: [HeaderName]+    }+    deriving ( Show, Eq, Generic )++-- | An individual access grant+data Grant = Grant { permission :: Permission, grantee :: Grantee }+    deriving ( Show, Eq, Generic )++-- | Access grant level; Spaces currently only supports these two levels+data Permission = ReadOnly | FullControl+    deriving ( Show, Eq, Generic, Ord )++-- | Information about who an access grant applies to+data Grantee+    = Group -- ^ Nominally contains a URI value, but Spaces only supports a+      -- single value for group access grants+    | CanonicalUser Owner+    deriving ( Show, Eq, Generic )++-- | A generic type for describing ACL configuration, can be applied to+-- both 'Bucket' and 'Object' ACLs+data ACLResponse =+    ACLResponse { owner :: Owner, accessControlList :: [Grant] }+    deriving ( Show, Eq, Generic )++type Days = Word16++-- | Lifecycle configuration for a 'Bucket'+data LifecycleRule = LifecycleRule+    { id'             :: LifecycleID+    , enabled         :: Bool -- ^ The status of the @LifecycleRule@+    , prefix          :: Maybe Text+      -- ^ When specified, only 'Object's which share the prefix will be affected+      -- by the lifecycle rules+    , expiration      :: Maybe LifecycleExpiration+    , abortIncomplete :: Maybe Days+      -- ^ When specified, configures the deletion of incomplete multipart uploads+    }+    deriving ( Show, Eq, Generic )++-- | Configuration for automatically deleting expire 'Object's+data LifecycleExpiration = AfterDays Days | OnDate UTCTime+    deriving ( Show, Eq, Generic )++-- | A unique ID for a 'LifecycleRule'+newtype LifecycleID = LifecycleID Text+    deriving ( Show, Eq, Generic )++-- | Smart constructor for 'LifecycleID', which may contain a maximum of 255+-- characters, including spaces+mkLifecycleID :: MonadThrow m => Text -> m LifecycleID+mkLifecycleID t+    | T.length t > 255 = throwM+        $ OtherError "LifecycleID: ID exceeds maximum length (255 chars)"+    | otherwise = return $ LifecycleID t++-- | Smart constructor for 'CORSRule'. Ensures that both origins and header names+-- contain a maximum of one wildcard and removes duplicates from both headers and+-- methods+mkCORSRule :: MonadThrow m => Text -> [Method] -> [HeaderName] -> m CORSRule+mkCORSRule origin ms hs+    | T.count "*" origin > 1 = throwM+        $ OtherError "CORSRule: maximum of one wildcard permitted in origins"+    | or ((> 1) . C.count '*' . CI.original <$> hs) = throwM+        $ OtherError "CORSRule: maximum of one wildcard permitted in headers"+    | otherwise = return CORSRule+                         { allowedOrigin  = origin+                         , allowedMethods = nubOrd ms+                         , allowedHeaders = nubOrd hs+                         }++-- | Represents some resource that has been canonicalized according to the+-- Spaces/AWS v4 spec+newtype Canonicalized a = Canonicalized { unCanonicalized :: ByteString }+    deriving ( Show, Eq, Generic )++-- | Different types of computed 'ByteString's+data ComputedTag = Hash | StrToSign | Sig | Cred | Auth+    deriving ( Show, Eq )++-- | A strict 'ByteString' that has been computed according to some part of+-- the AWS v4 spec. The AWS v4 signature is calculated from a series of+-- interdependent computations. It would be possible to represent these all as+-- 'ByteString's; this approach, however, would make it easy to confuse two+-- sequences that are not semantically equivalent, leading to the generation of+-- malformed singatures. The promiscuous use of 'ByteString's also makes for+-- unclear type signatures. Using a GADT with type synonyms is simpler than+-- creating a @newtype@ for each type of computation+data Computed (a :: ComputedTag) where+    Hashed :: ByteString -> Computed 'Hash+    -- | Represents a \"string to sign\" that has been computed according to the+    -- Spaces/AWS v4 spec+    StringToSign :: ByteString -> Computed 'StrToSign+    -- | Signed hash of a 'Request' body, a 'SecretKey', and request information+    Signature :: ByteString -> Computed 'Sig+    Credentials :: ByteString -> Computed 'Cred+    -- | Authorization string containing information about your 'AccessKey' and+    -- your request+    Authorization :: ByteString -> Computed 'Auth++deriving instance Show (Computed a)++deriving instance Eq (Computed a)++type StringToSign = Computed 'StrToSign++type Hashed = Computed 'Hash++type Signature = Computed 'Sig++type Credentials = Computed 'Cred++type Authorization = Computed 'Auth++-- | Extract the 'ByteString' from something 'Computed'+uncompute :: Computed a -> ByteString+uncompute = \case+    Hashed b        -> b+    StringToSign b  -> b+    Signature b     -> b+    Credentials b   -> b+    Authorization b -> b++-- | Spaces access key+newtype AccessKey = AccessKey { unAccessKey :: ByteString }+    deriving ( Show, Eq, Generic )++-- | Spaces secret key+newtype SecretKey = SecretKey { unSecretKey :: ByteString }+    deriving ( Show, Eq, Generic )++-- | The name of a per-project configuration profile to select when loading+-- credentials from a file+type Profile = Text++-- Generate a 'SpacesRequestBuilder' for a given type, settings the appropriate+-- specific 'Header's, etc..., for that type+class Monad m => Action m a where+    type ConsumedResponse a :: Type++    buildRequest :: a -> m SpacesRequestBuilder+    consumeResponse :: RawResponse m -> m (ConsumedResponse a)++-- A response, before being transformed into a 'ConsumedResponse'+data RawResponse m = RawResponse { headers :: [Header], body :: BodyBS m }+    deriving ( Generic )++-- | A request or response body+type BodyBS m = ConduitT () ByteString m ()++-- | Metadata and other response information returned from each Spaces API+-- transaction; it can be helpful to retain this at times+data SpacesMetadata = SpacesMetadata+    { requestID :: Maybe RequestID+      -- ^ Unique ID assigned to your request. This is not included in all+      -- responses+    , date      :: Maybe UTCTime+    , status    :: Status -- ^ HTTP status+    }+    deriving ( Show, Eq, Generic )++-- | Whether or not to retain 'SpacesMetadata' when consuming responses+data WithMetadata = KeepMetadata | NoMetadata+    deriving ( Show, Eq, Generic )++-- | A 'ConsumedResponse' with optional 'SpacesMetadata'+data SpacesResponse a = SpacesResponse+    { result   :: ConsumedResponse a+      -- ^ A 'Network.HTTP.Conduit.Response' consumed by an 'Action' instance+    , metadata :: Maybe SpacesMetadata+      -- ^ 'SpacesMetadata', the retention of which can be controlled using+      -- 'WithMetadata'+    }+    deriving ( Generic )++deriving instance (Show (ConsumedResponse a)) => Show (SpacesResponse a)++-- This instance is necessary to make the polymorphic @result@ field work with+-- HasField+instance {-# OVERLAPPING #-}( GL.HasField' name (SpacesResponse a) s+                            , s ~ t+                            , a ~ b+                            )+    => GL.HasField name (SpacesResponse a) (SpacesResponse b) s t where+    field = GL.field' @name++-- | A unique ID that is assigned to each request+type RequestID = Text++-- | How to discover 'AccessKey's and 'SecretKey's when creating a new 'Spaces'+-- client.+data CredentialSource+    = FromEnv (Maybe (Text, Text)) -- ^ 'AccessKey' and 'SecretKey' env vars+    | FromFile FilePath (Maybe Profile)+      -- ^ Load your credentials from a file, optionally providing the profile+      -- to use (or @default@ as the... default).+    | Explicit AccessKey SecretKey -- ^ Provide both keys explicitly++-- | \"Canned\" access controls; Spaces doesn't support the full range offered+-- by s3+data CannedACL+    = Private -- ^ No unauthenticated public access+    | PublicRead -- ^ Unauthenticated public read access permitted+    deriving ( Eq, Show )++-- | The base 'Exception' type for both 'ClientException's and 'APIException's+data SpacesException = forall e. Exception e => SpacesException e++instance Show SpacesException where+    show (SpacesException e) = show e++instance Exception SpacesException++spsExToException :: Exception e => e -> SomeException+spsExToException = toException . SpacesException++spsExFromException :: Exception e => SomeException -> Maybe e+spsExFromException e = do+    SpacesException x <- fromException e+    cast x++-- | An exception generated within the 'Spaces' client+data ClientException+    = InvalidRequest Text+    | InvalidXML Text+    | ConfigurationError Text+      -- | This includes the raw 'Network.HTTP.Types.Response' body, read into a+      -- lazy 'LB.ByteString'+    | HTTPStatus Status LB.ByteString+    | OtherError Text+    deriving ( Show, Eq, Generic, Typeable )++instance Exception ClientException where+    toException = spsExToException++    fromException = spsExFromException++-- | An s3-compatible API error response, sent as XML+data APIException = APIException+    { status    :: Status -- ^ HTTP 'Status'+    , code      :: Text -- ^ The s3 error code type+    , requestID :: RequestID -- ^ The unique ID of the request+    , hostID    :: Text+    }+    deriving ( Show, Eq, Generic, Typeable )++instance Exception APIException where+    toException = spsExToException++    fromException = spsExFromException
+ src/Network/DO/Spaces/Utils.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Network.DO.Spaces.Utils+-- Copyright   : (c) 2021 Rory Tyler Hayford+-- License     : BSD-3-Clause+-- Maintainer  : rory.hayford@protonmail.com+-- Stability   : experimental+-- Portability : GHC+--+-- Small utilities+module Network.DO.Spaces.Utils+    ( -- * General utilities+      tshow+    , bshow+    , unquote+    , quote+    , bodyLBS+    , toLowerBS+    , handleMaybe+    , regionSlug+    , showCannedACL+    , renderUploadHeaders+    , defaultUploadHeaders+    , slugToRegion+    , getResponseMetadata+    , mkNode+    , showPermission+      -- * Parsing/reading+      -- ** XML+    , xmlDocCursor+    , xmlInt+    , xmlElemError+    , xmlUTCTime+    , xmlNum+    , xmlMaybeElem+    , isTruncP+    , bucketP+    , objectP+    , etagP+    , ownerP+    , lastModifiedP+    , aclP+    , writeACLSetter+      -- ** Response headers+    , lookupObjectMetadata+    , lookupHeader+    , readEtag+    , readContentLen+    ) where++import           Conduit                   ( (.|), runConduit )++import           Control.Monad.Catch+                 ( MonadCatch+                 , MonadThrow(throwM)+                 , handleAll+                 )+import           Control.Monad.IO.Class    ( MonadIO )+import           Control.Monad.Trans.Maybe ( MaybeT(MaybeT, runMaybeT) )++import           Data.Bifunctor            ( Bifunctor(first, second) )+import           Data.Bool                 ( bool )+import           Data.ByteString           ( ByteString )+import qualified Data.ByteString.Char8     as C+import qualified Data.ByteString.Lazy      as LB+import qualified Data.CaseInsensitive      as CI+import           Data.Char                 ( toLower )+import           Data.Coerce               ( coerce )+import           Data.Either.Extra         ( eitherToMaybe )+import           Data.Generics.Product     ( HasField'(field')+                                           , HasField(field)+                                           )+import qualified Data.Map                  as M+import           Data.Maybe                ( catMaybes, listToMaybe )+import           Data.String               ( IsString )+import           Data.Text                 ( Text )+import qualified Data.Text                 as T+import qualified Data.Text.Encoding        as T+import           Data.Time+                 ( UTCTime+                 , defaultTimeLocale+                 , parseTimeM+                 )+import           Data.Time.Format.ISO8601  ( iso8601ParseM )++import           Lens.Micro                ( (&), (^.) )++import           Network.DO.Spaces.Types+import           Network.HTTP.Conduit+                 ( RequestBody(RequestBodyBS, RequestBodyLBS)+                 )+import           Network.HTTP.Types        ( Header, HeaderName, Status )++import           Text.Read                 ( readMaybe )+import           Text.XML                  ( Node )+import qualified Text.XML                  as X+import qualified Text.XML.Cursor           as X+import           Text.XML.Cursor           ( ($/), (&/), (&|) )+import           Text.XML.Cursor.Generic   ( Cursor )++-- | Convert a 'Region' to its equivalent slug+regionSlug :: IsString a => Region -> a+regionSlug = \case+    NewYork      -> "nyc3"+    Amsterdam    -> "ams3"+    SanFrancisco -> "sfo3"+    Singapore    -> "sgp1"+    Frankfurt    -> "fra1"++slugToRegion :: MonadThrow m => Text -> m Region+slugToRegion = \case+    "nyc3" -> return NewYork+    "ams3" -> return Amsterdam+    "sfo3" -> return SanFrancisco+    "sgp1" -> return Singapore+    "fra1" -> return Frankfurt+    reg    -> throwM . OtherError $ "Unrecognized region " <> quote reg++-- | Map 'ByteString' chars to lower-case+toLowerBS :: ByteString -> ByteString+toLowerBS = C.pack . fmap toLower . C.unpack++-- | Show a 'ByteString'+bshow :: Show a => a -> ByteString+bshow = C.pack . show++-- | Show some 'Text'+tshow :: Show a => a -> Text+tshow = T.pack . show++-- | Strip leading and trailing double quotes from a 'Text'+unquote :: Text -> Text+unquote = T.dropAround ('"' ==)++quote :: (IsString a, Monoid a) => a -> a+quote x = "\"" <> x <> "\""++showCannedACL :: IsString a => CannedACL -> a+showCannedACL = \case+    Private    -> "private"+    PublicRead -> "public-read"++showPermission :: IsString a => Permission -> a+showPermission = \case+    ReadOnly    -> "READ"+    FullControl -> "FULL_CONTROL"++handleMaybe :: MonadCatch m => (a -> m b) -> a -> m (Maybe b)+handleMaybe g x = handleAll (\_ -> return Nothing) (Just <$> g x)++-- | Convert a 'RequestBody' to a 'Data.ByteString.Lazy.ByteString'+bodyLBS :: MonadThrow m => RequestBody -> m LB.ByteString+bodyLBS (RequestBodyBS b)   = return $ LB.fromStrict b+bodyLBS (RequestBodyLBS lb) = return lb+bodyLBS _                   =+    throwM $ InvalidRequest "Unsupported request body type"++-- | Convert 'UploadHeaders' to a list of request 'Header's+renderUploadHeaders :: UploadHeaders -> [Header]+renderUploadHeaders UploadHeaders { .. } = second T.encodeUtf8+    <$> catMaybes [ ("x-amz-acl", ) . showCannedACL <$> acl+                  , ("Cache-Control", ) <$> cacheControl+                  , ("Content-Disposition", ) <$> contentDisposition+                  , ("Content-Encoding", ) <$> contentEncoding+                  ]+    <> (first (CI.mk . T.encodeUtf8 . ("x-amz-meta-" <>)) <$> metadata)++-- | Create an XML 'Node'+mkNode :: X.Name -> Text -> Node+mkNode name nc = X.NodeElement $ X.Element name mempty [ X.NodeContent nc ]++xmlDocCursor :: (MonadIO m, MonadThrow m) => RawResponse m -> m X.Cursor+xmlDocCursor RawResponse { .. } = X.fromDocument+    <$> runConduit (body .| X.sinkDoc X.def)++-- | XML parser for 'Owner' attribute+ownerP :: MonadThrow m => Cursor Node -> m Owner+ownerP c = do+    id' <- X.forceM (xmlElemError "ID")+        $ c $/ X.laxElement "ID" &/ X.content &| xmlInt @_ @OwnerID+    return Owner { displayName = id', id' }++-- | XML parser for 'ETag' attribute+etagP :: MonadThrow m => Cursor Node -> m ETag+etagP c = X.force (xmlElemError "ETag")+    $ c $/ X.laxElement "ETag" &/ X.content &| unquote++-- | XML parser for @LastModified@ attribute+lastModifiedP :: MonadThrow m => Cursor Node -> m UTCTime+lastModifiedP c = X.forceM (xmlElemError "LastModified")+    $ c $/ X.laxElement "LastModified" &/ X.content &| xmlUTCTime++-- | Read a 'Num' type from 'Text'+xmlInt :: (MonadThrow m, Num a) => Text -> m a+xmlInt txt = case readMaybe $ T.unpack txt of+    Just n  -> return $ fromInteger n+    Nothing -> throwM $ InvalidXML "Failed to read integer value"++-- | Read a 'Num' type, encoded as an integer, from XML+xmlNum :: Num a => MonadThrow m => Text -> Cursor Node -> m a+xmlNum name c = X.forceM (xmlElemError name)+    $ c $/ X.laxElement name &/ X.content &| xmlInt++-- | Read a 'UTCTime' from an ISO-O8601-formatted 'Text'+xmlUTCTime :: MonadThrow m => Text -> m UTCTime+xmlUTCTime txt = case iso8601ParseM $ T.unpack txt of+    Just t  -> return t+    Nothing -> throwM $ InvalidXML "Failed to read ISO-8601 value"++isTruncP :: MonadThrow m => Cursor Node -> m Bool+isTruncP c = X.force (xmlElemError "IsTruncated")+    $ c $/ X.laxElement "IsTruncated" &/ X.content &| truncP+  where+    truncP t = bool False True (t == "true")++-- | Helper to build exceptions during XML parsing+xmlElemError :: Text -> ClientException+xmlElemError txt = InvalidXML $ "Missing " <> txt++-- | Parse the name of a 'Bucket' from XML+bucketP :: MonadThrow m => Cursor Node -> m Bucket+bucketP c = X.force (xmlElemError "Bucket")+    $ c $/ X.laxElement "Bucket" &/ X.content &| coerce++-- | Parse the name of an 'Object' from XML+objectP :: MonadThrow m => Cursor Node -> m Object+objectP c = X.force (xmlElemError "Key")+    $ c $/ X.laxElement "Key" &/ X.content &| coerce++xmlMaybeElem :: Cursor Node -> Text -> Maybe Text+xmlMaybeElem cursor name =+    listToMaybe $ cursor $/ X.laxElement name &/ X.content++lookupObjectMetadata :: MonadThrow m => RawResponse m -> m ObjectMetadata+lookupObjectMetadata raw = do+    metadata <- runMaybeT+        $ ObjectMetadata+        <$> (readContentLen =<< lookupHeader' "Content-Length")+        <*> lookupHeader' "Content-Type"+        <*> (readEtag =<< lookupHeader' "Etag")+        <*> (readDate =<< lookupHeader' "Last-Modified")+    case metadata of+        Just md -> return md+        Nothing -> throwM $ OtherError "Missing/malformed headers"+  where+    lookupHeader' = lookupHeader raw++    readDate      = MaybeT . return . parseAmzTime . C.unpack++parseAmzTime :: [Char] -> Maybe UTCTime+parseAmzTime = parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S %EZ"++-- | Lookup the value of a 'HeaderName' from a 'RawResponse' in a monadic context+lookupHeader :: Monad m => RawResponse m -> HeaderName -> MaybeT m ByteString+lookupHeader raw = MaybeT . return . flip lookup (raw ^. field @"headers")++-- | Transform a 'Header' value into an 'ETag'+readEtag :: Monad m => ByteString -> MaybeT m ETag+readEtag = MaybeT . return . fmap unquote . eitherToMaybe . T.decodeUtf8'++-- | Transform a 'Header' value into an 'Int' (for @Content-Length@)+readContentLen :: Monad m => ByteString -> MaybeT m Int+readContentLen = MaybeT . return . readMaybe @Int . C.unpack++aclP :: MonadThrow m => Cursor Node -> m ACLResponse+aclP cursor = ACLResponse+    <$> (X.forceM (xmlElemError "Owner")+         $ cursor $/ X.laxElement "Owner" &| ownerP)+    <*> (X.force (xmlElemError "AccessControlList")+         $ cursor $/ X.laxElement "AccessControlList" &| grantsP)+  where+    grantsP c = X.forceM (xmlElemError "Grant") . sequence+        $ c $/ X.laxElement "Grant" &| grantP++    grantP c = Grant+        <$> (X.forceM (xmlElemError "Permission")+             $ c $/ X.laxElement "Permission" &/ X.content &| readPerm)+        <*> (X.forceM (xmlElemError "Grantee")+             $ c $/ X.laxElement "Grantee" &| granteeP)+      where+        readPerm = \case+            "FULL_CONTROL" -> return FullControl+            "READ"         -> return ReadOnly+            _              ->+                throwM $ InvalidXML "Unrecognized ACL Permission"++    granteeP c = case X.node c of+        X.NodeElement (X.Element _ as _) -> case M.lookup typeName as of+            Just "Group" -> return Group+            Just "CanonicalUser" -> CanonicalUser <$> ownerP c+            _ -> throwM $ InvalidXML "Invalid ACL Grantee type"+        _ -> throwM $ InvalidXML "Invalid ACL Grantee"+      where+        typeName = X.Name "type"+                          (Just "http://www.w3.org/2001/XMLSchema-instance")+                          (Just "xsi")++writeACLSetter :: (HasField' "owner" r Owner, HasField' "acls" r [Grant])+               => r+               -> LB.ByteString+writeACLSetter r = X.renderLBS X.def $ X.Document prologue root mempty+  where+    prologue = X.Prologue mempty Nothing mempty++    root = X.Element name mempty nodes+      where+        name = X.Name "AccessControlPolicy"+                      (Just "http://s3.amazonaws.com/doc/2006-03-01/")+                      Nothing++    nodes = [ X.NodeElement+              $ X.Element "Owner"+                          mempty+                          [ mkNode "ID"+                                   (r ^. field' @"owner" . field @"id'"+                                    & coerce @_ @Int+                                    & tshow)+                          ]+            , X.NodeElement+              $ X.Element "AccessControlList"+                          mempty+                          (aclNode <$> r ^. field' @"acls")+            ]++    aclNode Grant { .. } = X.NodeElement+        $ X.Element "Grant"+                    mempty+                    [ granteeNode grantee+                    , mkNode "Permission" (showPermission permission)+                    ]++    granteeNode = \case+        CanonicalUser owner -> X.NodeElement+            $ X.Element "Grantee"+                        (granteeAttrs "CanonicalUser")+                        [ mkNode "ID"+                                 (owner ^. field @"id'"+                                  & coerce @_ @Int+                                  & tshow)+                        ]+        Group               -> X.NodeElement+            $ X.Element "Grantee"+                        (granteeAttrs "Group")+                        [ mkNode "URI"+                                 "http://acs.amazonaws.com/groups/global/AllUsers"+                        ]+      where+        granteeAttrs ty =+            M.fromList [ ( X.Name "type"+                                  (Just "http://www.w3.org/2001/XMLSchema-instance")+                                  (Just "xsi")+                         , ty+                         )+                       ]++defaultUploadHeaders :: UploadHeaders+defaultUploadHeaders = UploadHeaders+    { acl                = Nothing+    , cacheControl       = Nothing+    , contentDisposition = Nothing+    , contentEncoding    = Nothing+    , metadata           = mempty+    }++-- | Create a 'SpacesMetadata' by reading response 'Header's, after passing the+-- 'Status'+getResponseMetadata :: Status -> RawResponse m -> SpacesMetadata+getResponseMetadata status RawResponse { .. } = SpacesMetadata { .. }+  where+    requestID =+        eitherToMaybe . T.decodeUtf8' =<< lookup "x-amz-request-id" headers++    date      = parseAmzTime . C.unpack =<< lookup "Date" headers
+ tests/Main.hs view
@@ -0,0 +1,457 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++-- |+module Main where++import           Conduit                   ( sourceLazy, withSourceFile )++import qualified Data.ByteString.Char8     as C+import qualified Data.CaseInsensitive      as CI+import           Data.Foldable             ( Foldable(toList), for_ )+import           Data.Generics.Labels      ()+import           Data.Maybe                ( isJust )+import qualified Data.Sequence             as S+import qualified Data.Text                 as T+import           Data.Time                 ( UTCTime )+import           Data.Time.Format.ISO8601  ( iso8601ParseM )++import           Lens.Micro++import           Network.DO.Spaces         ( newSpaces )+import           Network.DO.Spaces.Actions+import           Network.DO.Spaces.Request+import           Network.DO.Spaces.Types+import           Network.HTTP.Types        ( mkStatus )++import           Test.Hspec++main :: IO ()+main = sequence_ [ requests+                 , errorResponse+                 , listAllBucketsResponse+                 , listBucket+                 , bucketLocationResponse+                 , objectInfoResponse+                 , copyObject+                 , beginMultipartResponse+                 , listPartsResponse+                 , bucketName+                 , bucketCORS+                 , bucketACLs+                 , bucketLifecycle+                 ]++requests :: IO ()+requests = do+    sp <- testSpaces+    spacesRequest <- newSpacesRequest (testBuilder sp) testTime++    hspec . describe "Network.DO.Spaces.Request" $ do+        it "generates the canonical request"+            $ (spacesRequest & canonicalRequest) `shouldBe` canonRequest++        it "generates the string to sign"+            $ mkStringToSign spacesRequest `shouldBe` strToSign++        it "generates the signature"+            $ mkSignature spacesRequest strToSign `shouldBe` sig++        it "generates the authorization"+            $ mkAuthorization spacesRequest strToSign `shouldBe` auth+  where+    bodyHash           =+        "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"++    canonRequest       = Canonicalized+        $ C.intercalate "\n"+                        [ "GET"+                        , "/"+                        , ""+                        , "host:a-bucket.sgp1.digitaloceanspaces.com"+                        , "x-amz-content-sha256:" <> bodyHash+                        , "x-amz-date:20210404T214315Z"+                        , ""+                        , "host;x-amz-content-sha256;x-amz-date"+                        , bodyHash+                        ]++    strToSign          = StringToSign+        $ C.intercalate "\n"+                        [ "AWS4-HMAC-SHA256"+                        , "20210404T214315Z"+                        , "20210404/sgp1/s3/aws4_request"+                        , "266d2fb56a251205c42c7e0deb7d2e370574cf190f366ecf53179c27697c8e38"+                        ]++    sig                =+        Signature "3d0da77e916e588d05f0190f8c350eddb47337953897b1e0cfdb44075fd6b2b9"++    auth               = Authorization+        $ mconcat [ "AWS4-HMAC-SHA256 Credential="+                  , "II5JDQBAN3JYM4DNEB6C"+                  , "/"+                  , "20210404/sgp1/s3/aws4_request, "+                  , "SignedHeaders="+                  , "host;x-amz-content-sha256;x-amz-date, "+                  , "Signature="+                  , uncompute sig+                  ]++    testTime           = read @UTCTime "2021-04-04 21:43:15 +0000"++    testBuilder spaces = SpacesRequestBuilder+        { spaces+        , method         = Nothing+        , body           = Nothing+        , headers        = mempty+        , bucket         = Just testBucket+        , object         = Nothing+        , subresources   = Nothing+        , queryString    = Nothing+        , overrideRegion = Nothing+        }++    testBucket         = Bucket "a-bucket"++testSpaces :: IO Spaces+testSpaces =+    newSpaces Singapore+              (Explicit (AccessKey "II5JDQBAN3JYM4DNEB6C")+                        (SecretKey "wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY"))++errorResponse :: IO ()+errorResponse = do+    apiEx <- withSourceFile "./tests/data/error-response.xml" $ \body -> do+        let headers = mempty+            raw     = RawResponse { .. }+        parseErrorResponse status raw++    hspec+        . describe "Network.DO.Spaces.Actions.parseErrorResponse"+        . it "parses Spaces XML error responses correctly"+        $ apiEx+        `shouldBe` APIException+        { code      = "SignatureDoesNotMatch"+        , requestID = "tx000012a832c-nyc3"+        , hostID    = "71f0230-nyc3a-nyc"+        , status+        }+  where+    status = mkStatus 403 ""++listAllBucketsResponse :: IO ()+listAllBucketsResponse = do+    sp <- testSpaces+    allBuckets+        <- withSourceFile "./tests/data/list-all-buckets.xml" $ \body -> do+            let headers = mempty+                raw     = RawResponse { .. }+            runSpacesT (consumeResponse @_ @ListAllBuckets raw) sp+    d1 <- iso8601ParseM @_ @UTCTime "2017-06-23T18:37:48.157Z"+    d2 <- iso8601ParseM @_ @UTCTime "2017-06-23T18:37:48.157Z"++    hspec+        . describe "Network.DO.Spaces.Actions.ListAllBuckets"+        . it "parses the response correctly"+        $ allBuckets+        `shouldBe` ListAllBucketsResponse+        { owner   = Owner (OwnerID 6174283) (OwnerID 6174283)+        , buckets = S.fromList [ BucketInfo (Bucket "static-images") d1+                               , BucketInfo (Bucket "log-files") d2+                               ]+        }++listBucket :: IO ()+listBucket = do+    sp <- testSpaces+    bucketContents+        <- withSourceFile "./tests/data/list-bucket.xml" $ \body -> do+            let headers = mempty+                raw     = RawResponse { .. }+            runSpacesT (consumeResponse @_ @ListBucket raw) sp+    d1 <- iso8601ParseM @_ @UTCTime "2017-07-13T18:40:46.777Z"+    d2 <- iso8601ParseM @_ @UTCTime "2017-07-14T17:44:03.597Z"++    hspec . describe "Network.DO.Spaces.Actions.ListBucket" $ do+        it "parses the response correctly"+            $ bucketContents `shouldBe` listBucketResp d1 d2++        it "ensures maxKeys is within the correct range" $ do+            let badReq  = listBucketReq $ Just (-1)+                badReq2 = listBucketReq $ Just 1001+            runSpacesT (buildRequest badReq) sp+                `shouldThrow` (InvalidRequest msg ==)+            runSpacesT (buildRequest badReq2) sp+                `shouldThrow` (InvalidRequest msg ==)+  where+    listBucketReq maxKeys = ListBucket+        { bucket    = Bucket "some-bucket"+        , delimiter = Nothing+        , marker    = Nothing+        , prefix    = Nothing+        , maxKeys+        }++    msg                   = "ListBucket: maxKeys must be >= 0 && <= 1000"++    listBucketResp d1 d2 = ListBucketResponse+        { bucket      = Bucket "static-images"+        , prefix      = Nothing+        , marker      = Nothing+        , nextMarker  = Nothing+        , maxKeys     = 1000+        , isTruncated = False+        , objects     =+              S.fromList [ ObjectInfo+                           { object       = Object "example.txt"+                           , lastModified = d1+                           , etag         = "b3a92f49e7ae64acbf6b3e76f2040f5e"+                           , size         = 14+                           , owner        =+                                 Owner (OwnerID 6174283) (OwnerID 6174283)+                           }+                         , ObjectInfo+                           { object       = Object "sammy.png"+                           , lastModified = d2+                           , etag         = "fb08934ef619f205f272b0adfd6c018c"+                           , size         = 35369+                           , owner        =+                                 Owner (OwnerID 6174283) (OwnerID 6174283)+                           }+                         ]+        }++bucketLocationResponse :: IO ()+bucketLocationResponse = do+    sp <- testSpaces+    bucketContents+        <- withSourceFile "./tests/data/bucket-location.xml" $ \body -> do+            let headers = mempty+                raw     = RawResponse { .. }+            runSpacesT (consumeResponse @_ @GetBucketLocation raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.GetBucketLocation"+        . it "parses the response correctly"+        $ bucketContents+        `shouldBe` GetBucketLocationResponse { locationConstraint = NewYork }++objectInfoResponse :: IO ()+objectInfoResponse = do+    sp <- testSpaces+    let body    = sourceLazy mempty+        headers = [ (CI.mk "Content-Type", "text/plain")+                  , (CI.mk "Content-Length", "14")+                  , (CI.mk "Etag", "b3a92f49e7ae64acbf6b3e76f2040f5e")+                  , (CI.mk "Last-Modified", "Thu, 13 Jul 2017 18:40:46 GMT")+                  ]+        raw     = RawResponse { .. }+    objectInfo <- runSpacesT (consumeResponse @_ @GetObjectInfo raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.GetObjectInfo"+        . it "parses response headers correctly"+        $ objectInfo+        `shouldBe` ObjectMetadata+        { contentLength = 14+        , contentType   = "text/plain"+        , etag          = "b3a92f49e7ae64acbf6b3e76f2040f5e"+        , lastModified  = testTime+        }+  where+    testTime = read @UTCTime "2017-07-13 18:40:46 +0000"++copyObject :: IO ()+copyObject = do+    sp <- testSpaces+    copyObjectDate <- iso8601ParseM @_ @UTCTime "2017-07-10T20:22:54.167Z"+    copyObjectResp+        <- withSourceFile "./tests/data/copy-object.xml" $ \body -> do+            let headers = mempty+                raw     = RawResponse { .. }+            runSpacesT (consumeResponse @_ @CopyObject raw) sp++    hspec . describe "Network.DO.Spaces.Actions.CopyObject" $ do+        it "parses the response correctly"+            $ copyObjectResp+            `shouldBe` CopyObjectResponse+            { lastModified = copyObjectDate+            , etag         = "7967bfe102f83fb5fc7e5a02bf05e8fc"+            }++        it "ensures the correct metadataDirective is provided"+            $ runSpacesT (buildRequest badReq) sp+            `shouldThrow` (InvalidRequest msg ==)+  where+    badReq    = CopyObject+        { srcBucket+        , srcObject+        , destBucket        = srcBucket+        , destObject        = srcObject+        , metadataDirective = Copy+        , acl               = Nothing+        }++    srcObject = Object "some-object"++    srcBucket = Bucket "some-bucket"++    msg       = mconcat [ "CopyObject: "+                        , "Object cannot be copied to itself unless "+                        , "REPLACE directive is specified"+                        ]++beginMultipartResponse :: IO ()+beginMultipartResponse = do+    sp <- testSpaces+    multipart+        <- withSourceFile "./tests/data/begin-multipart.xml" $ \body -> do+            let headers = mempty+                raw     = RawResponse { .. }+            runSpacesT (consumeResponse @_ @BeginMultipart raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.BeginMultipart"+        . it "parses the response correctly"+        $ multipart+        `shouldBe` BeginMultipartResponse+        { session = MultipartSession+              { bucket   = Bucket "static-images"+              , object   = Object "multipart-file.tar.gz"+              , uploadID = "2~iCw_lDY8VoBhoRrIJbPMrUqnE3Z-3Qh"+              }+        }++listPartsResponse :: IO ()+listPartsResponse = do+    sp <- testSpaces+    d <- iso8601ParseM @_ @UTCTime "2017-08-14T18:45:01.601Z"+    listParts <- withSourceFile "./tests/data/list-parts.xml" $ \body -> do+        let headers = mempty+            raw     = RawResponse { .. }+        runSpacesT (consumeResponse @_ @ListParts raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.ListParts"+        . it "parses the response correctly"+        $ listParts `shouldBe` listPartsResp d+  where+    listPartsResp lastModified = ListPartsResponse+        { bucket         = Bucket "my-new-bucket"+        , object         = Object "multipart-file.tar.gz"+        , uploadID       = "2~iCw_lDY8VoBhoRrIJbPMrUqnE3Z-3Qh"+        , partMarker     = 0+        , nextPartMarker = 1+        , maxParts       = 1000+        , isTruncated    = False+        , parts          =+              S.fromList [ Part+                           { partNumber   = 1+                           , etag         = "d8d3ed3a4de016917a814a2cf5acad3c"+                           , size         = 5242880+                           , lastModified+                           }+                         , Part+                           { partNumber   = 2+                           , etag         = "adf5feafc0fe4632008d5cb30beb1c49"+                           , size         = 5242880+                           , lastModified+                           }+                         ]+        }++bucketName :: IO ()+bucketName = hspec . describe "Network.DO.Spaces.Types.mkBucket" $ do+    it "rejects invalid Bucket names"+        . for_ [ "doc_example_bucket"+               , "doc-example-bucket-"+               , "do"+               , T.replicate 64 "d"+               ]+        $ \name -> mkBucket name `shouldThrow` matchErr++    it "accepts valid Bucket names"+        . for_ [ "docexamplebucket1"+               , "log-delivery-march-2020"+               , "my-hosted-content"+               ]+        $ \name -> mkBucket name `shouldSatisfy` isJust+  where+    matchErr (OtherError _) = True+    matchErr _              = False++bucketCORS :: IO ()+bucketCORS = do+    sp <- testSpaces+    cors <- withSourceFile "./tests/data/get-bucket-cors.xml" $ \body -> do+        let headers = mempty+            raw     = RawResponse { .. }+        runSpacesT (consumeResponse @_ @GetBucketCORS raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.GetBucketCORS"+        . it "parses the response correctly"+        $ (cors ^. #rules & toList)+        `shouldBe` [ CORSRule+                     { allowedOrigin  = "http://example.com"+                     , allowedMethods = [ PUT, DELETE, POST ]+                     , allowedHeaders = [ "*" ]+                     }+                   , CORSRule+                     { allowedOrigin  = "*"+                     , allowedMethods = [ GET ]+                     , allowedHeaders = mempty+                     }+                   ]++bucketACLs :: IO ()+bucketACLs = do+    sp <- testSpaces+    acls <- withSourceFile "./tests/data/get-bucket-acls.xml" $ \body -> do+        let headers = mempty+            raw     = RawResponse { .. }+        runSpacesT (consumeResponse @_ @GetBucketACLs raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.GetBucketACLs"+        . it "parses the response correctly"+        $ (acls ^. #accessControlList)+        `shouldBe` [ Grant { permission = ReadOnly, grantee = Group }+                   , Grant+                     { permission = FullControl+                     , grantee    = CanonicalUser (Owner (OwnerID 6174283)+                                                         (OwnerID 6174283))+                     }+                   ]++bucketLifecycle :: IO ()+bucketLifecycle = do+    sp <- testSpaces+    rs <- withSourceFile "./tests/data/get-bucket-lifecycle.xml" $ \body -> do+        let headers = mempty+            raw     = RawResponse { .. }+        runSpacesT (consumeResponse @_ @GetBucketLifecycle raw) sp++    hspec+        . describe "Network.DO.Spaces.Actions.GetBucketACLs"+        . it "parses the response correctly"+        $ (rs ^. #rules)+        `shouldBe` [ LifecycleRule+                     { id'             = LifecycleID "Expire old logs"+                     , enabled         = True+                     , expiration      = Just (AfterDays 90)+                     , prefix          = Just "logs/"+                     , abortIncomplete = Nothing+                     }+                   , LifecycleRule+                     { id'             =+                           LifecycleID "Remove uncompleted uploads"+                     , enabled         = True+                     , abortIncomplete = Just 1+                     , expiration      = Nothing+                     , prefix          = Nothing+                     }+                   ]
+ tests/data/begin-multipart.xml view
@@ -0,0 +1,6 @@+<?xml version="1.0" encoding="UTF-8"?>+<InitiateMultipartUploadResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+  <Bucket>static-images</Bucket>+  <Key>multipart-file.tar.gz</Key>+  <UploadId>2~iCw_lDY8VoBhoRrIJbPMrUqnE3Z-3Qh</UploadId>+</InitiateMultipartUploadResult>
+ tests/data/bucket-location.xml view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+  <LocationConstraint xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+    nyc3+  </LocationConstraint>
+ tests/data/copy-object.xml view
@@ -0,0 +1,4 @@+<CopyObjectResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+  <LastModified>2017-07-10T20:22:54.167Z</LastModified>+  <ETag>7967bfe102f83fb5fc7e5a02bf05e8fc</ETag>+</CopyObjectResult>
+ tests/data/error-response.xml view
@@ -0,0 +1,6 @@+<?xml version="1.0" encoding="UTF-8"?>+<Error>+  <Code>SignatureDoesNotMatch</Code>+  <RequestId>tx000012a832c-nyc3</RequestId>+  <HostId>71f0230-nyc3a-nyc</HostId>+</Error>
+ tests/data/get-bucket-acls.xml view
@@ -0,0 +1,22 @@+<?xml version="1.0" encoding="UTF-8"?>+  <AccessControlPolicy xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+    <Owner>+      <ID>6174283</ID>+      <DisplayName>6174283</DisplayName>+    </Owner>+    <AccessControlList>+      <Grant>+        <Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="Group">+          <URI>http://acs.amazonaws.com/groups/global/AllUsers</URI>+        </Grantee>+        <Permission>READ</Permission>+      </Grant>+      <Grant>+        <Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="CanonicalUser">+          <ID>6174283</ID>+          <DisplayName>6174283</DisplayName>+        </Grantee>+        <Permission>FULL_CONTROL</Permission>+      </Grant>+    </AccessControlList>+  </AccessControlPolicy>
+ tests/data/get-bucket-cors.xml view
@@ -0,0 +1,13 @@+<CORSConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+  <CORSRule>+    <AllowedMethod>PUT</AllowedMethod>+    <AllowedMethod>DELETE</AllowedMethod>+    <AllowedMethod>POST</AllowedMethod>+    <AllowedOrigin>http://example.com</AllowedOrigin>+    <AllowedHeader>*</AllowedHeader>+  </CORSRule>+  <CORSRule>+    <AllowedMethod>GET</AllowedMethod>+    <AllowedOrigin>*</AllowedOrigin>+  </CORSRule>+</CORSConfiguration>
+ tests/data/get-bucket-lifecycle.xml view
@@ -0,0 +1,18 @@+<LifecycleConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+  <Rule>+    <ID>Expire old logs</ID>+    <Prefix>logs/</Prefix>+    <Status>Enabled</Status>+    <Expiration>+      <Days>90</Days>+    </Expiration>+  </Rule>+  <Rule>+    <ID>Remove uncompleted uploads</ID>+    <Status>Enabled</Status>+    <Prefix/>+    <AbortIncompleteMultipartUpload>+      <DaysAfterInitiation>1</DaysAfterInitiation>+    </AbortIncompleteMultipartUpload>+  </Rule>+</LifecycleConfiguration>
+ tests/data/list-all-buckets.xml view
@@ -0,0 +1,17 @@+<?xml version="1.0" encoding="UTF-8"?>+  <ListAllMyBucketsResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+    <Owner>+      <ID>6174283</ID>+      <DisplayName>6174283</DisplayName>+    </Owner>+    <Buckets>+      <Bucket>+        <Name>static-images</Name>+        <CreationDate>2017-06-23T18:37:48.157Z</CreationDate>+      </Bucket>+      <Bucket>+        <Name>log-files</Name>+        <CreationDate>2017-06-23T18:37:48.157Z</CreationDate>+      </Bucket>+    </Buckets>+  </ListAllMyBucketsResult>
+ tests/data/list-bucket.xml view
@@ -0,0 +1,29 @@+<?xml version="1.0" encoding="UTF-8"?>+<ListBucketResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+  <Name>static-images</Name>+  <Prefix/>+  <MaxKeys>1000</MaxKeys>+  <IsTruncated>false</IsTruncated>+  <Contents>+    <Key>example.txt</Key>+    <LastModified>2017-07-13T18:40:46.777Z</LastModified>+    <ETag>"b3a92f49e7ae64acbf6b3e76f2040f5e"</ETag>+    <Size>14</Size>+    <StorageClass>STANDARD</StorageClass>+    <Owner>+      <ID>6174283</ID>+      <DisplayName>6174283</DisplayName>+    </Owner>+  </Contents>+  <Contents>+    <Key>sammy.png</Key>+    <LastModified>2017-07-14T17:44:03.597Z</LastModified>+    <ETag>"fb08934ef619f205f272b0adfd6c018c"</ETag>+    <Size>35369</Size>+    <StorageClass>STANDARD</StorageClass>+    <Owner>+      <ID>6174283</ID>+      <DisplayName>6174283</DisplayName>+    </Owner>+  </Contents>+</ListBucketResult>
+ tests/data/list-parts.xml view
@@ -0,0 +1,27 @@+<?xml version="1.0" encoding="UTF-8"?>+<ListPartsResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/">+  <Bucket>my-new-bucket</Bucket>+  <Key>multipart-file.tar.gz</Key>+  <UploadId>2~iCw_lDY8VoBhoRrIJbPMrUqnE3Z-3Qh</UploadId>+  <StorageClass>STANDARD</StorageClass>+  <PartNumberMarker>0</PartNumberMarker>+  <NextPartNumberMarker>1</NextPartNumberMarker>+  <MaxParts>1000</MaxParts>+  <IsTruncated>false</IsTruncated>+  <Owner>+    <ID>612423</ID>+    <DisplayName>612423</DisplayName>+  </Owner>+  <Part>+    <LastModified>2017-08-14T18:45:01.601Z</LastModified>+    <PartNumber>1</PartNumber>+    <ETag>"d8d3ed3a4de016917a814a2cf5acad3c"</ETag>+    <Size>5242880</Size>+  </Part>+  <Part>+    <LastModified>2017-08-14T18:45:01.601Z</LastModified>+    <PartNumber>2</PartNumber>+    <ETag>"adf5feafc0fe4632008d5cb30beb1c49"</ETag>+    <Size>5242880</Size>+  </Part>+</ListPartsResult>