Remove LoggingT

Author: nicolashery

example-handlers.cabal

@@ -81,6 +81,7 @@ library
         App.Db
         App.External
         App.Json
+        App.Logging
         App.Req
         App.Scotty
         App.Servant
@@ -92,8 +93,8 @@ library
         , bytestring ^>= 0.11
         , http-client ^>= 0.7
         , http-types ^>= 0.12
-        , microlens ^>= 0.4
         , modern-uri ^>= 0.3
+        , monad-logger ^>= 0.3
         , mtl ^>= 2.3
         , postgresql-simple ^>= 0.7
         , req ^>= 3.13

src/App/AppEnv.hs

@@ -2,7 +2,7 @@ module App.AppEnv
   ( AppEnv
       ( AppEnv,
         appEnvConfig,
-        appEnvLogger,
+        appEnvLogFunc,
         appEnvHttpConfig,
         appEnvDbPool
       ),
@@ -29,22 +29,20 @@ import App.Config
     configInit,
   )
 import App.Db (HasDbPool (getDbPool), dbInit)
-import Blammo.Logging (HasLogger (loggerL), Logger)
-import Blammo.Logging.Simple (newLoggerEnv)
+import App.Logging (HasLogFunc (getLogFunc), LogFunc, loggingInit)
 import Data.Pool (Pool)
 import Database.PostgreSQL.Simple (Connection)
-import Lens.Micro (lens)
 import Network.HTTP.Req (HttpConfig, defaultHttpConfig)
 
 data AppEnv = AppEnv
   { appEnvConfig :: Config,
-    appEnvLogger :: Logger,
+    appEnvLogFunc :: LogFunc,
     appEnvHttpConfig :: HttpConfig,
     appEnvDbPool :: Pool Connection
   }
 
-instance HasLogger AppEnv where
-  loggerL = lens appEnvLogger $ \x y -> x {appEnvLogger = y}
+instance HasLogFunc AppEnv where
+  getLogFunc = appEnvLogFunc
 
 instance HasCartConfig AppEnv where
   getBookingUrl = configBookingUrl . appEnvConfig
@@ -58,12 +56,12 @@ instance HasDbPool AppEnv where
 appEnvInit :: IO AppEnv
 appEnvInit = do
   config <- configInit
-  logger <- newLoggerEnv
+  logFunc <- loggingInit
   dbPool <- dbInit $ configDatabaseUrl config
   let app =
         AppEnv
           { appEnvConfig = config,
-            appEnvLogger = logger,
+            appEnvLogFunc = logFunc,
             appEnvHttpConfig = defaultHttpConfig,
             appEnvDbPool = dbPool
           }

src/App/Logging.hs

@@ -0,0 +1,40 @@
+module App.Logging
+  ( LogFunc,
+    HasLogFunc (getLogFunc),
+    loggingInit,
+    monadLoggerLogImpl,
+  )
+where
+
+import Blammo.Logging (MonadLoggerIO (askLoggerIO), runLoggerLoggingT)
+import Blammo.Logging.Simple (newLoggerEnv)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Logger
+  ( Loc,
+    LogLevel,
+    LogSource,
+    LogStr,
+    ToLogStr (toLogStr),
+  )
+import Control.Monad.Reader (MonadReader, asks)
+
+type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+
+class HasLogFunc env where
+  getLogFunc :: env -> LogFunc
+
+loggingInit :: IO LogFunc
+loggingInit = do
+  logger <- newLoggerEnv
+  runLoggerLoggingT logger askLoggerIO
+
+monadLoggerLogImpl ::
+  (MonadReader env m, HasLogFunc env, MonadIO m, ToLogStr msg) =>
+  Loc ->
+  LogSource ->
+  LogLevel ->
+  msg ->
+  m ()
+monadLoggerLogImpl loc logSource logLevel msg = do
+  logFunc <- asks getLogFunc
+  liftIO $ logFunc loc logSource logLevel (toLogStr msg)

src/App/Scotty.hs

@@ -20,13 +20,12 @@ import App.Cart
   )
 import App.Config (Config (configPurchaseDelay))
 import App.Json (defaultToJSON)
+import App.Logging (monadLoggerLogImpl)
 import Blammo.Logging
