hw-polysemy 0.2.13.0 → 0.2.14.0
raw patch · 11 files changed
+216/−37 lines, 11 filesdep +binarydep ~polysemy-logdep ~polysemy-timePVP ok
version bump matches the API change (PVP)
Dependencies added: binary
Dependency ranges changed: polysemy-log, polysemy-time
API changes (from Hackage documentation)
Files
- amazonka/HaskellWorks/Polysemy/Amazonka.hs +80/−6
- core/HaskellWorks/Polysemy/Control/Concurrent/QSem.hs +12/−7
- core/HaskellWorks/Polysemy/Control/Concurrent/STM.hs +5/−3
- core/HaskellWorks/Polysemy/Control/Concurrent/STM/TVar.hs +12/−8
- core/HaskellWorks/Polysemy/Log.hs +36/−0
- hedgehog/HaskellWorks/Polysemy/Hedgehog.hs +3/−0
- hedgehog/HaskellWorks/Polysemy/Hedgehog/Jot.hs +32/−0
- hw-polysemy.cabal +9/−1
- test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs +1/−0
- test/Test/Polysemy/Env.hs +26/−4
- testcontainers-localstack/HaskellWorks/TestContainers/LocalStack.hs +0/−8
amazonka/HaskellWorks/Polysemy/Amazonka.hs view
@@ -1,22 +1,47 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} module HaskellWorks.Polysemy.Amazonka- ( runReaderAwsEnvDiscover,+ ( AwsLogEntry(..),+ runReaderAwsEnvDiscover, sendAws,+ interpretDataLogAwsLogEntryToLog,+ interpretDataLogAwsLogEntryToLogWith,+ interpretDataLogAwsLogEntryLocalToLogWith,+ awsLogLevelToSeverity, ) where import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Typeable -import qualified Amazonka as AWS+import qualified Amazonka as AWS+import qualified Control.Concurrent.STM as STM+import Control.Lens+import Data.Binary.Builder (Builder)+import qualified Data.Binary.Builder as B+import Data.Generics.Product.Any+import qualified Data.List as L+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import HaskellWorks.Polysemy.Control.Concurrent.STM.TVar import HaskellWorks.Prelude import Polysemy import Polysemy.Error+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Log+import qualified Polysemy.Log.Effect.DataLog as Log import Polysemy.Reader-import qualified System.IO as IO+import Polysemy.Resource+import qualified System.IO as IO +data AwsLogEntry = AwsLogEntry+ { logLevel :: AWS.LogLevel+ , builder :: Builder+ }+ deriving (Generic, Show, Typeable)+ runReaderAwsEnvDiscover :: () => Member (Embed IO) r => Sem (Reader AWS.Env : r) a@@ -29,15 +54,64 @@ sendAws :: () => AWS.AWSRequest a+ => Member (DataLog AwsLogEntry) r => Member (Embed m) r => Member (Error AWS.Error) r => Member (Reader AWS.Env) r+ => Member Resource 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+ tStack <- newTVarIO @[AwsLogEntry] []+ envAws0 <- ask @AWS.Env++ let logger :: AWS.LogLevel -> Builder -> IO ()+ logger ll b = STM.atomically $ STM.modifyTVar tStack (AwsLogEntry ll b:)++ let envAws1 = envAws0 { AWS.logger = logger }++ (fromEither =<< embed (liftIO $ runResourceT $ AWS.sendEither envAws1 req))+ & do flip finally do+ entries <- L.reverse <$> readTVarIO tStack+ forM_ entries dataLog++interpretDataLogAwsLogEntryToLog :: forall r. ()+ => Member Log r+ => InterpreterFor (DataLog AwsLogEntry) r+interpretDataLogAwsLogEntryToLog =+ interpretDataLogAwsLogEntryToLogWith awsLogLevelToSeverity++interpretDataLogAwsLogEntryToLogWith :: forall r. ()+ => Member Log r+ => (AWS.LogLevel -> Severity)+ -> InterpreterFor (DataLog AwsLogEntry) r+interpretDataLogAwsLogEntryToLogWith mapSeverity+ = interpretDataLogAwsLogEntryLocalToLogWith mapSeverity id++interpretDataLogAwsLogEntryLocalToLogWith :: forall r. ()+ => Member Log r+ => (AWS.LogLevel -> Severity)+ -> (AwsLogEntry -> AwsLogEntry)+ -> InterpreterFor (DataLog AwsLogEntry) r+interpretDataLogAwsLogEntryLocalToLogWith mapSeverity context =+ interpretH \case+ Log.DataLog logEntry -> do+ let severity = mapSeverity (logEntry ^. the @"logLevel")+ let text = LT.toStrict (LT.decodeUtf8 (B.toLazyByteString (logEntry ^. the @"builder")))+ liftT (log severity text)+ Log.Local f ma ->+ raise . interpretDataLogAwsLogEntryLocalToLogWith mapSeverity (f . context) =<< runT ma+{-# inline interpretDataLogAwsLogEntryLocalToLogWith #-}++awsLogLevelToSeverity :: ()+ => AWS.LogLevel+ -> Severity+awsLogLevelToSeverity = \case+ AWS.Trace -> Debug+ AWS.Debug -> Debug+ AWS.Info -> Info+ AWS.Error -> Error+{-# inline awsLogLevelToSeverity #-}
core/HaskellWorks/Polysemy/Control/Concurrent/QSem.hs view
@@ -9,33 +9,38 @@ import Control.Concurrent.QSem (QSem) import qualified Control.Concurrent.QSem as IO+import Control.Monad.IO.Class (MonadIO (..)) import HaskellWorks.Polysemy.Prelude import Polysemy import Polysemy.Resource newQSem :: ()- => Member (Embed IO) r+ => MonadIO m+ => Member (Embed m) r => Int -> Sem r QSem newQSem n = do- embed $ IO.newQSem n+ embed $ liftIO $ IO.newQSem n waitQSem :: ()- => Member (Embed IO) r+ => MonadIO m+ => Member (Embed m) r => QSem -> Sem r () waitQSem sem =- embed $ IO.waitQSem sem+ embed $ liftIO $ IO.waitQSem sem signalQSem :: ()- => Member (Embed IO) r+ => MonadIO m+ => Member (Embed m) r => QSem -> Sem r () signalQSem sem =- embed $ IO.signalQSem sem+ embed $ liftIO $ IO.signalQSem sem bracketQSem :: ()- => Member (Embed IO) r+ => MonadIO m+ => Member (Embed m) r => Member Resource r => QSem -> Sem r a
core/HaskellWorks/Polysemy/Control/Concurrent/STM.hs view
@@ -10,12 +10,14 @@ import Control.Concurrent.STM (STM, TVar) import qualified Control.Concurrent.STM as STM+import Control.Monad.IO.Class (MonadIO (..)) import HaskellWorks.Polysemy.Prelude import Polysemy -atomically :: ()- => Member (Embed IO) r+atomically :: forall a m r. ()+ => MonadIO m+ => Member (Embed m) r => STM a -> Sem r a atomically m =- embed $ STM.atomically m+ embed $ liftIO $ STM.atomically m
core/HaskellWorks/Polysemy/Control/Concurrent/STM/TVar.hs view
@@ -15,26 +15,30 @@ import Control.Concurrent.STM (TVar) import qualified Control.Concurrent.STM as STM+import Control.Monad.IO.Class (MonadIO (..)) import HaskellWorks.Polysemy.Prelude import Polysemy -newTVarIO :: ()- => Member (Embed IO) r+newTVarIO :: forall a m r. ()+ => MonadIO m+ => Member (Embed m) r => a -> Sem r (TVar a) newTVarIO a = do- embed $ STM.newTVarIO a+ embed $ liftIO $ STM.newTVarIO a -readTVarIO :: ()- => Member (Embed IO) r+readTVarIO :: forall a m r. ()+ => MonadIO m+ => Member (Embed m) r => TVar a -> Sem r a readTVarIO tvar = do- embed $ STM.readTVarIO tvar+ embed $ liftIO $ STM.readTVarIO tvar registerDelay :: ()- => Member (Embed IO) r+ => MonadIO m+ => Member (Embed m) r => Int -> Sem r (TVar Bool) registerDelay n = do- embed $ STM.registerDelay n+ embed $ liftIO $ STM.registerDelay n
+ core/HaskellWorks/Polysemy/Log.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- HLINT ignore "Use let" -}++module HaskellWorks.Polysemy.Log+ ( interpretDataLogNoop,+ interpretDataLogLocalNoop,+ ) where++import HaskellWorks.Prelude+import Polysemy+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Log+import qualified Polysemy.Log.Effect.DataLog as Log++interpretDataLogNoop :: forall a r. ()+ => InterpreterFor (DataLog a) r+interpretDataLogNoop =+ interpretDataLogLocalNoop id++interpretDataLogLocalNoop :: forall a r. ()+ => (a -> a)+ -> InterpreterFor (DataLog a) r+interpretDataLogLocalNoop context =+ interpretH \case+ Log.DataLog _ ->+ liftT (pure ())+ Log.Local f ma ->+ raise . interpretDataLogLocalNoop (f . context) =<< runT ma+{-# inline interpretDataLogLocalNoop #-}
hedgehog/HaskellWorks/Polysemy/Hedgehog.hs view
@@ -87,6 +87,9 @@ jotRootInputFile, jotTempFile, + jotShowDataLog,+ jotShowDataLogLocal,+ Property, Workspace(..),
hedgehog/HaskellWorks/Polysemy/Hedgehog/Jot.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-} module HaskellWorks.Polysemy.Hedgehog.Jot ( jotShow,@@ -41,6 +42,9 @@ jotPkgInputFile, jotRootInputFile, jotTempFile,++ jotShowDataLog,+ jotShowDataLogLocal, ) where import Data.Aeson (ToJSON)@@ -65,6 +69,9 @@ import HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog import HaskellWorks.Polysemy.Hedgehog.Workspace.Types import HaskellWorks.Polysemy.String+import Polysemy+import Polysemy.Internal.Tactics (liftT)+import qualified Polysemy.Log.Effect.DataLog as Log -- | Annotate the given string at the context supplied by the callstack. jotWithCallstack :: ()@@ -499,3 +506,28 @@ let relPath = workspace <> "/" <> fp jot_ $ workspace <> "/" <> relPath return relPath++jotShowDataLog :: forall a r. ()+ => HasCallStack+ => Show a+ => Member Hedgehog r+ => InterpreterFor (DataLog a) r+jotShowDataLog =+ withFrozenCallStack $+ jotShowDataLogLocal id+{-# inline jotShowDataLog #-}++jotShowDataLogLocal :: forall a r. ()+ => HasCallStack+ => Show a+ => Member Hedgehog r+ => (a -> a)+ -> InterpreterFor (DataLog a) r+jotShowDataLogLocal context =+ withFrozenCallStack $+ interpretH \case+ Log.DataLog a ->+ liftT (jotShow_ (context a))+ Log.Local f ma ->+ raise . jotShowDataLogLocal (f . context) =<< runT ma+{-# inline jotShowDataLogLocal #-}
hw-polysemy.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: hw-polysemy-version: 0.2.13.0+version: 0.2.14.0 synopsis: Opinionated polysemy library description: Opinionated polysemy library. license: Apache-2.0@@ -24,6 +24,7 @@ common async { build-depends: async < 2.3 } common amazonka { build-depends: amazonka >= 2 && < 3 } common amazonka-s3 { build-depends: amazonka-s3 >= 2 && < 3 }+common binary { build-depends: binary >= 0.8.9 && < 0.9 } common bytestring { build-depends: bytestring < 0.13 } common contravariant { build-depends: contravariant < 1.6 } common Diff { build-depends: Diff < 0.6 }@@ -151,6 +152,7 @@ HaskellWorks.Polysemy.Except HaskellWorks.Polysemy.File HaskellWorks.Polysemy.FilePath+ HaskellWorks.Polysemy.Log HaskellWorks.Polysemy.OS HaskellWorks.Polysemy.Prelude HaskellWorks.Polysemy.Stack@@ -211,8 +213,14 @@ library amazonka import: base, project-config, amazonka,+ binary,+ generic-lens, hw-polysemy-core,+ lens,+ polysemy-log, resourcet,+ text,+ stm, visibility: public exposed-modules: HaskellWorks.Polysemy.Amazonka hs-source-dirs: amazonka
test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs view
@@ -35,6 +35,7 @@ listBucketsReq <- pure AWS.newListBuckets listBucketResp <- sendAws listBucketsReq+ & jotShowDataLog @AwsLogEntry & trapFail jotShow_ listBucketResp
test/Test/Polysemy/Env.hs view
@@ -10,10 +10,13 @@ {- HLINT ignore "Use let" -} module Test.Polysemy.Env- ( EnvironmentVariableMissing(..)- , runLocalTestEnv- , runTestEnv- , runReaderFromEnvOrFail+ ( EnvironmentVariableMissing(..),+ runLocalTestEnv,+ runTestEnv,+ runReaderFromEnvOrFail,++ interpretDataLogNoop,+ interpretDataLogLocalNoop, ) where import qualified Amazonka as AWS@@ -25,6 +28,9 @@ import HaskellWorks.Prelude import Polysemy import Polysemy.Error+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Log+import qualified Polysemy.Log.Effect.DataLog as Log import Polysemy.Reader import qualified TestContainers.Tasty as TC @@ -71,3 +77,19 @@ & onNothingM (throw (EnvironmentVariableMissing envVar) & trapFail) runReader (f env) action++interpretDataLogNoop :: forall a r. ()+ => InterpreterFor (DataLog a) r+interpretDataLogNoop =+ interpretDataLogLocalNoop id++interpretDataLogLocalNoop :: forall a r. ()+ => (a -> a)+ -> InterpreterFor (DataLog a) r+interpretDataLogLocalNoop _ =+ interpretH \case+ Log.DataLog _ ->+ liftT (pure ())+ Log.Local f ma ->+ raise . interpretDataLogLocalNoop f =<< runT ma+{-# inline interpretDataLogLocalNoop #-}
testcontainers-localstack/HaskellWorks/TestContainers/LocalStack.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,17 +17,14 @@ import Control.Exception (try) import Control.Monad (when) import Control.Monad.IO.Class-import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Function import qualified Data.Text as T import Data.Time.Clock.POSIX (getPOSIXTime)-import qualified Data.Yaml as Y import HaskellWorks.TestContainers.LocalStack.Types (LocalStackEndpoint (LocalStackEndpoint)) import Network.HTTP.Conduit (HttpException, simpleHttp) import qualified System.Environment as IO-import qualified System.IO as IO import qualified TestContainers.Monad as TC import qualified TestContainers.Tasty as TC @@ -49,10 +45,6 @@ -- Wait until the container is ready to accept requests. `run` blocks until -- readiness can be established. & TC.setWaitingFor (TC.waitUntilMappedPortReachable 4566)-- json <- liftIO $ TC.runTestContainer TC.defaultDockerConfig $ TC.inspect localstackContainer-- liftIO $ BS.hPut IO.stdout $ "Local stack container: " <> Y.encode json -- Look up the corresponding port on the host machine for the exposed port 4566. let localStackPort = TC.containerPort localstackContainer 4566