hw-polysemy 0.2.14.5 → 0.2.14.6
raw patch · 4 files changed
+52/−11 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- amazonka/HaskellWorks/Polysemy/Amazonka.hs +21/−9
- core/HaskellWorks/Polysemy/Log.hs +28/−0
- hw-polysemy.cabal +2/−1
- test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs +1/−1
amazonka/HaskellWorks/Polysemy/Amazonka.hs view
@@ -25,9 +25,13 @@ import qualified Data.Binary.Builder as B import Data.Generics.Product.Any import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT+import qualified GHC.Stack as GHC import HaskellWorks.Polysemy.Control.Concurrent.STM.TVar+import HaskellWorks.Polysemy.Log import HaskellWorks.Polysemy.System.Environment import HaskellWorks.Prelude import Polysemy@@ -37,14 +41,14 @@ import qualified Polysemy.Log.Effect.DataLog as Log import Polysemy.Reader import Polysemy.Resource+import Polysemy.Time (GhcTime) import qualified System.IO as IO-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Text.Read+import Text.Read data AwsLogEntry = AwsLogEntry- { logLevel :: AWS.LogLevel- , builder :: Builder+ { callStack :: CallStack+ , logLevel :: AWS.LogLevel+ , builder :: Builder } deriving (Generic, Show, Typeable) @@ -57,7 +61,7 @@ Just (host, portString) -> case readMaybe portString of Just port -> (. AWS.setEndpoint False (T.encodeUtf8 (T.pack host)) port)- Nothing -> id+ Nothing -> id Nothing -> id runReaderAwsEnvDiscover :: ()@@ -82,6 +86,7 @@ runReader awsEnv f sendAws :: ()+ => HasCallStack => AWS.AWSRequest a => Member (DataLog AwsLogEntry) r => Member (Embed m) r@@ -93,12 +98,12 @@ => Typeable a => a -> Sem r (AWS.AWSResponse a)-sendAws req = do+sendAws req = GHC.withFrozenCallStack $ do tStack <- newTVarIO @[AwsLogEntry] [] envAws0 <- ask @AWS.Env let logger :: AWS.LogLevel -> Builder -> IO ()- logger ll b = STM.atomically $ STM.modifyTVar tStack (AwsLogEntry ll b:)+ logger ll b = STM.atomically $ STM.modifyTVar tStack (AwsLogEntry GHC.callStack ll b:) let envAws1 = envAws0 { AWS.logger = logger } @@ -108,12 +113,16 @@ forM_ entries dataLog interpretDataLogAwsLogEntryToLog :: forall r. ()+ => Member (DataLog (LogEntry LogMessage)) r+ => Member GhcTime r => Member Log r => InterpreterFor (DataLog AwsLogEntry) r interpretDataLogAwsLogEntryToLog = interpretDataLogAwsLogEntryToLogWith awsLogLevelToSeverity interpretDataLogAwsLogEntryToLogWith :: forall r. ()+ => Member (DataLog (LogEntry LogMessage)) r+ => Member GhcTime r => Member Log r => (AWS.LogLevel -> Severity) -> InterpreterFor (DataLog AwsLogEntry) r@@ -121,6 +130,8 @@ = interpretDataLogAwsLogEntryLocalToLogWith mapSeverity id interpretDataLogAwsLogEntryLocalToLogWith :: forall r. ()+ => Member (DataLog (LogEntry LogMessage)) r+ => Member GhcTime r => Member Log r => (AWS.LogLevel -> Severity) -> (AwsLogEntry -> AwsLogEntry)@@ -128,9 +139,10 @@ interpretDataLogAwsLogEntryLocalToLogWith mapSeverity context = interpretH \case Log.DataLog logEntry -> do+ let cs = logEntry ^. the @"callStack" let severity = mapSeverity (logEntry ^. the @"logLevel") let text = LT.toStrict (LT.decodeUtf8 (B.toLazyByteString (logEntry ^. the @"builder")))- liftT (log severity text)+ liftT (logCs cs severity text) Log.Local f ma -> raise . interpretDataLogAwsLogEntryLocalToLogWith mapSeverity (f . context) =<< runT ma {-# inline interpretDataLogAwsLogEntryLocalToLogWith #-}
core/HaskellWorks/Polysemy/Log.hs view
@@ -14,18 +14,24 @@ interpretDataLogToJsonStdout, logEntryToJson, logMessageToJson,++ annotateCs,+ logCs, ) where import Data.Aeson import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Encoding as T+import Data.Time import qualified GHC.Stack as GHC import HaskellWorks.Prelude import Polysemy import Polysemy.Internal.Tactics (liftT) import Polysemy.Log import qualified Polysemy.Log.Effect.DataLog as Log+import Polysemy.Time+import qualified Polysemy.Time as Time interpretDataLogNoop :: forall a r. () => InterpreterFor (DataLog a) r@@ -50,6 +56,28 @@ -> Sem r a interpretDataLogToJsonStdout toJson = interpretDataLogStdoutWith (T.decodeUtf8 . LBS.toStrict . J.encode . toJson)++-- | Log a datalog message with the given severity and provided callstack.+annotateCs :: ()+ => Member GhcTime r+ => CallStack+ -> a+ -> Sem r (LogEntry a)+annotateCs cs msg = do+ time <- Time.now @UTCTime @Day+ pure (LogEntry msg time cs)++-- | Log a text message with the given severity and provided callstack.+logCs :: ()+ => Members [Logger, GhcTime] r+ => CallStack+ -> Severity+ -> Text+ -> Sem r ()+logCs cs severity message =+ withFrozenCallStack do+ send . DataLog =<< annotateCs cs (LogMessage severity message)+{-# inline logCs #-} logEntryToJson :: (a -> Value) -> LogEntry a -> Value logEntryToJson aToJson (LogEntry value time callstack) =
hw-polysemy.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: hw-polysemy-version: 0.2.14.5+version: 0.2.14.6 synopsis: Opinionated polysemy library description: Opinionated polysemy library. license: Apache-2.0@@ -219,6 +219,7 @@ hw-polysemy-core, lens, polysemy-log,+ polysemy-time, resourcet, text, stm,
test/HaskellWorks/Polysemy/TestContainers/LocalStackSpec.hs view
@@ -26,7 +26,7 @@ tasty_local_stack :: Tasty.TestTree tasty_local_stack =- TC.withContainers setupContainers $ \getContainer ->+ TC.withContainers (setupContainers' "localstack/localstack-pro:3.7.2") $ \getContainer -> H.testProperty "Local stack test" $ propertyOnce $ runLocalTestEnv getContainer $ do container <- embed getContainer ep <- getLocalStackEndpoint container