diff options
Diffstat (limited to 'hsm-log')
| -rw-r--r-- | hsm-log/Hsm/Log.hs | 120 | ||||
| -rw-r--r-- | hsm-log/Hsm/Log/Options.hs | 76 | ||||
| -rw-r--r-- | hsm-log/hsm-log.cabal | 25 |
3 files changed, 221 insertions, 0 deletions
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs new file mode 100644 index 0000000..99e5b7c --- /dev/null +++ b/hsm-log/Hsm/Log.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Hsm.Log + ( Severity (Attention, Info, Trace) + , Log + , getLevel + , logMsg + , makeLoggerIO + , LoggerOptionPrefix + , runLog + , runLogOpt + , runLogs + , runLogsOpt + ) +where + +import Control.Monad (when) +import Data.Function (applyWhen) +import Data.List (intercalate) +import Data.Proxy (Proxy (Proxy)) +import Data.Time.Clock (getCurrentTime) +import Data.Time.ISO8601 (formatISO8601Millis) +import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>)) +import Effectful.Dispatch.Static + ( SideEffects (WithSideEffects) + , StaticRep + , evalStaticRep + , getStaticRep + , unEff + , unsafeEff + , unsafeEff_ + ) +import GHC.Conc.Sync (fromThreadId, myThreadId) +import GHC.Records (HasField, getField) +import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal) +import String.ANSI (blue, green, red, white) + +data Severity + = Attention + | Info + | Trace + deriving (Enum, Eq, Ord, Read, Show) + +coloredShow :: Severity -> String +coloredShow Attention = red "ATTENTION" +coloredShow Info = green "INFO" +coloredShow Trace = blue "TRACE" + +data Log (d :: Symbol) (a :: * -> *) (b :: *) + +type instance DispatchOf (Log d) = Static WithSideEffects + +newtype instance StaticRep (Log d) + = Log Severity + +getLevel :: Log d :> es => Eff es Severity +getLevel = getStaticRep >>= \(Log level) -> return level + +logMsg + :: forall d es + . (KnownSymbol d, Log d :> es) + => Severity + -> String + -> Eff es () +logMsg severity message = do + level <- getLevel + when (severity <= level) . unsafeEff_ $ do + time <- formatISO8601Millis <$> getCurrentTime + domainAndThreadId <- myThreadId >>= \tid -> return . white $ symbolVal (Proxy @d) <> ":" <> show (fromThreadId tid) + putStrLn $ + unwords + [ time + , domainAndThreadId + , coloredShow severity + , applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message + ] + +makeLoggerIO + :: forall d es + . (KnownSymbol d, Log d :> es) + => Eff es (Severity -> String -> IO ()) +makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env + +type LoggerOptionPrefix = "logLevel_" + +runLog + :: forall d es a + . IOE :> es + => Severity + -> Eff (Log d : es) a + -> Eff es a +runLog = evalStaticRep . Log + +runLogOpt + :: forall d f o es a + . (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es) + => o + -> Eff (Log d : es) a + -> Eff es a +runLogOpt = runLog . getField @f + +class Logs (o :: *) (ds :: [Symbol]) (es :: [Effect]) where + type Insert ds es :: [Effect] + runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a + runLogsOpt :: o -> Eff (Insert ds es) a -> Eff es a + +instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where + type Insert '[] es = es + runLogs = const id + runLogsOpt = const id + +instance + (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, Logs o ds es) + => Logs (o :: *) (d : ds :: [Symbol]) (es :: [Effect]) + where + type Insert (d : ds) es = Log d : Insert ds es + runLogs level = runLogs @o @ds level . runLog @d level + runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs new file mode 100644 index 0000000..0e00b32 --- /dev/null +++ b/hsm-log/Hsm/Log/Options.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Hsm.Log.Options + ( makeLoggerOptionParser + ) +where + +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeLits (symbolVal) +import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals) +import Hsm.Log (LoggerOptionPrefix, Severity) +import Language.Haskell.TH + ( Bang (Bang) + , Body (NormalB) + , Clause (Clause) + , Con (RecC) + , Dec (DataD, FunD, SigD) + , Exp (AppE, ConE, LitE, ParensE, UInfixE, VarE) + , Lit (StringL) + , Name + , Q + , SourceStrictness (NoSourceStrictness) + , SourceUnpackedness (NoSourceUnpackedness) + , Type (AppT, ConT) + , mkName + ) +import Options.Applicative (Parser, auto, help, long, metavar, option, showDefault, value) + +-- Generates an optparse-applicative parser for multiple logger severity levels +-- +-- Creates a record type with configurable log levels and a corresponding parser +-- that accepts command-line arguments like `--log-cam` and `--log-web`. +-- +-- Example: +-- +-- $(makeLoggerOptionParser @'[ "cam", "web"] "Options" "parser" 'Info) +-- +-- Generates: +-- - Record: `Options { logLevel_cam :: Severity, logLevel_web :: Severity }` +-- - Parser: `parser :: Parser Options` with default values set to `Info` +makeLoggerOptionParser + :: forall ls + . KnownSymbols ls + => String + -> String + -> Name + -> Q [Dec] +makeLoggerOptionParser dataNameString parserNameString defaultSeverity = + return + [ DataD [] dataName [] Nothing [RecC dataName $ field <$> loggers] [] + , SigD parserName $ ConT ''Parser `AppT` ConT dataName + , FunD parserName [Clause [] (NormalB $ foldl parserApply parserBase loggers) []] + ] + where + loggers = symbolVals @ls + -- Record + dataName = mkName dataNameString + fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix + fieldName logger = mkName $ fieldPrefix <> logger + fieldBang = Bang NoSourceUnpackedness NoSourceStrictness + fieldType = ConT ''Severity + field logger = (fieldName logger, fieldBang, fieldType) + -- Parser + parserName = mkName parserNameString + parserBase = VarE 'pure `AppE` ConE dataName + parserConfigApply expr = UInfixE expr $ VarE '(<>) + parserOptionLong logger = VarE 'long `AppE` LitE (StringL $ "log-" <> logger) + parserOptionHelp logger = VarE 'help `AppE` LitE (StringL $ "Sets log level for logger " <> logger) + parserOptionShowDefault = VarE 'showDefault + parserOptionValue = VarE 'value `AppE` ConE defaultSeverity + parserOptionMetavar = VarE 'metavar `AppE` LitE (StringL "LEVEL") + parserOptions logger = [parserOptionLong logger, parserOptionHelp logger, parserOptionShowDefault, parserOptionValue, parserOptionMetavar] + parserApply expr logger = + UInfixE expr (VarE '(<*>)) $ + VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger) diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal new file mode 100644 index 0000000..f20d201 --- /dev/null +++ b/hsm-log/hsm-log.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> +name: hsm-log +version: 0.1.0.0 + +library + build-depends: + , base + , effectful-core + , effectful-plugin + , generic-data-functions + , iso8601-time + , optparse-applicative + , template-haskell + , text-ansi + , time + + default-language: GHC2024 + exposed-modules: + Hsm.Log + Hsm.Log.Options + + ghc-options: + -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages + -fplugin=Effectful.Plugin |