diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +## [_Unreleased_](https://github.com/freckle/amazonka-mtl/compare/v0.1.0.0...main) + +## [v0.1.0.0](https://github.com/freckle/amazonka-mtl/tree/v0.1.0.0) + +First tagged pre-release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2021 Renaissance Learning Inc + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,105 @@ +# amazonka-mtl + +[![Hackage](https://img.shields.io/hackage/v/amazonka-mtl.svg?style=flat)](https://hackage.haskell.org/package/amazonka-mtl) +[![Stackage Nightly](http://stackage.org/package/amazonka-mtl/badge/nightly)](http://stackage.org/nightly/package/amazonka-mtl) +[![Stackage LTS](http://stackage.org/package/amazonka-mtl/badge/lts)](http://stackage.org/lts/package/amazonka-mtl) +[![CI](https://github.com/freckle/amazonka-mtl/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/amazonka-mtl/actions/workflows/ci.yml) + +MTL-style type-class and deriving-via newtypes for Amazonka. + +## Example + +This package allows incorporation of AWS actions into any MTL-style function, + + + +```haskell +import Amazonka.Data.Text (ToText(..)) +import Amazonka.S3.ListObjects +import Amazonka.S3.Types.Object +import Blammo.Logging +import Conduit +import Control.Lens hiding ((.=)) +import Control.Monad.AWS as AWS +``` + + + +```haskell +someAction + :: ( MonadIO m + , MonadLogger m + , MonadAWS m + , MonadReader env m + , HasSettings env + ) + => m () +someAction = do + Settings {..} <- view settingsL + + keys <- + runConduit + $ paginate (newListObjects settingsBucketName) + .| concatMapC (^. listObjectsResponse_contents) + .| concatC + .| mapC (^. object_key . to toText) + .| iterMC (\k -> logDebug $ k :# []) + .| sinkList + + logInfo $ "Bucket contents" :# ["keys" .= keys] +``` + + + +This package also provides a number of options for execution: + +- Through a concrete transformer: `Control.Monad.AWS.EnvT` +- Through your own reader env and deriving-via: `Control.Monad.AWS.ViaReader` + +This package also provides mechanisms for mocking AWS in tests: + +- Through a concrete transformer: `Control.Monad.AWS.MockT` +- Through your own reader env and deriving-via: `Control.Monad.AWS.ViaMock` + +Please see the [documentation on hackage][hackage] for all the details. + +[hackage]: https://hackage.haskell.org/package/amazonka-mtl + +## Development & Tests + +```console +stack build --fast --pedantic --test --file-watch +``` + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,105 @@ +# amazonka-mtl + +[![Hackage](https://img.shields.io/hackage/v/amazonka-mtl.svg?style=flat)](https://hackage.haskell.org/package/amazonka-mtl) +[![Stackage Nightly](http://stackage.org/package/amazonka-mtl/badge/nightly)](http://stackage.org/nightly/package/amazonka-mtl) +[![Stackage LTS](http://stackage.org/package/amazonka-mtl/badge/lts)](http://stackage.org/lts/package/amazonka-mtl) +[![CI](https://github.com/freckle/amazonka-mtl/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/amazonka-mtl/actions/workflows/ci.yml) + +MTL-style type-class and deriving-via newtypes for Amazonka. + +## Example + +This package allows incorporation of AWS actions into any MTL-style function, + + + +```haskell +import Amazonka.Data.Text (ToText(..)) +import Amazonka.S3.ListObjects +import Amazonka.S3.Types.Object +import Blammo.Logging +import Conduit +import Control.Lens hiding ((.=)) +import Control.Monad.AWS as AWS +``` + + + +```haskell +someAction + :: ( MonadIO m + , MonadLogger m + , MonadAWS m + , MonadReader env m + , HasSettings env + ) + => m () +someAction = do + Settings {..} <- view settingsL + + keys <- + runConduit + $ paginate (newListObjects settingsBucketName) + .| concatMapC (^. listObjectsResponse_contents) + .| concatC + .| mapC (^. object_key . to toText) + .| iterMC (\k -> logDebug $ k :# []) + .| sinkList + + logInfo $ "Bucket contents" :# ["keys" .= keys] +``` + + + +This package also provides a number of options for execution: + +- Through a concrete transformer: `Control.Monad.AWS.EnvT` +- Through your own reader env and deriving-via: `Control.Monad.AWS.ViaReader` + +This package also provides mechanisms for mocking AWS in tests: + +- Through a concrete transformer: `Control.Monad.AWS.MockT` +- Through your own reader env and deriving-via: `Control.Monad.AWS.ViaMock` + +Please see the [documentation on hackage][hackage] for all the details. + +[hackage]: https://hackage.haskell.org/package/amazonka-mtl + +## Development & Tests + +```console +stack build --fast --pedantic --test --file-watch +``` + +--- + +[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/amazonka-mtl.cabal b/amazonka-mtl.cabal new file mode 100644 --- /dev/null +++ b/amazonka-mtl.cabal @@ -0,0 +1,187 @@ +cabal-version: 1.18 +name: amazonka-mtl +version: 0.1.0.0 +license: MIT +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/amazonka-mtl#readme +bug-reports: https://github.com/freckle/amazonka-mtl/issues +synopsis: MTL-style type-class and deriving-via newtypes for Amazonka +description: + This package allows incorporation of AWS actions into any MTL-style function, + . + > import Amazonka.Data.Text (ToText(..)) + > import Amazonka.S3.ListObjects + > import Amazonka.S3.Types.Object + > import Blammo.Logging + > import Conduit + > import Control.Lens hiding ((.=)) + > import Control.Monad.AWS as AWS + > + > someAction + > :: ( MonadIO m + > , MonadLogger m + > , MonadAWS m + > , MonadReader env m + > , HasSettings env + > ) + > => m () + > someAction = do + > Settings {..} <- view settingsL + > + > keys <- + > runConduit + > $ paginate (newListObjects settingsBucketName) + > .| concatMapC (^. listObjectsResponse_contents) + > .| concatC + > .| mapC (^. object_key . to toText) + > .| iterMC (\k -> logDebug $ k :# []) + > .| sinkList + > + > logInfo $ "Bucket contents" :# ["keys" .= keys] + . + This package also provides a number of options for execution: + . + * Through a concrete transformer: "Control.Monad.AWS.EnvT" + * Through your own reader env and deriving-via: "Control.Monad.AWS.ViaReader" + . + This package also provides mechanisms for mocking AWS in tests: + . + * Through a concrete transformer: "Control.Monad.AWS.MockT" + * Through your own reader env and deriving-via: "Control.Monad.AWS.ViaMock" + . + Please see individual module documentation for all the details. + +category: Utils +build-type: Simple +extra-source-files: package.yaml +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/amazonka-mtl + +library + exposed-modules: + Control.Monad.AWS + Control.Monad.AWS.Class + Control.Monad.AWS.EnvT + Control.Monad.AWS.Matchers + Control.Monad.AWS.MockT + Control.Monad.AWS.ViaMock + Control.Monad.AWS.ViaReader + + hs-source-dirs: library + other-modules: Paths_amazonka_mtl + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe + + build-depends: + amazonka, + amazonka-core, + base >=4.14.3.0 && <5, + conduit, + lens, + mtl, + resourcet, + unliftio-core + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + other-modules: Paths_amazonka_mtl + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe -pgmL + markdown-unlit + + build-depends: + Blammo, + amazonka-core, + amazonka-mtl, + amazonka-s3, + base >=4.14.3.0 && <5, + conduit, + lens, + markdown-unlit, + mtl + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + other-modules: + Control.Monad.AWSSpec + Paths_amazonka_mtl + + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe -threaded + -rtsopts -with-rtsopts=-N + + build-depends: + amazonka-core, + amazonka-mtl, + amazonka-s3, + base >=4.14.3.0 && <5, + hspec, + lens, + text, + time + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module diff --git a/library/Control/Monad/AWS.hs b/library/Control/Monad/AWS.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS.hs @@ -0,0 +1,76 @@ +module Control.Monad.AWS + ( MonadAWS (..) + , send + , paginate + , paginateEither + , await + + -- * Concrete transformers + , EnvT + , runEnvT + , MockT + , runMockT + ) where + +import Amazonka.Prelude + +import Amazonka.Core (AWSPager, AWSRequest, AWSResponse, Error) +import qualified Amazonka.Pager as Pager +import qualified Amazonka.Waiter as Waiter +import qualified Control.Exception as Exception +import Control.Monad.AWS.Class +import Control.Monad.AWS.EnvT +import Control.Monad.AWS.MockT +import Data.Conduit (ConduitM) +import qualified Data.Conduit as Conduit +import Data.Typeable (Typeable) + +-- | Version of 'Amazonka.send' built on our 'sendEither' +send + :: ( MonadIO m + , MonadAWS m + , AWSRequest a + , Typeable a + , Typeable (AWSResponse a) + ) + => a + -> m (AWSResponse a) +send = sendEither >=> hoistEither + +-- | Version of 'Amazonka.paginateEither' built on our 'sendEither' +paginateEither + :: (MonadAWS m, AWSPager a, Typeable a, Typeable (AWSResponse a)) + => a + -> ConduitM () (AWSResponse a) m (Either Error ()) +paginateEither = go + where + go rq = + lift (sendEither rq) >>= \case + Left err -> pure (Left err) + Right rs -> do + Conduit.yield rs + maybe (pure (Right ())) go (Pager.page rq rs) + +-- | Version of 'Amazonka.paginate' built on our 'paginateEither' +paginate + :: ( MonadIO m + , MonadAWS m + , AWSPager a + , Typeable a + , Typeable (AWSResponse a) + ) + => a + -> ConduitM () (AWSResponse a) m () +paginate = + paginateEither >=> hoistEither + +-- | Version of 'Amazonka.await' built on our 'awaitEither' +await + :: (MonadIO m, MonadAWS m, AWSRequest a, Typeable a) + => Waiter.Wait a + -> a + -> m Waiter.Accept +await wait = awaitEither wait >=> hoistEither + +hoistEither :: MonadIO m => Either Error a -> m a +hoistEither = either (liftIO . Exception.throwIO) pure diff --git a/library/Control/Monad/AWS/Class.hs b/library/Control/Monad/AWS/Class.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS/Class.hs @@ -0,0 +1,33 @@ +module Control.Monad.AWS.Class + ( MonadAWS (..) + ) +where + +import Amazonka.Prelude + +import Amazonka.Core (AWSRequest, AWSResponse, Error) +import qualified Amazonka.Waiter as Waiter +import Data.Typeable (Typeable) + +-- | Typeclass for making AWS requests via "Amazonka" +-- +-- For out-of-the-box transformers, see: +-- +-- - "Control.Monad.AWS.EnvT" +-- - "Control.Monad.AWS.MockT" +-- +-- For @DerivingVia@ usage, see: +-- +-- - "Control.Monad.AWS.ViaReader" +-- - "Control.Monad.AWS.ViaMock" +class Monad m => MonadAWS m where + sendEither + :: (AWSRequest a, Typeable a, Typeable (AWSResponse a)) + => a + -> m (Either Error (AWSResponse a)) + + awaitEither + :: (AWSRequest a, Typeable a) + => Waiter.Wait a + -> a + -> m (Either Error Waiter.Accept) diff --git a/library/Control/Monad/AWS/EnvT.hs b/library/Control/Monad/AWS/EnvT.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS/EnvT.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DerivingVia #-} + +-- | Concrete reader monad over 'Env' +-- +-- Its 'MonadAWS' instance can be used in situations where you don't have or +-- want your own app transformer: +-- +-- @ +-- import qualified "Amazonka" +-- import "Amazonka.S3" +-- import "Control.Monad.AWS" +-- +-- main :: IO () +-- main = do +-- env <- 'Amazonka.newEnv' 'Amazonka.discover' +-- 'runEnvT' someAction env +-- +-- someAction :: (MonadIO m, 'MonadAWS' m) => m () +-- someAction = do +-- resp <- 'send' 'newListBuckets' +-- liftIO $ print resp +-- @ +module Control.Monad.AWS.EnvT + ( EnvT + , runEnvT + ) +where + +import Prelude + +import Control.Monad.AWS.Class +import Control.Monad.AWS.ViaReader +import Control.Monad.Reader +import Control.Monad.Trans.Resource + +newtype EnvT m a = EnvT + { unEnvT :: ReaderT Env (ResourceT m) a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadUnliftIO + , MonadResource + , MonadReader Env + ) + deriving (MonadAWS) via (ReaderAWS (EnvT m)) + +runEnvT :: MonadUnliftIO m => EnvT m a -> Env -> m a +runEnvT f = runResourceT . runReaderT (unEnvT f) diff --git a/library/Control/Monad/AWS/Matchers.hs b/library/Control/Monad/AWS/Matchers.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS/Matchers.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Control.Monad.AWS.Matchers + ( Matchers + , HasMatchers (..) + , Matcher (..) + , withMatcher + , withMatchers + , matchSend + , matchAwait + , UnmatchedRequestError (..) + ) where + +import Prelude + +import Amazonka (AWSRequest, AWSResponse, Error) +import qualified Amazonka.Waiter as Waiter +import Control.Exception (Exception (..), throwIO) +import Control.Lens (Lens', view, (<>~)) +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (MonadReader (..)) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Typeable + +-- | Define a response to provide for any matched requests +data Matcher where + -- Matches calls to 'send' where the given predicate holds + SendMatcher + :: forall a + . (AWSRequest a, Typeable a, Typeable (AWSResponse a)) + => (a -> Bool) + -> Either Error (AWSResponse a) + -> Matcher + -- Matches calls to 'await' where the given predicate holds + AwaitMatcher + :: forall a + . (AWSRequest a, Typeable a) + => (Waiter.Wait a -> a -> Bool) + -> Either Error Waiter.Accept + -> Matcher + +newtype Matchers = Matchers + { unMatchers :: [Matcher] + } + deriving newtype (Semigroup, Monoid) + +class HasMatchers env where + matchersL :: Lens' env Matchers + +instance HasMatchers Matchers where + matchersL = id + +-- | Add a 'Matcher' for the duration of the block +withMatcher :: (MonadReader env m, HasMatchers env) => Matcher -> m a -> m a +withMatcher = withMatchers . pure + +-- | Add multiple 'Matcher's for the duration of the block +withMatchers :: (MonadReader env m, HasMatchers env) => [Matcher] -> m a -> m a +withMatchers ms = local $ matchersL <>~ Matchers ms + +matchSend + :: forall m env a + . ( MonadIO m + , MonadReader env m + , HasMatchers env + , Typeable a + , Typeable (AWSResponse a) + ) + => a + -> m (Either Error (AWSResponse a)) +matchSend req = throwUnmatched @a =<< firstMatcher go + where + go = \case + SendMatcher matchReq resp -> do + guard . matchReq =<< cast req + cast resp + AwaitMatcher {} -> Nothing + +matchAwait + :: forall m env a + . (MonadIO m, MonadReader env m, HasMatchers env, Typeable a) + => Waiter.Wait a + -> a + -> m (Either Error Waiter.Accept) +matchAwait w req = throwUnmatched @a =<< firstMatcher go + where + go = \case + SendMatcher {} -> Nothing + AwaitMatcher matchReq acc -> do + guard =<< matchReq <$> cast w <*> cast req + cast acc + +firstMatcher + :: (MonadReader env m, HasMatchers env) + => (Matcher -> Maybe a) + -> m (Maybe a) +firstMatcher f = do + matchers <- view matchersL + pure $ listToMaybe $ mapMaybe f $ unMatchers matchers + +newtype UnmatchedRequestError = UnmatchedRequestError + { unmatchedRequestType :: String + } + deriving anyclass (Exception) + +-- Morally-speaking, Show should be reserved for a Haskell-like string +-- representation (derived is best), and displayException is where you make it +-- human-readable. Sadly, too many tools (*cough* hspec) use show instead of +-- displayException, and we want it to look nice there. Sigh. +instance Show UnmatchedRequestError where + show ex = + "Unexpected AWS request made within MockT: " + <> unmatchedRequestType ex + <> "\nUse withMatcher to add a Matcher for this request" + +throwUnmatched :: forall req m a. (MonadIO m, Typeable req) => Maybe a -> m a +throwUnmatched = + maybe + (liftIO $ throwIO $ UnmatchedRequestError $ show $ typeRep $ Proxy @req) + pure diff --git a/library/Control/Monad/AWS/MockT.hs b/library/Control/Monad/AWS/MockT.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS/MockT.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DerivingVia #-} + +-- | Concrete reader monad over 'Matchers' +-- +-- Its 'MonadAWS' instance can be used in tests where you don't have or +-- want your own test-app transformer: +-- +-- @ +-- import "Amazonka.S3" +-- import "Control.Monad.AWS" +-- +-- spec :: Spec +-- spec = do +-- describe "someAction" $ do +-- it "works" $ do +-- let matcher = 'SendMatcher' (const True) -- match all calls +-- $ 'newListBucketsResponse' -- return no buckets +-- & 'listBucketsResponse_buckets' ?~ [] +-- +-- names <- 'runMockT' $ 'withMatcher' matcher $ someAction +-- names `shouldBe` [] +-- +-- someAction :: (MonadIO m, 'MonadAWS') m => m [BucketName] +-- someAction = do +-- resp <- 'send' 'newListBuckets' +-- pure +-- $ maybe [] (map (^. bucket_name)) +-- $ resp ^. listBucketsResponse_buckets +-- @ +module Control.Monad.AWS.MockT + ( MockT + , runMockT + + -- * Setting up 'Matchers' + , Matcher (..) + , withMatcher + , withMatchers + ) where + +import Prelude + +import Control.Monad.AWS.Class +import Control.Monad.AWS.Matchers +import Control.Monad.AWS.ViaMock +import Control.Monad.IO.Unlift +import Control.Monad.Reader + +newtype MockT m a = MockT + { unMockT :: ReaderT Matchers m a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader Matchers + ) + deriving (MonadAWS) via (MockAWS (MockT m)) + +runMockT :: MockT m a -> m a +runMockT f = runReaderT (unMockT f) mempty diff --git a/library/Control/Monad/AWS/ViaMock.hs b/library/Control/Monad/AWS/ViaMock.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS/ViaMock.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | @DerivingVia@ machinery for mocking AWS interactions in tests +-- +-- This module assumes your specs run in a custom transformer that can provide a +-- reader environment. If you define 'HasMatchers' for that environment, you can +-- then derive 'MonadAWS' for this transformer via 'MockAWS'. +-- +-- For a more explicit alternative, see "Control.Monad.AWS.MockT". +-- +-- === Example: +-- +-- Assuming you have some implementation you wanted to test: +-- +-- @ +-- getBucketsByPrefix :: (MonadIO m, MonadAWS) m => Text -> m [Bucket] +-- getBucketsByPrefix p = do +-- resp <- send newListBuckets +-- pure +-- $ maybe [] (filter matchesPrefix) +-- $ resp ^. listBucketsResponse_buckets +-- where +-- matchesPrefix b = p `T.isPrefixOf` toText (b ^. bucket_name) +-- @ +-- +-- And assuming you've set up your example monad with 'MonadAWS' via 'MockAWS', +-- you can now test it without talking to AWS: +-- +-- @ +-- describe "getBucketsByPrefix" $ do +-- it "works" $ do +-- now <- getCurrentTime +-- +-- let +-- bucketA = newBucket now "a-bucket" +-- bucketB = newBucket now "b-bucket" +-- bucketC = newBucket now "c-bucket" +-- buckets = [bucketA, bucketB, bucketC] +-- matcher = +-- SendMatcher (== newListBuckets) +-- $ Right +-- $ newListBucketsResponse 200 +-- & listBucketsResponse_buckets ?~ buckets +-- +-- withMatcher matcher $ do +-- buckets <- getBucketsByPrefix "b-" +-- buckets `shouldBe` [bucketB] +-- @ +module Control.Monad.AWS.ViaMock + ( Matchers + , HasMatchers (..) + , Matcher (..) + , withMatcher + , withMatchers + , MockAWS (..) + ) where + +import Prelude + +import Control.Monad.AWS.Class +import Control.Monad.AWS.Matchers +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader (..)) + +newtype MockAWS m a = MockAWS + { unMockAWS :: m a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader env + ) + +instance (MonadIO m, MonadReader env m, HasMatchers env) => MonadAWS (MockAWS m) where + sendEither = matchSend + awaitEither = matchAwait diff --git a/library/Control/Monad/AWS/ViaReader.hs b/library/Control/Monad/AWS/ViaReader.hs new file mode 100644 --- /dev/null +++ b/library/Control/Monad/AWS/ViaReader.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | @DerivingVia@ machinery for adding Amazonka functionality to a reader-like +-- transformer +-- +-- This is useful when you have a /ReaderT-IO/-like stack implemented with an +-- @AppT@ wrapper to which you will add the 'MonadAWS' instance: +-- +-- @ +-- newtype AppT m a = AppT +-- -- ... +-- deriving MonadAWS via (ReaderAWS (AppT m)) +-- @ +-- +-- Complete example: +-- +-- @ +-- {-# LANGUAGE DerivingVia #-} +-- +-- module Main (main) where +-- +-- import qualified "Amazonka" +-- import "Control.Lens" +-- import "Control.Monad.AWS" +-- import "Control.Monad.AWS.ViaReader" +-- import "Control.Monad.Reader" +-- import "Control.Monad.Trans.Resource" +-- +-- data App = App +-- { -- ... +-- , appAWS :: 'Amazonka.Env' +-- } +-- +-- instance HasEnv App where +-- envL = lens appAWS $ \x y -> x { appAWS = y } +-- +-- newtype AppT m a = AppT +-- { unAppT :: ReaderT App (ResourceT m) a +-- } +-- deriving newtype +-- ( Functor +-- , Applicative +-- , Monad +-- , MonadIO +-- , MonadUnliftIO +-- , MonadResource +-- , MonadReader App +-- ) +-- deriving 'MonadAWS' via ('ReaderAWS' (AppT m)) +-- +-- runAppT :: MonadUnliftIO m => AppT m a -> App -> m a +-- runAppT f app = runResourceT $ runReaderT (unAppT f) app +-- +-- main :: IO () +-- main = do +-- app <- undefined +-- runAppT someAction app +-- +-- someAction :: (MonadIO m, 'MonadAWS' m) => m () +-- someAction = do +-- resp <- 'send' 'newListBuckets' +-- liftIO $ print resp +-- @ +module Control.Monad.AWS.ViaReader + ( Env + , HasEnv (..) + , ReaderAWS (..) + ) where + +import Prelude + +import Amazonka.Env +import qualified Amazonka.Send as Amazonka +import Control.Lens (Lens', view) +import Control.Monad.AWS.Class +import Control.Monad.Reader +import Control.Monad.Trans.Resource (MonadResource) + +class HasEnv env where + envL :: Lens' env Env + +instance HasEnv Env where + envL = id + +newtype ReaderAWS m a = ReaderAWS + { unReaderAWS :: m a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadResource + , MonadReader env + ) + +instance (MonadResource m, MonadReader env m, HasEnv env) => MonadAWS (ReaderAWS m) where + sendEither req = do + env <- view envL + Amazonka.sendEither env req + + awaitEither w a = do + env <- view envL + Amazonka.awaitEither env w a diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,142 @@ +name: amazonka-mtl +version: 0.1.0.0 +maintainer: Freckle Education +category: Utils +github: freckle/amazonka-mtl +synopsis: MTL-style type-class and deriving-via newtypes for Amazonka +description: | + This package allows incorporation of AWS actions into any MTL-style function, + + > import Amazonka.Data.Text (ToText(..)) + > import Amazonka.S3.ListObjects + > import Amazonka.S3.Types.Object + > import Blammo.Logging + > import Conduit + > import Control.Lens hiding ((.=)) + > import Control.Monad.AWS as AWS + > + > someAction + > :: ( MonadIO m + > , MonadLogger m + > , MonadAWS m + > , MonadReader env m + > , HasSettings env + > ) + > => m () + > someAction = do + > Settings {..} <- view settingsL + > + > keys <- + > runConduit + > $ paginate (newListObjects settingsBucketName) + > .| concatMapC (^. listObjectsResponse_contents) + > .| concatC + > .| mapC (^. object_key . to toText) + > .| iterMC (\k -> logDebug $ k :# []) + > .| sinkList + > + > logInfo $ "Bucket contents" :# ["keys" .= keys] + + This package also provides a number of options for execution: + + * Through a concrete transformer: "Control.Monad.AWS.EnvT" + * Through your own reader env and deriving-via: "Control.Monad.AWS.ViaReader" + + This package also provides mechanisms for mocking AWS in tests: + + * Through a concrete transformer: "Control.Monad.AWS.MockT" + * Through your own reader env and deriving-via: "Control.Monad.AWS.ViaMock" + + Please see individual module documentation for all the details. + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +ghc-options: + - -Weverything + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-local-signatures + - -Wno-monomorphism-restriction + - -Wno-unsafe + - -Wno-safe + +when: + - condition: "impl(ghc >= 9.2)" + ghc-options: + - -Wno-missing-kind-signatures + - condition: "impl(ghc >= 8.10)" + ghc-options: + - -Wno-missing-safe-haskell-mode + - -Wno-prepositive-qualified-module + +dependencies: + - base < 5 + +default-extensions: + - BangPatterns + - DataKinds + - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - FlexibleContexts + - FlexibleInstances + - GADTs + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NoImplicitPrelude + - NoMonomorphismRestriction + - OverloadedStrings + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TypeApplications + - TypeFamilies + +library: + source-dirs: library + dependencies: + - amazonka + - amazonka-core + - conduit + - lens + - mtl + - resourcet + - unliftio-core + +tests: + spec: + main: Spec.hs + source-dirs: tests + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + dependencies: + - amazonka-core + - amazonka-mtl + - amazonka-s3 + - hspec + - lens + - text + - time + + readme: + main: README.lhs + ghc-options: -pgmL markdown-unlit + dependencies: + - Blammo + - amazonka-core + - amazonka-mtl + - amazonka-s3 + - conduit + - lens + - markdown-unlit + - mtl diff --git a/tests/Control/Monad/AWSSpec.hs b/tests/Control/Monad/AWSSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Control/Monad/AWSSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DerivingVia #-} + +module Control.Monad.AWSSpec + ( spec + ) where + +import Prelude + +import Amazonka.Data.Text (ToText (..)) +import Amazonka.S3.ListBuckets +import Amazonka.S3.Types.Bucket +import Control.Exception (Exception (..), try) +import Control.Lens ((&), (?~), (^.)) +import Control.Monad.AWS +import Control.Monad.AWS.Matchers +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Test.Hspec + +listBucketsMatching :: (MonadIO m, MonadAWS m) => Text -> m [Bucket] +listBucketsMatching p = do + resp <- send newListBuckets + pure $ maybe [] (filter match) $ resp ^. listBucketsResponse_buckets + where + match b = p `T.isPrefixOf` toText (b ^. bucket_name) + +spec :: Spec +spec = do + describe "MockT" $ do + it "can mock send" $ do + now <- getCurrentTime + + let + bucketA = newBucket now "a-bucket" + bucketB = newBucket now "b-bucket" + bucketC = newBucket now "c-bucket" + buckets = [bucketA, bucketB, bucketC] + matcher = + SendMatcher (== newListBuckets) $ + Right $ + newListBucketsResponse 200 & listBucketsResponse_buckets ?~ buckets + + result <- + runMockT $ withMatcher matcher $ listBucketsMatching "b-" + + result `shouldBe` [bucketB] + + it "reports useful failures on un-matched requests" $ do + result <- try @UnmatchedRequestError $ runMockT (listBucketsMatching "b-") + + case result of + Left ex -> + displayException ex + `shouldBe` mconcat + [ "Unexpected AWS request made within MockT: ListBuckets\n" + , "Use withMatcher to add a Matcher for this request" + ] + Right resp -> + expectationFailure $ + "UnmatchedRequestError expected, but got response: " + <> show resp diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-}