Use logger in the example

examples/mig-example-apps/JsonApi/Init.hs

@@ -4,17 +4,14 @@ module Init (
 ) where
 
 import Control.Monad
-import Data.Aeson ((.=))
-import Data.Aeson qualified as Json
 import Data.IORef
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Time
-import Data.Yaml qualified as Yaml
-import System.Log.FastLogger
+import Mig.Tool.Log.Fast qualified as Log
 import System.Random
 
 import Interface
@@ -38,18 +35,15 @@ initEnv port = do
 
 initProc :: Int -> IO Proc
 initProc port = do
-  (writeLog, closeLogger) <- newFastLogger (LogStdout defaultBufSize)
-  let logger = initLogger writeLog
-
-      logMessage :: Text -> IO ()
-      logMessage msg = logger.info $ Json.toJSON msg
+  logger <- Log.newLoggerStdout Log.LogYaml
+  let Log.LogFuns{..} = Log.logFuns logger
   pure $
     Proc
       { logger = logger
-      , startup = logMessage $ ("App starts on port: " <> Text.pack (show port))
+      , startup = logInfo @Text $ ("App starts on port: " <> Text.pack (show port))
       , cleanup = do
-          logMessage "App shutdown"
-          closeLogger
+          logInfo @Text "App shutdown"
+          logger.close.run
       }
 
 initAuth :: St -> Auth
@@ -82,30 +76,6 @@ toDaySpan day (DayInterval count) = List.unfoldr go (day, count)
       | n <= 0 = Nothing
       | otherwise = Just (succ d, (succ d, n - 1))
 
-initLogger :: (LogStr -> IO ()) -> Logger
-initLogger writeLog =
-  Logger
-    { error = logBy "ERROR"
-    , info = logBy "INFO"
-    , debug = logBy "DEBUG"
-    }
-  where
-    logBy :: Text -> LogFun
-    logBy level msg = do
-      now <- getCurrentTime
-      writeLog $
-        toLogStr $
-          (<> "\n") $
-            Yaml.encode $
-              Json.object
-                [ "log"
-                    .= Json.object
-                      [ "message" .= msg
-                      , "level" .= level
-                      , "time" .= now
-                      ]
-                ]
-
 initStateConfig :: IO InitSt
 initStateConfig = do
   now <- (.utctDay) <$> getCurrentTime

examples/mig-example-apps/JsonApi/Interface.hs

@@ -1,18 +1,18 @@
 module Interface (
   Env (..),
-  LogFun,
   Proc (..),
-  Logger (..),
-  logInfo,
-  logDebug,
-  logError,
   Auth (..),
   Weather (..),
+  getLogger,
+  module X,
 ) where
 
-import Data.Aeson (ToJSON (..), Value)
+import Mig.Tool.Log as X (Log, LogFuns (..), LogNamespace, addLogNamespace, logFuns)
 import Types
 
+getLogger :: Env -> LogNamespace -> LogFuns
+getLogger env ns = logFuns (addLogNamespace ns env.proc.logger)
+
 -- | Site's environment. It contains all interfaces
 data Env = Env
   { weather :: Weather
@@ -24,25 +24,7 @@ data Env = Env
 data Proc = Proc
   { startup :: IO ()
   , cleanup :: IO ()
-  , logger :: Logger
-  }
-
-type LogFun = Value -> IO ()
-
-logInfo :: (ToJSON a) => Env -> a -> IO ()
-logInfo env = env.proc.logger.info . toJSON
-
-logDebug :: (ToJSON a) => Env -> a -> IO ()
-logDebug env = env.proc.logger.debug . toJSON
-
-logError :: (ToJSON a) => Env -> a -> IO ()
-logError env = env.proc.logger.error . toJSON
-
--- logger interface
-data Logger = Logger
-  { info :: LogFun
-  , debug :: LogFun
-  , error :: LogFun
+  , logger :: Log
   }
 
 -- authorization interface

examples/mig-example-apps/JsonApi/Server.hs

@@ -32,7 +32,9 @@ server env =
         , "update" /. updateWeather env
         ]
 