-  ( LoggingT,
-    Message ((:#)),
+  ( Message ((:#)),
     MonadLogger (monadLoggerLog),
     logInfo,
     logWarn,
-    runLoggerLoggingT,
     (.=),
   )
 import Control.Concurrent (threadDelay)
@@ -59,13 +58,12 @@ import Web.Scotty.Trans
   )
 
 newtype App a = App
-  { unApp :: ReaderT AppEnv (LoggingT IO) a
+  { unApp :: ReaderT AppEnv IO a
   }
   deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadUnliftIO)
 
 instance MonadLogger App where
-  monadLoggerLog loc logSource logLevel msg =
-    App $ lift $ monadLoggerLog loc logSource logLevel msg
+  monadLoggerLog = monadLoggerLogImpl
 
 instance (ScottyError e, MonadLogger m) => MonadLogger (ActionT e m) where
   monadLoggerLog loc logSource logLevel msg =
@@ -78,7 +76,7 @@ instance MonadHttp App where
 runApp :: App a -> IO a
 runApp m = do
   app <- appEnvInit
-  runLoggerLoggingT app $ runReaderT (unApp m) app
+  runReaderT (unApp m) app
 
 data CartPurchaseResponse = CartPurchaseResponse
   { cartPurchaseResponseCartId :: CartId,

src/App/Servant.hs

@@ -17,20 +17,18 @@ import App.Cart
   )
 import App.Config (Config (configPurchaseDelay))
 import App.Json (defaultToJSON)
+import App.Logging (monadLoggerLogImpl)
 import Blammo.Logging
-  ( LoggingT,
-    Message ((:#)),
+  ( Message ((:#)),
     MonadLogger (monadLoggerLog),
     logInfo,
     logWarn,
-    runLoggerLoggingT,
     (.=),
   )
 import Control.Concurrent (threadDelay)
 import Control.Monad.Except (ExceptT (ExceptT))
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)
-import Control.Monad.Trans (lift)
 import Data.Aeson (ToJSON (toJSON), encode, object)
 import Data.Text (Text)
 import GHC.Generics (Generic)
@@ -63,21 +61,20 @@ import UnliftIO.Async (concurrently)
 import UnliftIO.Exception (catch, throwIO, try)
 
 newtype App a = App
-  { unApp :: ReaderT AppEnv (LoggingT IO) a
+  { unApp :: ReaderT AppEnv IO a
   }
   deriving (Functor, Applicative, Monad, MonadReader AppEnv, MonadIO, MonadUnliftIO)
 
 instance MonadLogger App where
-  monadLoggerLog loc logSource logLevel msg =
-    App $ lift $ monadLoggerLog loc logSource logLevel msg
+  monadLoggerLog = monadLoggerLogImpl
 
 instance MonadHttp App where
   handleHttpException = throwIO
   getHttpConfig = asks appEnvHttpConfig
 
 appToHandler :: AppEnv -> App a -> Handler a
 appToHandler app m =
-  Handler $ ExceptT $ try $ runLoggerLoggingT app $ runReaderT (unApp m) app
+  Handler $ ExceptT $ try $ runReaderT (unApp m) app
 
 type Api = "cart" :> Capture "cartId" CartId :> "purchase" :> Post '[JSON] CartPurchaseResponse
 

src/App/Yesod.hs

@@ -11,7 +11,10 @@ module App.Yesod
   )
 where
 
-import App.AppEnv (AppEnv (appEnvConfig, appEnvHttpConfig), appEnvInit)
+import App.AppEnv
+  ( AppEnv (appEnvConfig, appEnvHttpConfig, appEnvLogFunc),
+    appEnvInit,
+  )
 import App.Cart
   ( BookingId,
     CartException (CartException),
@@ -35,10 +38,8 @@ import App.Db (HasDbPool (getDbPool))
 import App.Json (defaultToJSON)
 import Blammo.Logging
   ( Message ((:#)),
-    MonadLogger (monadLoggerLog),
     logInfo,
     logWarn,
-    runLoggerLoggingT,
     (.=),
   )
 import Control.Concurrent (threadDelay)
@@ -96,8 +97,9 @@ instance MonadHttp Handler where
   getHttpConfig = getsYesod appEnvHttpConfig
 
 instance Yesod AppEnv where
-  messageLoggerSource app _logger loc source level msg =
-    runLoggerLoggingT app $ monadLoggerLog loc source level msg
+  messageLoggerSource app _logger loc source level msg = do
+    let logFunc = appEnvLogFunc app
+    logFunc loc source level msg
 
   makeSessionBackend _ = return Nothing