aboutsummaryrefslogtreecommitdiffstats
path: root/lib/G4fClient/LoggingKatip.hs
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2026-02-21 14:18:13 +0100
committertv <tv@krebsco.de>2026-02-21 22:22:17 +0100
commit55d42f1dd83b428aa0f1352bc0ea1402b9c2b811 (patch)
tree81d5e80b385de42a0d1b48d3edd0d2b66d858b2d /lib/G4fClient/LoggingKatip.hs
generate initial commit
Generate haskell-http-client from running g4f v-7.1.4. Server started like this: python -m g4f --port 8080 --debug Code generated like this: openapi-generator-cli generate \ -i http://localhost:8080/openapi.json \ -g haskell-http-client \ --skip-validate-spec \ -o g4f-client \ --additional-properties=cabalPackage=g4f-client,cabalVersion=7.1.4,baseModule=G4fApi
Diffstat (limited to 'lib/G4fClient/LoggingKatip.hs')
-rw-r--r--lib/G4fClient/LoggingKatip.hs117
1 files changed, 117 insertions, 0 deletions
diff --git a/lib/G4fClient/LoggingKatip.hs b/lib/G4fClient/LoggingKatip.hs
new file mode 100644
index 0000000..3d258f7
--- /dev/null
+++ b/lib/G4fClient/LoggingKatip.hs
@@ -0,0 +1,117 @@
+{-
+ FastAPI
+
+ No description provided (generated by Openapi Generator https://github.com/openapitools/openapi-generator)
+
+ OpenAPI Version: 3.1.0
+ FastAPI API version: 0.1.0
+ Generated by OpenAPI Generator (https://openapi-generator.tech)
+-}
+
+{-|
+Module : G4fClient.LoggingKatip
+Katip Logging functions
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module G4fClient.LoggingKatip where
+
+import qualified Control.Exception.Safe as E
+import qualified Control.Monad.IO.Class as P
+import qualified Control.Monad.Trans.Reader as P
+import qualified Data.Text as T
+import qualified Lens.Micro as L
+import qualified System.IO as IO
+
+import Data.Text (Text)
+import GHC.Exts (IsString(..))
+
+import qualified Katip as LG
+
+-- * Type Aliases (for compatibility)
+
+-- | Runs a Katip logging block with the Log environment
+type LogExecWithContext = forall m a. P.MonadIO m =>
+ LogContext -> LogExec m a
+
+-- | A Katip logging block
+type LogExec m a = LG.KatipT m a -> m a
+
+-- | A Katip Log environment
+type LogContext = LG.LogEnv
+
+-- | A Katip Log severity
+type LogLevel = LG.Severity
+
+-- * default logger
+
+-- | the default log environment
+initLogContext :: IO LogContext
+initLogContext = LG.initLogEnv "G4fClient" "dev"
+
+-- | Runs a Katip logging block with the Log environment
+runDefaultLogExecWithContext :: LogExecWithContext
+runDefaultLogExecWithContext = LG.runKatipT
+
+-- * stdout logger
+
+-- | Runs a Katip logging block with the Log environment
+stdoutLoggingExec :: LogExecWithContext
+stdoutLoggingExec = runDefaultLogExecWithContext
+
+-- | A Katip Log environment which targets stdout
+stdoutLoggingContext :: LogContext -> IO LogContext
+stdoutLoggingContext cxt = do
+ handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stdout (LG.permitItem LG.InfoS) LG.V2
+ LG.registerScribe "stdout" handleScribe LG.defaultScribeSettings cxt
+
+-- * stderr logger
+
+-- | Runs a Katip logging block with the Log environment
+stderrLoggingExec :: LogExecWithContext
+stderrLoggingExec = runDefaultLogExecWithContext
+
+-- | A Katip Log environment which targets stderr
+stderrLoggingContext :: LogContext -> IO LogContext
+stderrLoggingContext cxt = do
+ handleScribe <- LG.mkHandleScribe LG.ColorIfTerminal IO.stderr (LG.permitItem LG.InfoS) LG.V2
+ LG.registerScribe "stderr" handleScribe LG.defaultScribeSettings cxt
+
+-- * Null logger
+
+-- | Disables Katip logging
+runNullLogExec :: LogExecWithContext
+runNullLogExec le (LG.KatipT f) = P.runReaderT f (L.set LG.logEnvScribes mempty le)
+
+-- * Log Msg
+
+-- | Log a katip message
+_log :: (Applicative m, LG.Katip m) => Text -> LogLevel -> Text -> m ()
+_log src level msg = do
+ LG.logMsg (fromString $ T.unpack src) level (LG.logStr msg)
+
+-- * Log Exceptions
+
+-- | re-throws exceptions after logging them
+logExceptions
+ :: (LG.Katip m, E.MonadCatch m, Applicative m)
+ => Text -> m a -> m a
+logExceptions src =
+ E.handle
+ (\(e :: E.SomeException) -> do
+ _log src LG.ErrorS ((T.pack . show) e)
+ E.throw e)
+
+-- * Log Level
+
+levelInfo :: LogLevel
+levelInfo = LG.InfoS
+
+levelError :: LogLevel
+levelError = LG.ErrorS
+
+levelDebug :: LogLevel
+levelDebug = LG.DebugS