From d5b97cb23ee437ca98d7675939e742a58ab5a4aa Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Wed, 25 Aug 2021 17:38:45 +0100 Subject: [PATCH] Make site's logger type be instance-based At the moment, all sites are tied to using the fast-logger `Logger` type for Yesod's logging functions, including `makeLogger` and `messageLoggerSource`. This represents an obstacle to logging through other libraries which are incompatible with the fast-logger API. This replaces the use of the concrete `Logger` type with an associated type family on the `Yesod` class which allows sites to use their choice of logger representation for Yesod's logging functions. The associated type family is declared in such a way that existing instances should work with no further effort. This commit introduces a change in semantics around how logging is shared between the Yesod site and the underlying WAI server - because WAI is still tied to fast-logger, it's not possible to have them share the logging config in general. Instead, the logger passed to WAI is the default stdout logger. --- yesod-core/src/Yesod/Core.hs | 2 +- yesod-core/src/Yesod/Core/Class/Yesod.hs | 18 ++++++++++++++++-- yesod-core/src/Yesod/Core/Dispatch.hs | 17 +++++++++-------- yesod-core/src/Yesod/Core/Internal/Run.hs | 5 +++-- yesod-core/src/Yesod/Core/Unsafe.hs | 2 +- 5 files changed, 30 insertions(+), 14 deletions(-) diff --git a/yesod-core/src/Yesod/Core.hs b/yesod-core/src/Yesod/Core.hs index 13ed21367..255339dd1 100644 --- a/yesod-core/src/Yesod/Core.hs +++ b/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) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 2a2c1b047..bd9e3be3e 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/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,7 +228,8 @@ 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@. @@ -231,12 +237,20 @@ class RenderRoute site => Yesod site where -- 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, diff --git a/yesod-core/src/Yesod/Core/Dispatch.hs b/yesod-core/src/Yesod/Core/Dispatch.hs index feb7765b2..b64c4a1d0 100644 --- a/yesod-core/src/Yesod/Core/Dispatch.hs +++ b/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 -> diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 8f0afee9c..b8a1a4218 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/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 diff --git a/yesod-core/src/Yesod/Core/Unsafe.hs b/yesod-core/src/Yesod/Core/Unsafe.hs index 3683ba915..a95cca042 100644 --- a/yesod-core/src/Yesod/Core/Unsafe.hs +++ b/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