diff --git a/amazonka/HaskellWorks/Polysemy/Amazonka.hs b/amazonka/HaskellWorks/Polysemy/Amazonka.hs new file mode 100644 --- /dev/null +++ b/amazonka/HaskellWorks/Polysemy/Amazonka.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.Polysemy.Amazonka + ( runReaderAwsEnvDiscover, + sendAws, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Typeable + +import qualified Amazonka as AWS +import HaskellWorks.Prelude +import Polysemy +import Polysemy.Error +import Polysemy.Reader +import qualified System.IO as IO + +runReaderAwsEnvDiscover :: () + => Member (Embed IO) r + => Sem (Reader AWS.Env : r) a + -> Sem r a +runReaderAwsEnvDiscover f = do + logger' <- embed $ AWS.newLogger AWS.Debug IO.stdout + discoveredAwsEnv <- embed $ AWS.newEnv AWS.discover + let awsEnv = discoveredAwsEnv { AWS.logger = logger' } + runReader awsEnv f + +sendAws :: () + => AWS.AWSRequest a + => Member (Embed m) r + => Member (Error AWS.Error) r + => Member (Reader AWS.Env) r + => MonadIO m + => Typeable (AWS.AWSResponse a) + => Typeable a + => a + -> Sem r (AWS.AWSResponse a) +sendAws req = do + envAws <- ask @AWS.Env + result <- embed $ liftIO $ runResourceT $ AWS.sendEither envAws req + fromEither result diff --git a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Property.hs b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Property.hs --- a/hedgehog/HaskellWorks/Polysemy/Hedgehog/Property.hs +++ b/hedgehog/HaskellWorks/Polysemy/Hedgehog/Property.hs @@ -32,16 +32,16 @@ , Final (H.PropertyT IO) ] () -> H.Property -propertyOnce f = f - & interpretLogDataLog - & setLogLevel (Just Info) - & interpretDataLogHedgehog formatLogEntry getLogEntryCallStack - & interpretDataLogHedgehog id (const GHC.callStack) - & interpretTimeGhc - & hedgehogToPropertyFinal - & runEmbedded liftIO - & embedToFinal @(H.PropertyT IO) - & runResource - & runFinal - & H.property - & H.withTests 1 +propertyOnce f = + f & interpretLogDataLog + & setLogLevel (Just Info) + & interpretDataLogHedgehog formatLogEntry getLogEntryCallStack + & interpretDataLogHedgehog id (const GHC.callStack) + & interpretTimeGhc + & hedgehogToPropertyFinal + & runEmbedded liftIO + & embedToFinal @(H.PropertyT IO) + & runResource + & runFinal + & H.property + & H.withTests 1 diff --git a/hw-polysemy.cabal b/hw-polysemy.cabal --- a/hw-polysemy.cabal +++ b/hw-polysemy.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: hw-polysemy -version: 0.2.11.1 +version: 0.2.12.0 synopsis: Opinionated polysemy library description: Opinionated polysemy library. license: Apache-2.0 @@ -22,6 +22,8 @@ common aeson { build-depends: aeson < 2.3 } common aeson-pretty { build-depends: aeson-pretty < 0.9 } common async { build-depends: async < 2.3 } +common amazonka { build-depends: amazonka >= 2 && < 3 } +common amazonka-s3 { build-depends: amazonka-s3 >= 2 && < 3 } common bytestring { build-depends: bytestring < 0.13 } common contravariant { build-depends: contravariant < 1.6 } common Diff { build-depends: Diff < 0.6 } @@ -30,6 +32,7 @@ common filepath { build-depends: filepath < 1.6 } common generic-lens { build-depends: generic-lens < 2.3 } common ghc-prim { build-depends: ghc-prim < 0.12 } +common http-conduit { build-depends: http-conduit >= 2.3 && < 2.4 } common hedgehog { build-depends: hedgehog < 1.5 } common network { build-depends: network < 3.3 } common lens { build-depends: lens < 5.4 } @@ -43,9 +46,11 @@ common resourcet { build-depends: resourcet < 1.4 } common stm { build-depends: stm < 2.6 } common tasty { build-depends: tasty < 1.6 } +common tasty-discover { build-depends: tasty-discover < 6 } common tasty-hedgehog { build-depends: tasty-hedgehog < 1.5 } common temporary { build-depends: temporary < 1.4 } common text { build-depends: text < 3 } +common testcontainers { build-depends: testcontainers < 0.6 } common time { build-depends: time < 2 } common transformers { build-depends: transformers < 0.7 } common unliftio { build-depends: unliftio < 0.3 } @@ -55,9 +60,11 @@ if os(windows) build-depends: Win32 >= 2.5.4.1 -common hw-polysemy { build-depends: hw-polysemy } -common hw-polysemy-core { build-depends: hw-polysemy:core } -common hw-polysemy-hedgehog { build-depends: hw-polysemy:hedgehog } +common hw-polysemy { build-depends: hw-polysemy } +common hw-polysemy-amazonka { build-depends: hw-polysemy:amazonka } +common hw-polysemy-core { build-depends: hw-polysemy:core } +common hw-polysemy-hedgehog { build-depends: hw-polysemy:hedgehog } +common hw-polysemy-testcontainers-localstack { build-depends: hw-polysemy:testcontainers-localstack } flag werror description: Enable -Werror @@ -201,6 +208,38 @@ hs-source-dirs: hedgehog default-language: Haskell2010 +library amazonka + import: base, project-config, + amazonka, + hw-polysemy-core, + resourcet, + visibility: public + exposed-modules: HaskellWorks.Polysemy.Amazonka + hs-source-dirs: amazonka + default-language: Haskell2010 + +library testcontainers-localstack + import: base, project-config, + amazonka, + bytestring, + generic-lens, + http-conduit, + hw-polysemy-amazonka, + hw-polysemy-core, + hw-polysemy-hedgehog, + lens, + resourcet, + resourcet, + testcontainers, + text, + time, + visibility: public + exposed-modules: HaskellWorks.Polysemy.Amazonka.LocalStack + HaskellWorks.TestContainers.LocalStack + HaskellWorks.TestContainers.LocalStack.Types + hs-source-dirs: testcontainers-localstack + default-language: Haskell2010 + library import: base, project-config, hw-polysemy-core, @@ -249,12 +288,21 @@ test-suite hw-polysemy-test import: base, project-config, + amazonka, + amazonka-s3, filepath, + generic-lens, + hw-polysemy-amazonka, + hw-polysemy-core, + hw-polysemy-testcontainers-localstack, hw-polysemy, - polysemy, + lens, polysemy-log, + polysemy, + tasty-discover, tasty-hedgehog, tasty, + testcontainers, text, default-language: Haskell2010 type: exitcode-stdio-1.0 @@ -262,4 +310,6 @@ hs-source-dirs: test main-is: Main.hs other-modules: HaskellWorks.Polysemy.HedgehogSpec + HaskellWorks.Polysemy.TestContainers.LocalStackSpec + Test.Polysemy.Env ghc-options: -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T diff --git a/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs b/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +{- HLINT ignore "Use let" -} + +module HaskellWorks.Polysemy.TestContainers.LocalStackSpec + ( tasty_local_stack + ) where + +import Prelude + +import HaskellWorks.TestContainers.LocalStack +import Test.Polysemy.Env +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Hedgehog as H + +import qualified Amazonka.S3 as AWS +import HaskellWorks.Polysemy.Amazonka +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Prelude +import Polysemy +import qualified TestContainers.Tasty as TC + +{- HLINT ignore "Use camelCase" -} + +tasty_local_stack :: Tasty.TestTree +tasty_local_stack = + TC.withContainers setupContainers $ \start -> + H.testProperty "Local stack test" $ propertyOnce $ runLocalTestEnv start $ do + ep <- embed start + jotShow_ ep + listBucketsReq <- pure AWS.newListBuckets + + listBucketResp <- sendAws listBucketsReq + & trapFail + + jotShow_ listBucketResp diff --git a/test/Test/Polysemy/Env.hs b/test/Test/Polysemy/Env.hs new file mode 100644 --- /dev/null +++ b/test/Test/Polysemy/Env.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{- HLINT ignore "Use let" -} + +module Test.Polysemy.Env + ( EnvironmentVariableMissing(..) + , runLocalTestEnv + , runTestEnv + , runReaderFromEnvOrFail + ) where + +import qualified Amazonka as AWS +import HaskellWorks.Polysemy.Amazonka +import HaskellWorks.Polysemy.Amazonka.LocalStack +import HaskellWorks.Polysemy.Error +import HaskellWorks.Polysemy.Hedgehog +import HaskellWorks.Polysemy.System.Environment +import HaskellWorks.Prelude +import HaskellWorks.TestContainers.LocalStack +import Polysemy +import Polysemy.Error +import Polysemy.Reader + +newtype EnvironmentVariableMissing = + EnvironmentVariableMissing String + deriving (Show, Eq) + +runTestEnv :: () + => HasCallStack + => Member (Embed IO) r + => Member Hedgehog r + => Sem + ( Reader AWS.Env + : r) + a + -> Sem r a +runTestEnv f = + withFrozenCallStack $ f + & runReaderAwsEnvDiscover + +runLocalTestEnv :: () + => HasCallStack + => Member (Embed IO) r + => Member Hedgehog r + => IO LocalStackEndpoint + -> Sem + ( Reader AWS.Env + : r) + a + -> Sem r a +runLocalTestEnv mk f = + withFrozenCallStack $ f + & runReaderLocalAwsEnvDiscover mk + +runReaderFromEnvOrFail :: forall i r a. () + => Member (Embed IO) r + => Member Hedgehog r + => (String -> i) + -> String + -> Sem (Reader i ': r) a + -> Sem r a +runReaderFromEnvOrFail f envVar action = do + env <- lookupEnv envVar + & onNothingM (throw (EnvironmentVariableMissing envVar) & trapFail) + + runReader (f env) action diff --git a/testcontainers-localstack/HaskellWorks/Polysemy/Amazonka/LocalStack.hs b/testcontainers-localstack/HaskellWorks/Polysemy/Amazonka/LocalStack.hs new file mode 100644 --- /dev/null +++ b/testcontainers-localstack/HaskellWorks/Polysemy/Amazonka/LocalStack.hs @@ -0,0 +1,36 @@ +{- HLINT ignore "Use let" -} + +module HaskellWorks.Polysemy.Amazonka.LocalStack + ( runReaderLocalAwsEnvDiscover + ) where + +import qualified Amazonka as AWS +import qualified Amazonka.Auth as AWS +import Control.Lens ((%~), (.~), (^.)) +import Data.Generics.Product.Any +import HaskellWorks.Prelude +import HaskellWorks.TestContainers.LocalStack +import Polysemy +import Polysemy.Reader +import qualified System.IO as IO + +runReaderLocalAwsEnvDiscover :: () + => Member (Embed IO) r + => IO LocalStackEndpoint + -> Sem (Reader AWS.Env : r) a + -> Sem r a +runReaderLocalAwsEnvDiscover mk f = do + ep <- embed mk + + logger' <- embed $ AWS.newLogger AWS.Debug IO.stdout + + let creds = AWS.fromKeys (AWS.AccessKey "test") (AWS.SecretKey "test") + + credEnv <- embed $ AWS.newEnv (AWS.runCredentialChain [pure . creds]) + + awsEnv <- pure $ + credEnv + & the @"logger" .~ logger' + & the @"overrides" %~ (. AWS.setEndpoint False "localhost" (ep ^. the @"port")) + + runReader awsEnv f diff --git a/testcontainers-localstack/HaskellWorks/TestContainers/LocalStack.hs b/testcontainers-localstack/HaskellWorks/TestContainers/LocalStack.hs new file mode 100644 --- /dev/null +++ b/testcontainers-localstack/HaskellWorks/TestContainers/LocalStack.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +{- HLINT ignore "Use camelCase" -} + +module HaskellWorks.TestContainers.LocalStack + ( LocalStackEndpoint(..) + , setupContainers + , waitForLocalStack + ) where + +import Prelude + +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import Control.Monad (when) +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as LBS +import Data.Function +import qualified Data.Text as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import HaskellWorks.TestContainers.LocalStack.Types (LocalStackEndpoint (LocalStackEndpoint)) +import qualified HaskellWorks.TestContainers.LocalStack.Types as Z +import Network.HTTP.Conduit (HttpException, + simpleHttp) +import qualified System.Environment as IO +import qualified TestContainers.Tasty as TC + +-- | Sets up and runs the containers required for this test suite. +setupContainers :: TC.MonadDocker m => m LocalStackEndpoint +setupContainers = do + authToken <- liftIO $ IO.lookupEnv "LOCALSTACK_AUTH_TOKEN" + -- Launch the container based on the postgres image. + localstackContainer <- TC.run $ TC.containerRequest (TC.fromTag "localstack/localstack-pro:3.1.0") + & TC.setEnv [("LOCALSTACK_AUTH_TOKEN", maybe "" T.pack authToken)] + -- Expose the port 4566 from within the container. The respective port + -- on the host machine can be looked up using `containerPort` (see below). + & TC.setExpose + ( mconcat + [ [ 4566 ] + , fmap fromInteger [4510 .. 4559] + ] + ) + -- Wait until the container is ready to accept requests. `run` blocks until + -- readiness can be established. + & TC.setWaitingFor (TC.waitUntilMappedPortReachable 4566) + + -- Look up the corresponding port on the host machine for the exposed port 4566. + let localStackPort = TC.containerPort localstackContainer 4566 + + liftIO $ waitForLocalStack "localhost" localStackPort 8 + + pure $ LocalStackEndpoint + { Z.host = "0.0.0.0" + , Z.port = localStackPort + } + +waitForLocalStack :: String -> Int -> Int -> IO () +waitForLocalStack host port timeout = do + startTime <- getPOSIXTime + let url = "http://" ++ host ++ ":" ++ show port + checkLoop startTime url + where + checkLoop startTime url = do + result <- try $ simpleHttp url :: IO (Either HttpException LBS.ByteString) + case result of + Right _ -> putStrLn "LocalStack is ready!" + Left _ -> do + currentTime <- getPOSIXTime + let elapsedTime = currentTime - startTime + when (elapsedTime < fromIntegral timeout) $ do + threadDelay 1000000 -- Wait for 1 second + checkLoop startTime url + when (elapsedTime >= fromIntegral timeout) $ do + putStrLn "Timeout reached. LocalStack is not ready." diff --git a/testcontainers-localstack/HaskellWorks/TestContainers/LocalStack/Types.hs b/testcontainers-localstack/HaskellWorks/TestContainers/LocalStack/Types.hs new file mode 100644 --- /dev/null +++ b/testcontainers-localstack/HaskellWorks/TestContainers/LocalStack/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} + +module HaskellWorks.TestContainers.LocalStack.Types + ( LocalStackEndpoint(..) + ) where + +import HaskellWorks.Prelude + +data LocalStackEndpoint = LocalStackEndpoint + { host :: String + , port :: Int + } deriving (Eq, Show, Generic)