-    withTrace = applyPlugin (Trace.logHttpBy (logInfo env) Trace.V2)
+    withTrace = applyPlugin (Trace.logHttpBy logInfo Trace.V2)
+
+    LogFuns{..} = getLogger env "http"
 
 -------------------------------------------------------------------------------------
 -- application handlers
@@ -44,36 +46,42 @@ getWeather ::
   Capture "day-interval" DayInterval ->
   Get (RespOr Text (Timed WeatherData))
 getWeather env (Capture location) (Capture fromDay) (Capture interval) = Send $ do
-  logInfo @Text env "get the weather forecast"
+  logInfo @Text "get the weather forecast"
   mResult <- env.weather.get location fromDay interval
   pure $ case mResult of
     Just result -> ok result
     Nothing -> bad status400 "No data"
+  where
+    LogFuns{..} = getLogger env "getWeather"
 
 updateWeather ::
   Env ->
   Body UpdateData ->
   Post (RespOr Text ())
 updateWeather env (Body updateData) = Send $ do
-  logInfo @Text env "update the weather data"
+  logInfo @Text "update the weather data"
   ok <$> env.weather.update updateData
+  where
+    LogFuns{..} = getLogger env "updateWeather"
 
 -------------------------------------------------------------------------------------
 -- authorization
 
 requestAuthToken :: Env -> Body User -> Post (RespOr Text AuthToken)
 requestAuthToken env (Body user) = Send $ do
-  logInfo env ("get new auth token for: " <> user.name)
+  logInfo ("get new auth token for: " <> user.name)
   isValid <- env.auth.validUser user
   if isValid
     then do
       token <- env.auth.newToken user
       void $ forkIO $ setExpireTimer token
       pure $ ok token
     else do
-      logError env $ Text.unwords ["User", user.name, "does not have access to the service"]
+      logError $ Text.unwords ["User", user.name, "does not have access to the service"]
       pure $ bad unauthorized401 "User is not valid"
   where
+    LogFuns{..} = getLogger env "requestAuthToken"
+
     setExpireTimer :: AuthToken -> IO ()
     setExpireTimer token = do
       threadDelay (1_000_000 * 60 * 10) -- 10 minutes
@@ -85,7 +93,8 @@ withAuth env (Header token) = processResponse $ \getResp -> do
   if isOk
     then getResp
     else do
-      logError env errMessage
+      logError errMessage
       pure $ Just (bad status500 $ Text.encodeUtf8 errMessage)
   where
     errMessage = "Token is invalid"
+    LogFuns{..} = getLogger env "auth"

examples/mig-example-apps/mig-example-apps.cabal

@@ -306,13 +306,14 @@ executable json-api-mig-example-app
     , bytestring
     , containers
     , derive-topdown
-    , fast-logger
     , http-types
     , mig
     , mig-client
     , mig-extra
+    , mig-fast-logger
     , mig-server
     , mig-swagger-ui
+    , mig-tools
     , openapi3
     , pretty-simple
     , random

examples/mig-example-apps/package.yaml

@@ -119,7 +119,8 @@ executables:
     - -with-rtsopts=-N
     dependencies:
     - containers
-    - fast-logger
+    - mig-tools
+    - mig-fast-logger
     - yaml
 
   counter-mig-example-app:

examples/mig-example-apps/stack.yaml

@@ -11,3 +11,5 @@ extra-deps:
   - ../../mig-swagger-ui
   - ../../mig-wai
   - ../../mig-extra
+  - ../../mig-tools
+  - ../../tools/mig-fast-logger

mig-tools/src/Mig/Tool/Base.hs

@@ -58,7 +58,7 @@ newtype GetOr err a = GetOr
 
 instance Applicative (GetOr err) where
   pure = GetOr . pure . pure
-  (<*>) (GetOr fa) (GetOr fb) = GetOr (liftA2 (<*>) fa fb)
+  (<*>) (GetOr fa) (GetOr fb) = GetOr ((<*>) <$> fa <*> fb)
 
 instance Monad (GetOr err) where
   (GetOr ma) >>= mf = GetOr $ do

