Logging primitives

libatrade.cabal

@@ -1,5 +1,5 @@
 name:                libatrade
-version:             0.10.0.0
+version:             0.11.0.0
 synopsis:            ATrade infrastructure core library
 description:         Please see README.md
 homepage:            https://github.com/asakul/libatrade.git
@@ -18,6 +18,7 @@ library
   ghc-options:         -Wincomplete-patterns
   exposed-modules:     ATrade.Types
                      , ATrade.Price
+                     , ATrade.Logging
                      , ATrade.QuoteSource.Client
                      , ATrade.QuoteSource.Server
                      , ATrade.Broker.Backend
@@ -57,6 +58,8 @@ library
                      , utf8-string
                      , zeromq4-haskell
                      , zeromq4-haskell-zap
+                     , co-log
+                     , ansi-terminal
   default-language:    Haskell2010
 
 

src/ATrade/Logging.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module ATrade.Logging
+  (
+    Severity(..),
+    Message(..),
+    fmtMessage,
+    showSeverity,
+    log,
+    logTrace,
+    logDebug,
+    logInfo,
+    logWarning,
+    logError,
+    logWith,
+    logTraceWith,
+    logDebugWith,
+    logInfoWith,
+    logWarningWith,
+    logErrorWith
+  ) where
+
+import           Colog                    (LogAction (unLogAction), WithLog,
+                                           logMsg)
+import           Control.Monad.IO.Class   (MonadIO (liftIO))
+import qualified Data.Text                as T
+import           Data.Time                (UTCTime, defaultTimeLocale,
+                                           getCurrentTime)
+import           Data.Time.Format.ISO8601 (iso8601Show)
+import           Prelude                  hiding (log)
+import           System.Console.ANSI      (Color (Cyan, Green, Red, White, Yellow),
+                                           ColorIntensity (Dull, Vivid),
+                                           ConsoleLayer (Foreground),
+                                           SGR (Reset, SetColor), setSGRCode)
+
+
+data Severity =
+    Trace
+  | Debug
+  | Info
+  | Warning
+  | Error
+  deriving (Show, Eq, Ord)
+
+data Message =
+  Message
+  {
+    msgTimestamp :: UTCTime,
+    msgComponent :: T.Text,
+    msgSeverity  :: Severity,
+    msgText      :: T.Text
+  } deriving (Show, Eq)
+
+fmtMessage :: Message -> T.Text
+fmtMessage Message{..} =
+  (bracketed . T.pack . iso8601Show) msgTimestamp <>
+  bracketed msgComponent <>
+  showSeverity msgSeverity <>
+  " " <>
+  msgText
+  where
+    bracketed txt = "[" <> txt <> "]"
+
+showSeverity :: Severity -> T.Text
+showSeverity = \case
+  Trace -> color White Dull "[Trace]  "
+  Debug -> color Cyan Dull "[Debug]  "
+  Info -> color Green Vivid "[Info]   "
+  Warning -> color Yellow Vivid "[Warning]"
+  Error -> color Red Vivid "[Error]  "
+  where
+    color c h txt = T.pack (setSGRCode [SetColor Foreground h c])
+        <> txt
+        <> T.pack (setSGRCode [Reset])
+
+logWith :: (MonadIO m) => LogAction m Message -> Severity -> T.Text -> T.Text -> m ()
+logWith act sev comp txt = do
+  now <- liftIO getCurrentTime
+  unLogAction act $ Message now comp sev txt
+
+logTraceWith :: (MonadIO m) => LogAction m Message -> T.Text -> T.Text -> m ()
+logTraceWith act = logWith act Trace
+
+logDebugWith :: (MonadIO m) => LogAction m Message -> T.Text -> T.Text -> m ()
+logDebugWith act = logWith act Debug
+
+logInfoWith :: (MonadIO m) => LogAction m Message -> T.Text -> T.Text -> m ()
+logInfoWith act = logWith act Info
+
+logWarningWith :: (MonadIO m) => LogAction m Message -> T.Text -> T.Text -> m ()
+logWarningWith act = logWith act Warning
+
+logErrorWith :: (MonadIO m) => LogAction m Message -> T.Text -> T.Text -> m ()
+logErrorWith act = logWith act Error
+
+log :: (MonadIO m, WithLog env Message m) => Severity -> T.Text -> T.Text -> m ()
+log sev comp txt = do
+  now <- liftIO getCurrentTime
+  logMsg $ Message now comp sev txt
+
+logTrace :: (MonadIO m, WithLog env Message m) => T.Text -> T.Text -> m ()
+logTrace = log Trace
+
+logDebug :: (MonadIO m, WithLog env Message m) => T.Text -> T.Text -> m ()
+logDebug = log Debug
+
+logInfo :: (MonadIO m, WithLog env Message m) => T.Text -> T.Text -> m ()
+logInfo = log Info
+
+logWarning :: (MonadIO m, WithLog env Message m) => T.Text -> T.Text -> m ()
+logWarning = log Warning
+
+logError :: (MonadIO m, WithLog env Message m) => T.Text -> T.Text -> m ()
+logError = log Error

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-17.14
+resolver: lts-18.18
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -40,7 +40,11 @@ packages:
 - '../zeromq4-haskell-zap'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: [ "datetime-0.3.1", "hexdump-0.1"]
+extra-deps:
+- datetime-0.3.1
+- hexdump-0.1
+- co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087
+- ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226
 
 # Override default flag values for local packages and extra-deps
 flags: {}