diff --git a/CHANGELOG.org b/CHANGELOG.org --- a/CHANGELOG.org +++ b/CHANGELOG.org @@ -1,4 +1,9 @@ #+TITLE: Changelog +* v0.2 ++ ~newSpaces~ no longer directly takes a ~Region~ argument. The region is now instead loaded along with the credentials. See the haddocks for more details ++ ~Discover~ was added to ~CredentialSource~ to try credential files first, falling back on environment variables ++ ~Owner(id')~ was renamed to ~ownerID~, ~LifeCycleRule(id')~ to ~lifecyleID~ + * v0.1 -Initial release ++ Initial release diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -9,13 +9,13 @@ - 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: +~Network.DO.Spaces~ exposes the types and actions requires to make transactions through the Spaces API. The first step is to configure a client: #+begin_src haskell someTransaction = do - mySpaces <- newSpaces NewYork (FromFile "~/.spaces-secrets" Nothing) + mySpaces <- newSpaces $ 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. +There are a few options for supplying your credentials and region. 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. @@ -24,44 +24,32 @@ A small example: #+begin_src haskell -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} - -import Data.Sequence ( Seq ) -import Data.Generics.Product ( HasField(field) ) +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeApplications #-} + +import Control.Monad.IO.Class +import Data.Sequence ( Seq ) +import Data.Generics.Labels () import Lens.Micro -- or whatever compatible lens library you fancy import Network.DO.Spaces -myObjects :: IO (Seq ObjectInfo) +myObjects :: MonadIO m => m (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" + -- Load your region and credentials by first trying to read from + -- $XDG_CONFIG_HOME/do-spaces/credentials or ~/.aws/credentials, + -- falling back on environment variables if neither exist + spaces <- newSpaces Discover -- 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 + -- "Network.DO.Spaces" with different options + response <- runSpaces spaces $ listBucket =<< mkBucket "my-real-bucket" -- See the note about accessing record fields below - return $ response ^. field @"result" . field @"objects" + pure $ response ^. #result . #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. +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 have used ~DuplicateRecordFields~ throughout this library and have chosen not to export field selectors by default. 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. My personal preference is to use the ~generic-lens~ package. * 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. diff --git a/do-spaces.cabal b/do-spaces.cabal --- a/do-spaces.cabal +++ b/do-spaces.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: do-spaces -version: 0.1.0 +version: 0.2 synopsis: DigitalOcean Spaces API bindings description: See the README at https://gitlab.com/ngua/do-spaces-hs license: BSD-3-Clause @@ -12,13 +12,12 @@ 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 +extra-doc-files: CHANGELOG.org - tests/data/*.xml - io-tests/creds.conf - io-tests/creds.conf.skel + README.org +extra-source-files: tests/data/*.xml + source-repository head type: git location: https://gitlab.com/ngua/do-spaces-hs.git @@ -27,6 +26,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wmissing-deriving-strategies common common-extensions default-extensions: OverloadedStrings @@ -38,30 +38,32 @@ library import: common-options, common-extensions build-depends: - , base >=4.13 && <5 + , base >=4.13 && <5 , base16-bytestring , bytestring >=0.9 - , case-insensitive >=1.0 && <1.3 + , 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 + , cryptonite >=0.25 && <0.30 , exceptions ^>=0.10 - , extra >=1.6 && <1.8 + , extra >=1.6 && <1.8 , filepath ^>=1.4 - , generic-lens >=1.1 && <2.2 - , http-client-tls ^>=0.3.5 + , generic-lens >=1.1 && <2.2 + , http-api-data ^>=0.4 + , http-client-tls ^>=0.3 , 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 + , memory >=0.14 && <0.17 + , microlens ^>=0.4 + , mime-types ^>=0.1 + , mtl >=2.2 , text ^>=1.2 - , time >=1.8 && <1.12 - , transformers ^>=0.5 - , xml-conduit >=1.8.0.1 && <1.10 + , time >=1.8 && <1.13 + , transformers >=0.5 + , unliftio ^>=0.2 + , xml-conduit >=1.8 && <1.10 exposed-modules: Network.DO.Spaces @@ -99,23 +101,23 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests build-depends: - , base >=4.13 && <5 + , base >=4.13 && <5 , bytestring >=0.9 - , case-insensitive >=1.0 && <1.3 + , 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 + , generic-lens >=1.1 && <2.2 + , hspec >=2.0 && <3.0 + , http-client-tls ^>=0.3 , http-conduit ^>=2.3 , http-types ^>=0.12 - , microlens >=0.4.10 && <0.4.13 - , mtl ^>=2.2 + , microlens ^>=0.4 + , mtl >=2.2 , resourcet ^>=1.2 , text ^>=1.2 - , time >=1.8 && <1.12 + , time >=1.8 && <1.13 main-is: Main.hs default-language: Haskell2010 @@ -129,20 +131,20 @@ type: exitcode-stdio-1.0 hs-source-dirs: io-tests build-depends: - , base >=4.13 && <5 + , 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 + , 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 + , microlens ^>=0.4 + , microlens-ghc ^>=0.4 , text ^>=1.2 - , time >=1.8 && <1.12 + , time >=1.8 && <1.13 main-is: Main.hs default-language: Haskell2010 diff --git a/io-tests/Main.hs b/io-tests/Main.hs --- a/io-tests/Main.hs +++ b/io-tests/Main.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | --- WARNING +-- __WARNING__ -- Run at your own risk! -- -- Running the tests in this module requires an active Digital Ocean spaces @@ -13,86 +15,65 @@ -- * 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 +-- * 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 author of this package does not take responsibility for any of the above +-- or any other damages not is explicitly mentioned here. -- +-- Before running, make sure that the 'Discover' credentials source will +-- succeed. In addition, make sure to export the @SPACES_DEFAULT_BUCKET@ +-- environment variable. This should correspond to a bucket name that will +-- be used to run some of the tests +-- -- 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 +-- Similarly, the default bucket as exported by @SPACES_DEFAULT_BUCKET@ +-- 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 cleanup 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 Control.Monad.Catch ( MonadCatch(catch) ) -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.Environment ( lookupEnv ) import System.Time.Extra ( sleep ) import Test.Hspec main :: IO () -main = sequence_ [ bucketCreateDelete - , bucketActions - , objectCreateDelete - , objectActions - , multipart - ] +main = hspec $ sequence_ [ objectActionSpec, multipartSpec, bucketSpec ] -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 +{- HLINT ignore "Redundant do" -} +objectActionSpec :: Spec +objectActionSpec = around withTestObject $ do + describe "Network.DO.Spaces.Actions.GetObjectInfo" $ do + it "retrieves object information" $ \(bucket, spaces, 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 + describe "Network.DO.Spaces.Actions.CopyObject" $ do + it "copies an existing object to a new object" + $ \(bucket, spaces, object) -> do destObject <- nameWithEpoch mkObject "test-object-copy-" copied <- runSpaces spaces $ copyObjectWithin bucket object destObject @@ -101,117 +82,92 @@ $ 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" + describe "Network.DO.Spaces.Actions.GetObject" $ do + it "retrieves object data" $ \(bucket, spaces, 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 + (bucket, spaces) <- getCreds object <- nameWithEpoch mkObject "test-object-" void . runSpaces spaces $ uploadObject (Just "text/plain") bucket object body - return object + pure (bucket, spaces, object) where body = sourceLazy "hello from haskell" - deleteTestObject object = do - (bucket, spaces) <- readConf + deleteTestObject (bucket, spaces, object) = do 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 +multipartSpec :: Spec +multipartSpec = do + around withMultipart $ do + describe "Network.DO.Spaces.multipartObject" $ do + it "uploads a multipart object" $ \(bucket, spaces, 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 + withMultipart = bracket uploadTestObject cleanup - body = sourceLazy $ LC.replicate 10485760 'f' + uploadTestObject = do + (bucket, spaces) <- getCreds + object <- nameWithEpoch mkObject "test-multipart-" + pure (bucket, spaces, object) -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 + cleanup (bucket, spaces, object) = + void . retry404 20 . runSpaces spaces $ deleteObject bucket object - deleted - <- retry404 20 . runSpaces spaces $ deleteObject bucket object - getStatus deleted `shouldBe` Just 204 - (deleted ^. #result) `shouldBe` () - where - body = sourceLazy "hello from haskell" + body = sourceLazy $ LC.replicate 10485760 'f' -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) +bucketSpec :: Spec +bucketSpec = beforeAll getCreds $ do + describe "Network.DO.Spaces.Actions.GetBucketLocation" $ do + it "retrieves a bucket's location" $ \(bucket, spaces) -> 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 ] + describe "Network.DO.Spaces.Actions.ListAllBuckets" $ do + it "lists account owner's buckets" $ \(bucket, spaces) -> 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 + context "Network.DO.Spaces.Actions Bucket CRUD" $ do + it "creates, reads, and deletes a new bucket" $ \(_, spaces) -> do + bucket <- nameWithEpoch mkBucket "do-spaces-test-" created <- runSpaces spaces $ createBucket bucket Nothing Nothing getStatus created `shouldBe` Just 200 - (created ^. #result) `shouldBe` () - + created ^. #result `shouldBe` () deleted <- retry404 20 . runSpaces spaces $ deleteBucket bucket getStatus deleted `shouldBe` Just 204 - (deleted ^. #result) `shouldBe` () + 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 +-- A crude 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) + loop !n = catch @_ @ClientException action $ catch404 n - catch404 n e@(HTTPStatus s _) + catch404 !n e@(HTTPStatus s _) | H.statusCode s == 404, n < maxRetries = liftIO (sleep 1) >> loop (n + 1) | otherwise = throwM e - catch404 _ e = 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, @@ -222,28 +178,11 @@ 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 +getCreds :: IO (Bucket, Spaces) +getCreds = lookupEnv "SPACES_DEFAULT_BUCKET" >>= \case + Nothing -> throwIO + $ userError "Please export SPACES_DEFAULT_BUCKET to run the tests" + Just b -> (,) <$> mkBucket (T.pack b) <*> newSpaces Discover getStatus :: SpacesResponse a -> Maybe Int getStatus = (^? #metadata . _Just . #status . to H.statusCode) diff --git a/io-tests/creds.conf b/io-tests/creds.conf deleted file mode 100644 --- a/io-tests/creds.conf +++ /dev/null @@ -1,4 +0,0 @@ -access=EUTZTPU7IKRELWXQ4SQW -secret=qW4cL9oE34II4uFVWnSjE8DMr6exxqJBlim9AjDHqkM -region=sgp1 -bucket=tiengnam-sg diff --git a/io-tests/creds.conf.skel b/io-tests/creds.conf.skel deleted file mode 100644 --- a/io-tests/creds.conf.skel +++ /dev/null @@ -1,4 +0,0 @@ -access=REPLACEME -secret=REPLACEME -region=REPLACEME -bucket=REPLACEME diff --git a/src/Network/DO/Spaces.hs b/src/Network/DO/Spaces.hs --- a/src/Network/DO/Spaces.hs +++ b/src/Network/DO/Spaces.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -72,37 +73,21 @@ , Profile , CORSRule , mkCORSRule - , Grant(..) + , Grant , Grantee(..) , Permission(..) , LifecycleID , mkLifecycleID , SpacesException , ClientException(..) - , APIException(..) + , 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 Control.Monad.Catch ( MonadCatch(catch) ) -import Data.Bifunctor ( Bifunctor(bimap) ) import Data.Bool ( bool ) import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as LB @@ -116,14 +101,13 @@ 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.DO.Spaces.Utils import Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) ) import Network.HTTP.Client.TLS ( getGlobalManager ) import Network.Mime @@ -133,83 +117,121 @@ , mimeByExt ) -import System.Environment ( lookupEnv ) import qualified System.FilePath as F +import UnliftIO.Directory +import UnliftIO.Environment + -- | Perform a transaction using your 'Spaces' client configuration. Note that --- this does /not/ perform any exception handling; if caught at the lower level, +-- 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: +-- | Create a new 'Spaces' by specifying a method to retrieve the region and +-- your credentials. -- +-- 'Discover' will first try to find a credentials file (see the notes on 'FromFile' +-- below) in @~/.aws/credentials@ or @$XDG_CONFIG_HOME/do-spaces/credentials@, in +-- that order, using the @[default]@ profile. Failing that, it will try the equivalent +-- of @FromEnv Nothing@ (see the notes below). +-- -- '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 +-- > aws_default_region=fra1 -- --- '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. +-- When provided with @Nothing@, 'FromEnv' will look up the following environment +-- variables to find your region and keys: -- --- You can also choose to provide both keys yourself with 'Explicit' +-- * For the 'Region': -- -newSpaces - :: (MonadThrow m, MonadIO m) => Region -> CredentialSource -> m Spaces -newSpaces region cs = do +-- - @AWS_DEFAULT_REGION@ +-- - /OR/ @SPACES_DEFAULT_REGION@ +-- +-- * For the 'AccessKey': +-- +-- - @AWS_ACCESS_KEY_ID@ +-- - /OR/ @SPACES_ACCESS_KEY_ID@ +-- - /OR/ @SPACES_ACCESS_KEY@ +-- +-- * For the 'SecretKey': +-- +-- - @AWS_SECRET_ACCESS_KEY@ +-- - /OR/ @SPACES_SECRET_ACCESS_KEY@ +-- - /OR/ @SPACES_SECRET_KEY@ +-- +-- Alternatively, you can directly specify a tuple of environment variables to +-- search for. +-- +-- You can also choose to provide the region and both keys yourself with 'Explicit' +-- +newSpaces :: (MonadThrow m, MonadIO m) => CredentialSource -> m Spaces +newSpaces 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" + (region, accessKey, secretKey) <- liftIO $ source cs + pure Spaces { .. } + +source :: (MonadIO m, MonadCatch m) + => CredentialSource + -> m (Region, AccessKey, SecretKey) +source = \case + Discover -> catch @_ @ClientException tryFile $ const tryEnv + where + tryFile = do + cfgDir <- getXdgDirectory XdgConfig "do-spaces" + findFile [ ".aws", cfgDir ] "credentials" >>= \case + Nothing -> + throwM $ ConfigurationError "No credentials file found" + Just fp -> source $ FromFile fp Nothing + + tryEnv = source $ FromEnv Nothing + + Explicit region ak sk -> pure (region, ak, sk) + + FromEnv (Just (region, a, s)) -> ensureVars + =<< (,,) <$> lookupVar region <*> lookupVar a <*> lookupVar s + + FromEnv Nothing -> do + region <- lookupVars [ "AWS_DEFAULT_REGION", "SPACES_DEFAULT_REGION" ] + ak <- lookupVars [ "AWS_ACCESS_KEY_ID" , "SPACES_ACCESS_KEY_ID" , "SPACES_ACCESS_KEY" ] - sk <- lookupKeys [ "AWS_SECRET_ACCESS_KEY" + sk <- lookupVars [ "AWS_SECRET_ACCESS_KEY" , "SPACES_SECRET_ACCESS_KEY" , "SPACES_SECRET_KEY" ] - ensureKeys (ak, sk) + ensureVars (region, ak, sk) - source (FromFile fp profile) = do + 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 + <$> liftIO (runConduitRes (sourceFile fp + .| decodeUtf8C + .| sinkLazy)) + either (throwM . ConfigurationError . T.pack) ensureVars + $ I.parseIniFile contents parseConf 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 + $ (,,) + <$> (fmap (T.unpack . T.toLower) + <$> I.fieldMb "aws_default_region") + <*> (fmap T.unpack <$> I.fieldMb "aws_access_key_id") + <*> (fmap T.unpack <$> I.fieldMb "aws_secret_access_key") + where + lookupVars xs = asum <$> sequence (lookupEnv <$> xs) - 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" + lookupVar = lookupEnv . T.unpack - mkKey f = f . C.pack + ensureVars = \case + (Just r, Just a, Just s) -> do + reg <- slugToRegion r + pure (reg, coerce $ C.pack a, coerce $ C.pack s) + (_, _, _) -> throwM . ConfigurationError + $ "Missing acces/secret keys and/or region" -- | Upload an 'Object' within a single request uploadObject :: MonadSpaces m @@ -225,7 +247,7 @@ -- | 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 +-- will be made to run a 'CancelMultipart' request, and the exception will be -- rethrown multipartObject :: MonadSpaces m @@ -256,20 +278,17 @@ 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) + go !n = awaitForever $ \v -> do + let pieceBody = RequestBodyLBS v + uploadPart = + runAction NoMetadata $ UploadPart session n pieceBody + etag <- lift $ uploadPart <&> (^. field @"result" . field @"etag") + yield etag >> go (n + 1) + inChunks = loop 0 [] where - loop n chunk = await >>= maybe (yieldChunk chunk) go + loop !n chunk = await >>= maybe (yieldChunk chunk) go where go bs = bool (loop len newChunk) (yieldChunk newChunk >> loop 0 []) @@ -450,8 +469,8 @@ case nextMarker of Just _ | isTruncated -> go (os <> objects) nextMarker - | otherwise -> return $ os <> objects - Nothing -> return $ os <> objects + | otherwise -> pure $ os <> objects + Nothing -> pure $ os <> objects -- | Get the 'CORSRule's configured for a given 'Bucket' getBucketCORS :: MonadSpaces m => Bucket -> m (SpacesResponse GetBucketCORS) @@ -537,7 +556,4 @@ -- 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' --- --- --- -- diff --git a/src/Network/DO/Spaces/Actions.hs b/src/Network/DO/Spaces/Actions.hs --- a/src/Network/DO/Spaces/Actions.hs +++ b/src/Network/DO/Spaces/Actions.hs @@ -127,7 +127,7 @@ =<< runConduit (body .| sinkLbs) result <- consumeResponse @_ @a raw - return SpacesResponse { .. } + pure SpacesResponse { .. } parseErrorResponse :: (MonadThrow m, MonadIO m) => Status -> RawResponse m -> m APIException @@ -139,5 +139,5 @@ $ cursor $/ X.laxElement "RequestId" &/ X.content hostID <- X.force (xmlElemError "HostId") $ cursor $/ X.laxElement "HostId" &/ X.content - return APIException { .. } + pure APIException { .. } diff --git a/src/Network/DO/Spaces/Actions/CopyObject.hs b/src/Network/DO/Spaces/Actions/CopyObject.hs --- a/src/Network/DO/Spaces/Actions/CopyObject.hs +++ b/src/Network/DO/Spaces/Actions/CopyObject.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -37,28 +38,14 @@ 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 ) +data MetadataDirective + = Copy + | Replace + deriving stock ( Show, Eq, Generic ) -- | Copy and 'Object' from one 'Bucket' to another. Both buckets must -- be in the same region @@ -70,11 +57,11 @@ , metadataDirective :: MetadataDirective , acl :: Maybe CannedACL } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) data CopyObjectResponse = CopyObjectResponse { etag :: ETag, lastModified :: UTCTime } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) instance MonadSpaces m => Action m CopyObject where type ConsumedResponse CopyObject = CopyObjectResponse @@ -88,16 +75,16 @@ , "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 - , .. - } + pure 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 [ "/" diff --git a/src/Network/DO/Spaces/Actions/CreateBucket.hs b/src/Network/DO/Spaces/Actions/CreateBucket.hs --- a/src/Network/DO/Spaces/Actions/CreateBucket.hs +++ b/src/Network/DO/Spaces/Actions/CreateBucket.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} + +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} @@ -28,15 +30,7 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( Action(..) - , Bucket - , CannedACL - , Method(PUT) - , MonadSpaces - , Region - , SpacesRequestBuilder(..) - ) -import Network.DO.Spaces.Utils ( showCannedACL ) +import Network.DO.Spaces.Utils -- | Create a new, empty 'Bucket' data CreateBucket = CreateBucket @@ -46,7 +40,7 @@ -- ^ The 'CannedACL' to use; defaults to -- 'Network.DO.Spaces.Types.CannedACL.Private' } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) type CreateBucketResponse = () @@ -55,17 +49,17 @@ buildRequest CreateBucket { .. } = do spaces <- ask - return SpacesRequestBuilder - { bucket = Just bucket - , method = Just PUT - , overrideRegion = region - , body = Nothing - , object = Nothing - , queryString = Nothing - , subresources = Nothing - , .. - } + pure 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 () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/DeleteBucket.hs b/src/Network/DO/Spaces/Actions/DeleteBucket.hs --- a/src/Network/DO/Spaces/Actions/DeleteBucket.hs +++ b/src/Network/DO/Spaces/Actions/DeleteBucket.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -25,18 +27,13 @@ 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 +newtype DeleteBucket = DeleteBucket { bucket :: Bucket -- ^ The name of the 'Bucket' to delete } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) type DeleteBucketResponse = () @@ -45,16 +42,16 @@ 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 - , .. - } + pure SpacesRequestBuilder + { method = Just DELETE + , bucket = Just bucket + , body = Nothing + , object = Nothing + , queryString = Nothing + , subresources = Nothing + , headers = mempty + , overrideRegion = Nothing + , .. + } - consumeResponse _ = return () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/DeleteBucketCORS.hs b/src/Network/DO/Spaces/Actions/DeleteBucketCORS.hs --- a/src/Network/DO/Spaces/Actions/DeleteBucketCORS.hs +++ b/src/Network/DO/Spaces/Actions/DeleteBucketCORS.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -28,17 +30,12 @@ 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 ) +newtype DeleteBucketCORS = DeleteBucketCORS { bucket :: Bucket } + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) type DeleteBucketCORSResponse = () @@ -47,20 +44,20 @@ 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 - ) - ] - , .. - } + pure 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 () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/DeleteBucketLifecycle.hs b/src/Network/DO/Spaces/Actions/DeleteBucketLifecycle.hs --- a/src/Network/DO/Spaces/Actions/DeleteBucketLifecycle.hs +++ b/src/Network/DO/Spaces/Actions/DeleteBucketLifecycle.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -28,16 +30,11 @@ 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 ) +newtype DeleteBucketLifecycle = DeleteBucketLifecycle { bucket :: Bucket } + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) type DeleteBucketLifecycleResponse = () @@ -46,20 +43,20 @@ 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 - ) - ] - , .. - } + pure 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 () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/DeleteObject.hs b/src/Network/DO/Spaces/Actions/DeleteObject.hs --- a/src/Network/DO/Spaces/Actions/DeleteObject.hs +++ b/src/Network/DO/Spaces/Actions/DeleteObject.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,17 +26,10 @@ 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 ) + deriving stock ( Show, Eq, Generic ) type DeleteObjectResponse = () @@ -44,16 +38,16 @@ 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 - , .. - } + pure SpacesRequestBuilder + { bucket = Just bucket + , object = Just object + , method = Just DELETE + , body = Nothing + , queryString = Nothing + , subresources = Nothing + , headers = mempty + , overrideRegion = Nothing + , .. + } - consumeResponse _ = return () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/GetBucketACLs.hs b/src/Network/DO/Spaces/Actions/GetBucketACLs.hs --- a/src/Network/DO/Spaces/Actions/GetBucketACLs.hs +++ b/src/Network/DO/Spaces/Actions/GetBucketACLs.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -28,18 +30,13 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( ACLResponse - , Action(..) - , Bucket - , MonadSpaces - , SpacesRequestBuilder(..) - ) -import Network.DO.Spaces.Utils ( aclP, xmlDocCursor ) +import Network.DO.Spaces.Utils 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 ) +newtype GetBucketACLs = GetBucketACLs { bucket :: Bucket } + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) type GetBucketACLsResponse = ACLResponse @@ -48,20 +45,20 @@ 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 - ) - ] - , .. - } + pure 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 diff --git a/src/Network/DO/Spaces/Actions/GetBucketCORS.hs b/src/Network/DO/Spaces/Actions/GetBucketCORS.hs --- a/src/Network/DO/Spaces/Actions/GetBucketCORS.hs +++ b/src/Network/DO/Spaces/Actions/GetBucketCORS.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -34,14 +36,7 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( Action(..) - , Bucket - , CORSRule(..) - , MonadSpaces - , SpacesRequestBuilder(..) - , mkCORSRule - ) -import Network.DO.Spaces.Utils ( xmlDocCursor, xmlElemError ) +import Network.DO.Spaces.Utils import qualified Network.HTTP.Types as H import Text.Read ( readMaybe ) @@ -49,32 +44,35 @@ import Text.XML.Cursor ( ($/), (&/), (&|) ) -- | Get the 'CORSRule's associated with a 'Bucket' -data GetBucketCORS = GetBucketCORS { bucket :: Bucket } - deriving ( Show, Eq, Generic ) +newtype GetBucketCORS = GetBucketCORS { bucket :: Bucket } + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) -data GetBucketCORSResponse = GetBucketCORSResponse { rules :: Seq CORSRule } - deriving ( Show, Eq, Generic ) +newtype GetBucketCORSResponse = + GetBucketCORSResponse { rules :: Seq CORSRule } + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) 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 - ) - ] - , .. - } + pure 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 diff --git a/src/Network/DO/Spaces/Actions/GetBucketLifecycle.hs b/src/Network/DO/Spaces/Actions/GetBucketLifecycle.hs --- a/src/Network/DO/Spaces/Actions/GetBucketLifecycle.hs +++ b/src/Network/DO/Spaces/Actions/GetBucketLifecycle.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} @@ -36,21 +38,7 @@ 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 ) @@ -62,33 +50,35 @@ -- | 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 ) +newtype GetBucketLifecycle = GetBucketLifecycle { bucket :: Bucket } + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) -data GetBucketLifecycleResponse = +newtype GetBucketLifecycleResponse = GetBucketLifecycleResponse { rules :: [LifecycleRule] } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) 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 - ) - ] - , .. - } + pure 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 @@ -97,11 +87,11 @@ ruleP :: MonadThrow m => Cursor X.Node -> m LifecycleRule ruleP c = do - id' <- X.force (xmlElemError "ID") + lifecycleID <- 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 { .. } + pure LifecycleRule { .. } where prefix = xmlMaybeElem c "Prefix" @@ -116,8 +106,8 @@ &| (readMaybe . T.unpack) readStatus = \case - "Enabled" -> return True - "Disabled" -> return False + "Enabled" -> pure True + "Disabled" -> pure False _ -> throwM $ InvalidXML "GetBucketLifecycle: invalid Status" -- TODO find a less hideous way of doing this diff --git a/src/Network/DO/Spaces/Actions/GetBucketLocation.hs b/src/Network/DO/Spaces/Actions/GetBucketLocation.hs --- a/src/Network/DO/Spaces/Actions/GetBucketLocation.hs +++ b/src/Network/DO/Spaces/Actions/GetBucketLocation.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -28,54 +30,47 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( Action(..) - , Bucket - , MonadSpaces - , Region(..) - , SpacesRequestBuilder(..) - ) -import Network.DO.Spaces.Utils ( slugToRegion - , xmlDocCursor - , xmlElemError - ) +import Network.DO.Spaces.Utils 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 +newtype GetBucketLocation = GetBucketLocation { bucket :: Bucket -- ^ The name of the 'Bucket' whose location you'd like to retrieve } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) -data GetBucketLocationResponse = GetBucketLocationResponse +newtype GetBucketLocationResponse = GetBucketLocationResponse { locationConstraint :: Region -- ^ The 'Region' of the queried 'Bucket' } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) 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 - ) - ] - , .. - } + pure 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 diff --git a/src/Network/DO/Spaces/Actions/GetObject.hs b/src/Network/DO/Spaces/Actions/GetObject.hs --- a/src/Network/DO/Spaces/Actions/GetObject.hs +++ b/src/Network/DO/Spaces/Actions/GetObject.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -31,41 +32,33 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( Action(..) - , Bucket - , MonadSpaces - , Object - , ObjectMetadata - , RawResponse(..) - , SpacesRequestBuilder(..) - ) -import Network.DO.Spaces.Utils ( lookupObjectMetadata ) +import Network.DO.Spaces.Utils -- | 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 ) + deriving stock ( Show, Eq, Generic ) data GetObjectResponse = GetObjectResponse { objectMetadata :: ObjectMetadata, objectData :: LB.ByteString } - deriving ( Show, Eq, Generic ) + deriving stock ( 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 - , .. - } + pure 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 diff --git a/src/Network/DO/Spaces/Actions/GetObjectACLs.hs b/src/Network/DO/Spaces/Actions/GetObjectACLs.hs --- a/src/Network/DO/Spaces/Actions/GetObjectACLs.hs +++ b/src/Network/DO/Spaces/Actions/GetObjectACLs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -28,19 +29,12 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( ACLResponse - , Action(..) - , Bucket - , MonadSpaces - , Object - , SpacesRequestBuilder(..) - ) -import Network.DO.Spaces.Utils ( aclP, xmlDocCursor ) +import Network.DO.Spaces.Utils 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 ) + deriving stock ( Show, Eq, Generic ) type GetObjectACLsResponse = ACLResponse @@ -49,20 +43,20 @@ 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 - ) - ] - , .. - } + pure 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 diff --git a/src/Network/DO/Spaces/Actions/GetObjectInfo.hs b/src/Network/DO/Spaces/Actions/GetObjectInfo.hs --- a/src/Network/DO/Spaces/Actions/GetObjectInfo.hs +++ b/src/Network/DO/Spaces/Actions/GetObjectInfo.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -26,20 +27,12 @@ import GHC.Generics ( Generic ) import Network.DO.Spaces.Types - ( Action(..) - , Bucket - , Method(HEAD) - , MonadSpaces - , Object - , ObjectMetadata(..) - , SpacesRequestBuilder(..) - ) -import Network.DO.Spaces.Utils ( lookupObjectMetadata ) +import Network.DO.Spaces.Utils -- | Get information about an 'Object'; the response does not contain the -- object itself data GetObjectInfo = GetObjectInfo { bucket :: Bucket, object :: Object } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) type GetObjectInfoResponse = ObjectMetadata @@ -48,16 +41,16 @@ 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 - , .. - } + pure SpacesRequestBuilder + { bucket = Just bucket + , object = Just object + , method = Just HEAD + , body = Nothing + , queryString = Nothing + , subresources = Nothing + , headers = mempty + , overrideRegion = Nothing + , .. + } consumeResponse = lookupObjectMetadata diff --git a/src/Network/DO/Spaces/Actions/ListAllBuckets.hs b/src/Network/DO/Spaces/Actions/ListAllBuckets.hs --- a/src/Network/DO/Spaces/Actions/ListAllBuckets.hs +++ b/src/Network/DO/Spaces/Actions/ListAllBuckets.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} @@ -29,47 +30,35 @@ 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 ) + deriving stock ( Show, Eq, Generic ) data ListAllBucketsResponse = ListAllBucketsResponse { owner :: Owner, buckets :: Seq BucketInfo } - deriving ( Show, Eq, Generic ) + deriving stock ( 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 - , .. - } + pure SpacesRequestBuilder + { body = Nothing + , method = Nothing + , object = Nothing + , queryString = Nothing + , subresources = Nothing + , bucket = Nothing + , headers = mempty + , overrideRegion = Nothing + , .. + } consumeResponse raw = do cursor <- xmlDocCursor raw @@ -77,7 +66,7 @@ $ cursor $/ X.laxElement "Owner" &| ownerP bs <- X.force (xmlElemError "Buckets") $ cursor $/ X.laxElement "Buckets" &| bucketsP - return ListAllBucketsResponse { buckets = S.fromList bs, .. } + pure ListAllBucketsResponse { buckets = S.fromList bs, .. } where bucketsP c = X.forceM (xmlElemError "Bucket") . sequence $ c $/ X.laxElement "Bucket" &| bucketInfoP @@ -87,4 +76,4 @@ $ c $/ X.laxElement "Name" &/ X.content &| coerce creationDate <- X.forceM (xmlElemError "Creation date") $ c $/ X.laxElement "CreationDate" &/ X.content &| xmlUTCTime - return BucketInfo { .. } + pure BucketInfo { .. } diff --git a/src/Network/DO/Spaces/Actions/ListBucket.hs b/src/Network/DO/Spaces/Actions/ListBucket.hs --- a/src/Network/DO/Spaces/Actions/ListBucket.hs +++ b/src/Network/DO/Spaces/Actions/ListBucket.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -37,31 +38,14 @@ 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 ( ($/), (&/), (&|) ) +import Web.HttpApiData ( ToHttpApiData(toQueryParam) ) + -- | List the contents ('Object's) of a 'Bucket' data ListBucket = ListBucket { bucket :: Bucket @@ -74,7 +58,7 @@ -- ^ String value to group keys. Only objects whose names begin with the -- prefix are returned } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) data ListBucketResponse = ListBucketResponse { bucket :: Bucket @@ -92,7 +76,7 @@ -- ^ Indicates whether the response contains all possible 'Object's , objects :: Seq ObjectInfo } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) instance MonadSpaces m => Action m ListBucket where type ConsumedResponse ListBucket = ListBucketResponse @@ -103,21 +87,22 @@ $ 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 - , .. - } + pure 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 + , ("marker", ) . T.encodeUtf8 . toQueryParam + <$> marker , ("max-keys", ) . bshow <$> maxKeys , ("prefix", ) . T.encodeUtf8 <$> prefix ] @@ -133,7 +118,7 @@ let prefix = xmlMaybeElem cursor "Prefix" marker = coerce <$> xmlMaybeElem cursor "Marker" nextMarker = coerce <$> xmlMaybeElem cursor "NextMarker" - return ListBucketResponse { .. } + pure ListBucketResponse { .. } where objectInfoP c = do object <- X.force (xmlElemError "Key") @@ -144,4 +129,4 @@ $ c $/ X.laxElement "Size" &/ X.content &| xmlInt owner <- X.forceM (xmlElemError "Owner") $ c $/ X.laxElement "Owner" &| ownerP - return ObjectInfo { .. } + pure ObjectInfo { .. } diff --git a/src/Network/DO/Spaces/Actions/SetBucketACLs.hs b/src/Network/DO/Spaces/Actions/SetBucketACLs.hs --- a/src/Network/DO/Spaces/Actions/SetBucketACLs.hs +++ b/src/Network/DO/Spaces/Actions/SetBucketACLs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -29,15 +30,7 @@ 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.DO.Spaces.Utils import Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) ) import qualified Network.HTTP.Types as H @@ -46,7 +39,7 @@ , acls :: [Grant] , owner :: Owner -- ^ The bucket owner } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) type SetBucketACLsResponse = () @@ -55,20 +48,20 @@ 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 - ) - ] - , .. - } + pure 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 () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/SetBucketCORS.hs b/src/Network/DO/Spaces/Actions/SetBucketCORS.hs --- a/src/Network/DO/Spaces/Actions/SetBucketCORS.hs +++ b/src/Network/DO/Spaces/Actions/SetBucketCORS.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} + +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,8 +18,6 @@ -- Stability : experimental -- Portability : GHC -- -{-# OPTIONS_GHC -Wno-unused-imports #-} - module Network.DO.Spaces.Actions.SetBucketCORS ( SetBucketCORSResponse , SetBucketCORS(..) @@ -27,20 +27,12 @@ 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.DO.Spaces.Utils import Network.HTTP.Conduit ( RequestBody(RequestBodyLBS) ) import qualified Network.HTTP.Types as H @@ -48,7 +40,7 @@ -- | Set a 'Bucket'\'s 'CORSRule's data SetBucketCORS = SetBucketCORS { bucket :: Bucket, rules :: [CORSRule] } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) type SetBucketCORSResponse = () @@ -57,20 +49,20 @@ 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 - ) - ] - , .. - } + pure 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 @@ -86,4 +78,4 @@ , mkNode "AllowedMethod" . tshow <$> allowedMethods ] - consumeResponse _ = return () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/SetBucketLifecycle.hs b/src/Network/DO/Spaces/Actions/SetBucketLifecycle.hs --- a/src/Network/DO/Spaces/Actions/SetBucketLifecycle.hs +++ b/src/Network/DO/Spaces/Actions/SetBucketLifecycle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -32,16 +33,7 @@ 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.DO.Spaces.Utils import Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) ) import qualified Network.HTTP.Types as H @@ -50,7 +42,7 @@ -- | Configure the 'LifecycleRule's for a 'Bucket' data SetBucketLifecycle = SetBucketLifecycle { bucket :: Bucket, rules :: [LifecycleRule] } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) type SetBucketLifecycleResponse = () @@ -59,20 +51,20 @@ 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 - ) - ] - , .. - } + pure 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 @@ -88,7 +80,7 @@ rulesNode LifecycleRule { .. } = X.NodeElement $ X.Element "Rule" mempty nodes where - nodes = [ mkNode "ID" (coerce id') + nodes = [ mkNode "ID" (coerce lifecycleID) , mkNode "Status" (showEnabled enabled) ] <> foldMap (pure . mkNode "Prefix") prefix @@ -111,4 +103,4 @@ mempty [ mkNode "DaysAfterInitiation" (tshow days) ] - consumeResponse _ = return () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/SetObjectACLs.hs b/src/Network/DO/Spaces/Actions/SetObjectACLs.hs --- a/src/Network/DO/Spaces/Actions/SetObjectACLs.hs +++ b/src/Network/DO/Spaces/Actions/SetObjectACLs.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} + +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -29,16 +31,7 @@ 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.DO.Spaces.Utils import Network.HTTP.Client.Conduit ( RequestBody(RequestBodyLBS) ) import qualified Network.HTTP.Types as H @@ -49,7 +42,7 @@ , owner :: Owner -- ^ The object owner , acls :: [Grant] } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) type SetObjectACLsResponse = () @@ -58,20 +51,20 @@ 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 - ) - ] - , .. - } + pure 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 () + consumeResponse _ = pure () diff --git a/src/Network/DO/Spaces/Actions/UploadMultipart.hs b/src/Network/DO/Spaces/Actions/UploadMultipart.hs --- a/src/Network/DO/Spaces/Actions/UploadMultipart.hs +++ b/src/Network/DO/Spaces/Actions/UploadMultipart.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} @@ -51,32 +53,7 @@ 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 ) @@ -92,14 +69,14 @@ , etag :: ETag , size :: Int -- ^ Size in bytes } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) data MultipartSession = MultipartSession { bucket :: Bucket , object :: Object , uploadID :: UploadID -- } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | A unique ID assigned to a multipart upload session type UploadID = Text @@ -111,31 +88,32 @@ , optionalHeaders :: UploadHeaders , contentType :: Maybe MimeType } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) newtype BeginMultipartResponse = BeginMultipartResponse { session :: MultipartSession } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) 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 - ) - ] - , .. - } + pure 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)) @@ -148,41 +126,41 @@ bucket <- bucketP cursor uploadID <- X.force (xmlElemError "UploadId") $ cursor $/ X.laxElement "UploadId" &/ X.content - return $ BeginMultipartResponse { session = MultipartSession { .. } } + pure $ BeginMultipartResponse { session = MultipartSession { .. } } data UploadPart = UploadPart { session :: MultipartSession, partNumber :: Int, body :: RequestBody } - deriving ( Generic ) + deriving stock ( Generic ) data UploadPartResponse = UploadPartResponse { etag :: ETag } - deriving ( Show, Eq, Generic ) + deriving stock ( 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") - ] - , .. - } + pure 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 + Nothing -> throwM $ InvalidResponse "Missing/malformed headers" + Just r -> pure r -- | Complete a multipart session data CompleteMultipart = CompleteMultipart @@ -190,7 +168,7 @@ , parts :: [(Int, ETag)] -- ^ The part numbers and 'ETag's of each uploaded part } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) data CompleteMultipartResponse = CompleteMultipartResponse { location :: Text @@ -200,27 +178,27 @@ -- ^ The MD5 hash of the final object, i.e. all of the cumulative -- uploaded parts } - deriving ( Show, Eq, Generic ) + deriving stock ( 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" - ) - ] - , .. - } + pure 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 @@ -244,11 +222,12 @@ $ cursor $/ X.laxElement "Location" &/ X.content object <- objectP cursor etag <- etagP cursor - return CompleteMultipartResponse { .. } + pure CompleteMultipartResponse { .. } -- | Cancel an active multipart upload session newtype CancelMultipart = CancelMultipart { session :: MultipartSession } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) type CancelMultipartResponse = () @@ -257,27 +236,28 @@ 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" - ) - ] - , .. - } + pure 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 () + consumeResponse _ = pure () -- | List all of the 'Part's of a multipart upload session newtype ListParts = ListParts { session :: MultipartSession } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Generic ) + deriving newtype ( Eq ) data ListPartsResponse = ListPartsResponse { bucket :: Bucket @@ -291,28 +271,28 @@ , maxParts :: Int , isTruncated :: Bool } - deriving ( Show, Eq, Generic ) + deriving stock ( 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" - ) - ] - , .. - } + pure 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 @@ -327,7 +307,7 @@ partMarker <- xmlNum "PartNumberMarker" cursor nextPartMarker <- xmlNum "NextPartNumberMarker" cursor - return ListPartsResponse { .. } + pure ListPartsResponse { .. } where partP c = Part <$> xmlNum "PartNumber" c <*> lastModifiedP c diff --git a/src/Network/DO/Spaces/Actions/UploadObject.hs b/src/Network/DO/Spaces/Actions/UploadObject.hs --- a/src/Network/DO/Spaces/Actions/UploadObject.hs +++ b/src/Network/DO/Spaces/Actions/UploadObject.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -29,22 +30,7 @@ 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 ) @@ -57,29 +43,29 @@ , optionalHeaders :: UploadHeaders , contentType :: Maybe MimeType } - deriving ( Generic ) + deriving stock ( Generic ) data UploadObjectResponse = UploadObjectResponse { etag :: ETag , contentLength :: Int -- ^ Length in bytes } - deriving ( Show, Eq, Generic ) + deriving stock ( 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 - , .. - } + pure 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)) @@ -91,7 +77,7 @@ $ UploadObjectResponse <$> (readEtag =<< lookupHeader' "etag") <*> (readContentLen =<< lookupHeader' "Content-Length") case resp of - Just r -> return r - Nothing -> throwM $ OtherError "Missing/malformed headers" + Just r -> pure r + Nothing -> throwM $ InvalidResponse "Missing/malformed headers" where lookupHeader' = lookupHeader raw diff --git a/src/Network/DO/Spaces/Request.hs b/src/Network/DO/Spaces/Request.hs --- a/src/Network/DO/Spaces/Request.hs +++ b/src/Network/DO/Spaces/Request.hs @@ -38,6 +38,7 @@ import Data.Function ( (&) ) import Data.Generics.Product ( HasField(field) ) import Data.Generics.Product.Positions ( HasPosition(position) ) +import Data.Generics.Wrapped import Data.List ( sort ) import Data.Maybe ( fromMaybe ) import qualified Data.Text as T @@ -103,7 +104,7 @@ (fromMaybe mempty queryString) request payloadHash - return + pure $ SpacesRequest { method = reqMethod, headers = headers <> newHeaders, .. } where @@ -126,7 +127,7 @@ , request & H.requestHeaders & canonicalizeHeaders - & unCanonicalized + & wrappedTo , request & H.requestHeaders & joinHeaderNames , uncompute payloadHash ] diff --git a/src/Network/DO/Spaces/Types.hs b/src/Network/DO/Spaces/Types.hs --- a/src/Network/DO/Spaces/Types.hs +++ b/src/Network/DO/Spaces/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,6 +17,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + -- | -- Module : Network.DO.Spaces.Types -- Copyright : (c) 2021 Rory Tyler Hayford @@ -58,6 +61,7 @@ , BodyBS , Method(..) , Region(..) + , RequestID , CacheControl , ContentDisposition , ContentEncoding @@ -132,13 +136,17 @@ import Network.HTTP.Types.Status ( Status ) import Network.Mime ( MimeType ) +import Web.HttpApiData ( ToHttpApiData ) + newtype SpacesT m a = SpacesT (ReaderT Spaces m a) - deriving ( Generic, Functor, Applicative, Monad, MonadIO, MonadThrow - , MonadCatch, MonadReader Spaces, MonadUnliftIO ) + deriving stock ( Generic ) + deriving newtype ( Functor, Applicative, Monad, MonadIO, MonadThrow + , MonadCatch, MonadReader Spaces, MonadUnliftIO ) runSpacesT :: SpacesT m a -> Spaces -> m a runSpacesT (SpacesT x) = runReaderT x +-- | A synonym for the constraints necessary to run 'SpacesT' actions type MonadSpaces m = (MonadReader Spaces m, MonadIO m, MonadUnliftIO m, MonadCatch m) @@ -149,7 +157,7 @@ , region :: Region -- ^ The DO region , manager :: Manager -- ^ HTTP 'Manager' } - deriving ( Generic ) + deriving stock ( Generic ) instance HasHttpManager Spaces where getHttpManager = manager @@ -166,7 +174,7 @@ -- ^ The canonicalized HTTP 'Request' , time :: UTCTime } - deriving ( Generic ) + deriving stock ( Generic ) data SpacesRequestBuilder = SpacesRequestBuilder { spaces :: Spaces @@ -182,7 +190,7 @@ -- should be able to override the region configured in the 'Spaces' -- client } - deriving ( Generic ) + deriving stock ( Generic ) -- | DO regions where Spaces is available (only a subset of all regions) data Region @@ -191,16 +199,22 @@ | SanFrancisco -- ^ SFO3 | Singapore -- ^ SGP1 | Frankfurt -- ^ FRA1 - deriving ( Show, Eq, Generic ) + deriving stock ( 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 ) +data Method + = GET + | POST + | PUT + | DELETE + | HEAD + deriving stock ( Show, Eq, Generic, Ord, Read ) -- | The name of a single storage bucket -newtype Bucket = Bucket { unBucket :: Text } - deriving ( Show, Eq, Generic ) +newtype Bucket = Bucket Text + deriving stock ( Show, Generic ) + deriving newtype ( Eq, ToHttpApiData ) -- | Smart constructor for 'Bucket's; names must conform to the following rules: -- @@ -226,7 +240,7 @@ 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 + | otherwise = pure . Bucket $ T.map toLower t where len = T.length t @@ -238,16 +252,18 @@ -- | Information about a single 'Bucket' data BucketInfo = BucketInfo { name :: Bucket, creationDate :: UTCTime } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | The name of a \"key\", in AWS parlance -newtype Object = Object { unObject :: Text } - deriving ( Show, Eq, Generic ) +newtype Object = Object Text + deriving stock ( Show, Generic ) + deriving newtype ( Eq, ToHttpApiData ) -- | 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 +mkObject t + | T.null t = throwM . OtherError $ "Object: Name must not be empty" + | otherwise = pure $ Object t -- | Information about a single 'Object', returned when listing a 'Bucket'\'s -- contents @@ -258,7 +274,7 @@ , size :: Int -- ^ Size in bytes , owner :: Owner } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | Metadata returned when querying information about an 'Object' data ObjectMetadata = ObjectMetadata @@ -267,15 +283,16 @@ , etag :: ETag , lastModified :: UTCTime } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | The resource owner -data Owner = Owner { id' :: OwnerID, displayName :: DisplayName } - deriving ( Show, Eq, Generic ) +data Owner = Owner { ownerID :: OwnerID, displayName :: DisplayName } + deriving stock ( 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 ) +newtype OwnerID = OwnerID Int + deriving stock ( Show, Generic ) + deriving newtype ( Eq, Num, ToHttpApiData ) -- | The display name is always equivalent to the owner's ID; Spaces includes -- it for AWS compatibility @@ -292,7 +309,7 @@ , contentEncoding :: Maybe ContentEncoding , metadata :: UserMetadata } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | @Cache-Control@ request header value type CacheControl = Text @@ -314,34 +331,36 @@ , allowedMethods :: [Method] , allowedHeaders :: [HeaderName] } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | An individual access grant data Grant = Grant { permission :: Permission, grantee :: Grantee } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | Access grant level; Spaces currently only supports these two levels -data Permission = ReadOnly | FullControl - deriving ( Show, Eq, Generic, Ord ) +data Permission + = ReadOnly + | FullControl + deriving stock ( 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 ) + deriving stock ( 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 ) + deriving stock ( Show, Eq, Generic ) type Days = Word16 -- | Lifecycle configuration for a 'Bucket' data LifecycleRule = LifecycleRule - { id' :: LifecycleID + { lifecycleID :: LifecycleID , enabled :: Bool -- ^ The status of the @LifecycleRule@ , prefix :: Maybe Text -- ^ When specified, only 'Object's which share the prefix will be affected @@ -350,15 +369,17 @@ , abortIncomplete :: Maybe Days -- ^ When specified, configures the deletion of incomplete multipart uploads } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | Configuration for automatically deleting expire 'Object's -data LifecycleExpiration = AfterDays Days | OnDate UTCTime - deriving ( Show, Eq, Generic ) +data LifecycleExpiration + = AfterDays Days + | OnDate UTCTime + deriving stock ( Show, Eq, Generic ) -- | A unique ID for a 'LifecycleRule' newtype LifecycleID = LifecycleID Text - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | Smart constructor for 'LifecycleID', which may contain a maximum of 255 -- characters, including spaces @@ -366,7 +387,7 @@ mkLifecycleID t | T.length t > 255 = throwM $ OtherError "LifecycleID: ID exceeds maximum length (255 chars)" - | otherwise = return $ LifecycleID t + | otherwise = pure $ 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 @@ -377,20 +398,25 @@ $ 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 - } + | otherwise = pure 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 ) +newtype Canonicalized a = Canonicalized ByteString + deriving stock ( Show, Eq, Generic ) -- | Different types of computed 'ByteString's -data ComputedTag = Hash | StrToSign | Sig | Cred | Auth - deriving ( Show, Eq ) +data ComputedTag + = Hash + | StrToSign + | Sig + | Cred + | Auth + deriving stock ( 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 @@ -401,20 +427,20 @@ -- 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 + Hashed :: ByteString -> Computed Hash -- | Represents a \"string to sign\" that has been computed according to the -- Spaces/AWS v4 spec - StringToSign :: ByteString -> Computed 'StrToSign + StringToSign :: ByteString -> Computed StrToSign -- | Signed hash of a 'Request' body, a 'SecretKey', and request information - Signature :: ByteString -> Computed 'Sig - Credentials :: ByteString -> Computed 'Cred + Signature :: ByteString -> Computed Sig + Credentials :: ByteString -> Computed Cred -- | Authorization string containing information about your 'AccessKey' and -- your request - Authorization :: ByteString -> Computed 'Auth + Authorization :: ByteString -> Computed Auth -deriving instance Show (Computed a) +deriving stock instance Show (Computed a) -deriving instance Eq (Computed a) +deriving stock instance Eq (Computed a) type StringToSign = Computed 'StrToSign @@ -437,11 +463,11 @@ -- | Spaces access key newtype AccessKey = AccessKey { unAccessKey :: ByteString } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | Spaces secret key newtype SecretKey = SecretKey { unSecretKey :: ByteString } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | The name of a per-project configuration profile to select when loading -- credentials from a file @@ -457,7 +483,7 @@ -- A response, before being transformed into a 'ConsumedResponse' data RawResponse m = RawResponse { headers :: [Header], body :: BodyBS m } - deriving ( Generic ) + deriving stock ( Generic ) -- | A request or response body type BodyBS m = ConduitT () ByteString m () @@ -471,11 +497,13 @@ , date :: Maybe UTCTime , status :: Status -- ^ HTTP status } - deriving ( Show, Eq, Generic ) + deriving stock ( Show, Eq, Generic ) -- | Whether or not to retain 'SpacesMetadata' when consuming responses -data WithMetadata = KeepMetadata | NoMetadata - deriving ( Show, Eq, Generic ) +data WithMetadata + = KeepMetadata + | NoMetadata + deriving stock ( Show, Eq, Generic ) -- | A 'ConsumedResponse' with optional 'SpacesMetadata' data SpacesResponse a = SpacesResponse @@ -485,12 +513,12 @@ -- ^ 'SpacesMetadata', the retention of which can be controlled using -- 'WithMetadata' } - deriving ( Generic ) + deriving stock ( Generic ) -deriving instance (Show (ConsumedResponse a)) => Show (SpacesResponse a) +deriving stock instance (Show (ConsumedResponse a)) => Show (SpacesResponse a) -- This instance is necessary to make the polymorphic @result@ field work with --- HasField +-- @HasField@ instance {-# OVERLAPPING #-}( GL.HasField' name (SpacesResponse a) s , s ~ t , a ~ b @@ -501,21 +529,24 @@ -- | 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. +-- | How to discover the 'Region', 'AccessKey', and 'SecretKey' when creating a +-- new 'Spaces' client. data CredentialSource - = FromEnv (Maybe (Text, Text)) -- ^ 'AccessKey' and 'SecretKey' env vars + = Discover + -- ^ Try a sequence of different sources until one succeeds + | FromEnv (Maybe (Text, Text, Text)) + -- ^ 'Region', '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 + | Explicit Region AccessKey SecretKey -- ^ Provide all values 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 ) + deriving stock ( Eq, Show ) -- | The base 'Exception' type for both 'ClientException's and 'APIException's data SpacesException = forall e. Exception e => SpacesException e @@ -536,13 +567,14 @@ -- | An exception generated within the 'Spaces' client data ClientException = InvalidRequest Text + | InvalidResponse 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 ) + deriving stock ( Show, Eq, Generic, Typeable ) instance Exception ClientException where toException = spsExToException @@ -556,7 +588,7 @@ , requestID :: RequestID -- ^ The unique ID of the request , hostID :: Text } - deriving ( Show, Eq, Generic, Typeable ) + deriving stock ( Show, Eq, Generic, Typeable ) instance Exception APIException where toException = spsExToException diff --git a/src/Network/DO/Spaces/Utils.hs b/src/Network/DO/Spaces/Utils.hs --- a/src/Network/DO/Spaces/Utils.hs +++ b/src/Network/DO/Spaces/Utils.hs @@ -117,14 +117,14 @@ Singapore -> "sgp1" Frankfurt -> "fra1" -slugToRegion :: MonadThrow m => Text -> m Region +slugToRegion :: (MonadThrow m, IsString a, Eq a) => a -> 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 + "nyc3" -> pure NewYork + "ams3" -> pure Amsterdam + "sfo3" -> pure SanFrancisco + "sgp1" -> pure Singapore + "fra1" -> pure Frankfurt + _ -> throwM . OtherError $ "Unrecognized region " -- | Map 'ByteString' chars to lower-case toLowerBS :: ByteString -> ByteString @@ -156,12 +156,12 @@ FullControl -> "FULL_CONTROL" handleMaybe :: MonadCatch m => (a -> m b) -> a -> m (Maybe b) -handleMaybe g x = handleAll (\_ -> return Nothing) (Just <$> g x) +handleMaybe g x = handleAll (\_ -> pure 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 (RequestBodyBS b) = pure $ LB.fromStrict b +bodyLBS (RequestBodyLBS lb) = pure lb bodyLBS _ = throwM $ InvalidRequest "Unsupported request body type" @@ -186,9 +186,9 @@ -- | XML parser for 'Owner' attribute ownerP :: MonadThrow m => Cursor Node -> m Owner ownerP c = do - id' <- X.forceM (xmlElemError "ID") + ownerID <- X.forceM (xmlElemError "ID") $ c $/ X.laxElement "ID" &/ X.content &| xmlInt @_ @OwnerID - return Owner { displayName = id', id' } + pure Owner { displayName = ownerID, ownerID } -- | XML parser for 'ETag' attribute etagP :: MonadThrow m => Cursor Node -> m ETag @@ -203,7 +203,7 @@ -- | 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 + Just n -> pure $ fromInteger n Nothing -> throwM $ InvalidXML "Failed to read integer value" -- | Read a 'Num' type, encoded as an integer, from XML @@ -214,7 +214,7 @@ -- | 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 + Just t -> pure t Nothing -> throwM $ InvalidXML "Failed to read ISO-8601 value" isTruncP :: MonadThrow m => Cursor Node -> m Bool @@ -250,27 +250,27 @@ <*> (readEtag =<< lookupHeader' "Etag") <*> (readDate =<< lookupHeader' "Last-Modified") case metadata of - Just md -> return md + Just md -> pure md Nothing -> throwM $ OtherError "Missing/malformed headers" where lookupHeader' = lookupHeader raw - readDate = MaybeT . return . parseAmzTime . C.unpack + readDate = MaybeT . pure . 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") +lookupHeader raw = MaybeT . pure . 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' +readEtag = MaybeT . pure . 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 +readContentLen = MaybeT . pure . readMaybe @Int . C.unpack aclP :: MonadThrow m => Cursor Node -> m ACLResponse aclP cursor = ACLResponse @@ -289,14 +289,14 @@ $ c $/ X.laxElement "Grantee" &| granteeP) where readPerm = \case - "FULL_CONTROL" -> return FullControl - "READ" -> return ReadOnly + "FULL_CONTROL" -> pure FullControl + "READ" -> pure 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 "Group" -> pure Group Just "CanonicalUser" -> CanonicalUser <$> ownerP c _ -> throwM $ InvalidXML "Invalid ACL Grantee type" _ -> throwM $ InvalidXML "Invalid ACL Grantee" @@ -322,7 +322,7 @@ $ X.Element "Owner" mempty [ mkNode "ID" - (r ^. field' @"owner" . field @"id'" + (r ^. field' @"owner" . field @"ownerID" & coerce @_ @Int & tshow) ] @@ -344,7 +344,7 @@ $ X.Element "Grantee" (granteeAttrs "CanonicalUser") [ mkNode "ID" - (owner ^. field @"id'" + (owner ^. field @"ownerID" & coerce @_ @Int & tshow) ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -3,7 +3,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} --- | module Main where import Conduit ( sourceLazy, withSourceFile ) @@ -86,8 +85,7 @@ , "266d2fb56a251205c42c7e0deb7d2e370574cf190f366ecf53179c27697c8e38" ] - sig = - Signature "3d0da77e916e588d05f0190f8c350eddb47337953897b1e0cfdb44075fd6b2b9" + sig = Signature "3d0da77e916e588d05f0190f8c350eddb47337953897b1e0cfdb44075fd6b2b9" auth = Authorization $ mconcat [ "AWS4-HMAC-SHA256 Credential=" @@ -118,8 +116,8 @@ testSpaces :: IO Spaces testSpaces = - newSpaces Singapore - (Explicit (AccessKey "II5JDQBAN3JYM4DNEB6C") + newSpaces (Explicit Singapore + (AccessKey "II5JDQBAN3JYM4DNEB6C") (SecretKey "wJalrXUtnFEMI/K7MDENG+bPxRfiCYEXAMPLEKEY")) errorResponse :: IO () @@ -440,14 +438,14 @@ . it "parses the response correctly" $ (rs ^. #rules) `shouldBe` [ LifecycleRule - { id' = LifecycleID "Expire old logs" + { lifecycleID = LifecycleID "Expire old logs" , enabled = True , expiration = Just (AfterDays 90) , prefix = Just "logs/" , abortIncomplete = Nothing } , LifecycleRule - { id' = + { lifecycleID = LifecycleID "Remove uncompleted uploads" , enabled = True , abortIncomplete = Just 1