mig-tools/src/Mig/Tool/Log.hs

@@ -9,10 +9,9 @@ module Mig.Tool.Log (
   trackLogTime,
 
   -- * functions
-  logInfo,
-  logWarn,
-  logError,
-  logDebug,
+  LogFuns (..),
+  logFuns,
+  logByLevel,
 
   -- * augment interfaces with logger
   logQuery,
@@ -24,9 +23,12 @@ module Mig.Tool.Log (
 ) where
 
 import Control.Monad
+import Data.Aeson (ToJSON)
 import Data.Aeson qualified as Json
 import Data.Aeson.Types qualified as Json
+import Data.String
 import Data.Text (Text)
+import Data.Text qualified as Text
 import Data.Time
 import Mig.Tool.Base
 
@@ -43,6 +45,9 @@ instance Json.ToJSON LogLevel where
 newtype LogNamespace = LogNamespace [Text]
   deriving newtype (Semigroup, Monoid, Show, Eq, Json.ToJSON)
 
+instance IsString LogNamespace where
+  fromString = LogNamespace . Text.splitOn "." . fromString
+
 data LogItem = LogItem
   { level :: LogLevel
   , time :: Maybe UTCTime
@@ -98,24 +103,28 @@ logByLevel level logger message = do
       , message = Json.toJSON message
       }
 
-logInfo :: (Json.ToJSON a) => Log -> a -> IO ()
-logInfo = logByLevel LogInfo
-
-logDebug :: (Json.ToJSON a) => Log -> a -> IO ()
-logDebug = logByLevel LogDebug
-
-logWarn :: (Json.ToJSON a) => Log -> a -> IO ()
-logWarn = logByLevel LogWarn
+data LogFuns = LogFuns
+  { logInfo :: forall a. (ToJSON a) => a -> IO ()
+  , logDebug :: forall a. (ToJSON a) => a -> IO ()
+  , logWarn :: forall a. (ToJSON a) => a -> IO ()
+  , logError :: forall a. (ToJSON a) => a -> IO ()
+  }
 
-logError :: (Json.ToJSON a) => Log -> a -> IO ()
-logError = logByLevel LogError
+logFuns :: Log -> LogFuns
+logFuns log =
+  LogFuns
+    { logInfo = logByLevel LogInfo log
+    , logDebug = logByLevel LogDebug log
+    , logWarn = logByLevel LogWarn log
+    , logError = logByLevel LogError log
+    }
 
 -------------------------------------------------------------------------------------
 -- add logger to interface
 
 logSet :: (Json.ToJSON a) => Log -> Text -> Set a -> Set a
 logSet env name (Set act) = Set $ \a -> do
-  logInfo env $
+  logByLevel LogInfo env $
     Json.object
       [ "call" Json..= name
       , "argument" Json..= a

tools/mig-fast-logger/src/Mig/Tool/Log/Fast.hs

@@ -1,5 +1,6 @@
 -- | Init fast-logger
 module Mig.Tool.Log.Fast (
+  LogCodec (..),
   newLogger,
   newLoggerStdout,
   module X,
@@ -8,7 +9,7 @@ module Mig.Tool.Log.Fast (
 import Data.Aeson qualified as Json
 import Data.ByteString.Lazy (ByteString, fromStrict)
 import Data.Yaml qualified as Yaml
-import Mig.Tool.Base
+import Mig.Tool.Base as X
 import Mig.Tool.Log as X
 import System.Log.FastLogger qualified as FastLogger
 
@@ -18,10 +19,11 @@ newLogger :: LogCodec -> FastLogger.LogType -> IO Log
 newLogger codec config = do
   (writeLog, closeLogger) <- FastLogger.newFastLogger config
   pure $
-    Log
-      { log = Set (writeLog . toLogStr)
-      , close = Proc closeLogger
-      }
+    trackLogTime $
+      Log
+        { log = Set (writeLog . toLogStr)
+        , close = Proc closeLogger
+        }
   where
     toLogStr :: LogItem -> FastLogger.LogStr
     toLogStr = FastLogger.toLogStr . toByteString