[RFC] Allow arbitrary logger types

yesod-core/src/Yesod/Core.hs

@@ -151,7 +151,7 @@ import Network.Wai (Application)
 
 runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
-               -> (site -> Logger)
+               -> (site -> SiteLogger site)
                -> site
                -> HandlerT site IO a
                -> m (Either ErrorResponse a)

yesod-core/src/Yesod/Core/Class/Yesod.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeFamilies      #-}
 module Yesod.Core.Class.Yesod where
 
 import           Yesod.Core.Content
@@ -215,6 +217,9 @@ class RenderRoute site => Yesod site where
     maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
     maximumContentLengthIO a b = pure $ maximumContentLength a b
 
+    type SiteLogger site :: *
+    type SiteLogger site = Logger
+
     -- | Creates a @Logger@ to use for log messages.
     --
     -- Note that a common technique (endorsed by the scaffolding) is to create
@@ -223,20 +228,29 @@ class RenderRoute site => Yesod site where
     -- same @Logger@ for printing messages during app initialization.
     --
     -- Default: the 'defaultMakeLogger' function.
-    makeLogger :: site -> IO Logger
+    makeLogger :: site -> IO (SiteLogger site)
+    default makeLogger :: (SiteLogger site ~ Logger) => site -> IO (SiteLogger site)
     makeLogger _ = defaultMakeLogger
 
     -- | Send a message to the @Logger@ provided by @getLogger@.
     --
     -- Default: the 'defaultMessageLoggerSource' function, using
     -- 'shouldLogIO' to check whether we should log.
     messageLoggerSource :: site
-                        -> Logger
+                        -> SiteLogger site
                         -> Loc -- ^ position in source code
                         -> LogSource
                         -> LogLevel
                         -> LogStr -- ^ message
                         -> IO ()
+    default messageLoggerSource :: (SiteLogger site ~ Logger)
+                                => site
+                                -> SiteLogger site
+                                -> Loc
+                                -> LogSource
+                                -> LogLevel
+                                -> LogStr
+                                -> IO ()
     messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site
 
     -- | Where to Load sripts from. We recommend the default value,

yesod-core/src/Yesod/Core/Dispatch.hs

@@ -83,11 +83,11 @@ import Data.Version (showVersion)
 -- used middlewares, please use 'toWaiApp'.
 toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
 toWaiAppPlain site = do
-    logger <- makeLogger site
+    waiLogger <- defaultMakeLogger
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     return $ toWaiAppYre YesodRunnerEnv
-            { yreLogger = logger
+            { yreLogger = waiLogger
             , yreSite = site
             , yreSessionBackend = sb
             , yreGen = defaultGen
@@ -158,15 +158,16 @@ toWaiAppYre yre req =
 -- * Accept header override with the _accept query string parameter
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
-    logger <- makeLogger site
-    toWaiAppLogger logger site
+    waiLogger <- defaultMakeLogger
+    toWaiAppLogger waiLogger site
 
 toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
-toWaiAppLogger logger site = do
+toWaiAppLogger waiLogger site = do
+    logger <- makeLogger site
     sb <- makeSessionBackend site
     getMaxExpires <- getGetMaxExpires
     let yre = YesodRunnerEnv
-                { yreLogger = logger
+                { yreLogger = waiLogger
                 , yreSite = site
                 , yreSessionBackend = sb
                 , yreGen = defaultGen
@@ -179,7 +180,7 @@ toWaiAppLogger logger site = do
         "yesod-core"
         LevelInfo
         (toLogStr ("Application launched" :: S.ByteString))
-    middleware <- mkDefaultMiddlewares logger
+    middleware <- mkDefaultMiddlewares waiLogger
     return $ middleware $ toWaiAppYre yre
 
 -- | A convenience method to run an application using the Warp webserver on the
@@ -194,7 +195,7 @@ toWaiAppLogger logger site = do
 warp :: YesodDispatch site => Int -> site -> IO ()
 warp port site = do
     logger <- makeLogger site
-    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings (
+    toWaiApp site >>= Network.Wai.Handler.Warp.runSettings (
         Network.Wai.Handler.Warp.setPort port $
         Network.Wai.Handler.Warp.setServerName serverValue $
         Network.Wai.Handler.Warp.setOnException (\_ e ->

yesod-core/src/Yesod/Core/Internal/Run.hs

@@ -238,7 +238,7 @@ safeEh log' er req = do
 -- @HandlerFor@'s return value.
 runFakeHandler :: (Yesod site, MonadIO m) =>
                   SessionMap
-               -> (site -> Logger)
+               -> (site -> SiteLogger site)
                -> site
                -> HandlerFor site a
                -> m (Either ErrorResponse a)
@@ -304,6 +304,7 @@ yesodRunner :: (ToTypedContent res, Yesod site)
             -> Maybe (Route site)
             -> Application
 yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
+  logger <- liftIO $ makeLogger yreSite
   mmaxLen <- maximumContentLengthIO yreSite route
   case (mmaxLen, requestBodyLength req) of
     (Just maxLen, KnownLength len) | maxLen < len -> sendResponse (tooLargeResponse maxLen len)
@@ -318,7 +319,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do
                   Left yreq' -> yreq'
                   Right needGen -> needGen yreGen
       let ra = resolveApproot yreSite req
-      let log' = messageLoggerSource yreSite yreLogger
+      let log' = messageLoggerSource yreSite logger
           -- We set up two environments: the first one has a "safe" error handler
           -- which will never throw an exception. The second one uses the
           -- user-provided errorHandler function. If that errorHandler function

yesod-core/src/Yesod/Core/Unsafe.hs

@@ -15,7 +15,7 @@ import Control.Monad.IO.Class (MonadIO)
 --
 -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 fakeHandlerGetLogger :: (Yesod site, MonadIO m)
-                     => (site -> Logger)
+                     => (site -> SiteLogger site)
                      -> site
                      -> HandlerFor site a
                      -> m a