LogSource (#405)

yesod-core/Yesod/Handler.hs

@@ -194,7 +194,7 @@ data HandlerData sub master = HandlerData
     , handlerToMaster :: Route sub -> Route master
     , handlerState    :: I.IORef GHState
     , handlerUpload   :: Word64 -> FileUpload
-    , handlerLog      :: Loc -> LogLevel -> LogStr -> IO ()
+    , handlerLog      :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
     }
 
 handlerSubData :: (Route sub -> Route master)
@@ -471,7 +471,7 @@ runHandler :: HasReps c
            -> master
            -> sub
            -> (Word64 -> FileUpload)
-           -> (Loc -> LogLevel -> LogStr -> IO ())
+           -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
            -> YesodApp
 runHandler handler mrender sroute tomr master sub upload log' =
   YesodApp $ \eh rr cts initSession -> do
@@ -881,7 +881,7 @@ handlerToYAR :: (HasReps a, HasReps b)
              => master -- ^ master site foundation
              -> sub    -- ^ sub site foundation
              -> (Word64 -> FileUpload)
-             -> (Loc -> LogLevel -> LogStr -> IO ())
+             -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
              -> (Route sub -> Route master)
              -> (Route master -> [(Text, Text)] -> Text) -- route renderer
              -> (ErrorResponse -> GHandler sub master a)
@@ -1056,6 +1056,7 @@ instance MonadResource (GHandler sub master) where
 #endif
 
 instance MonadLogger (GHandler sub master) where
-    monadLoggerLog a b c = do
+    monadLoggerLog a c d = monadLoggerLogSource a "" c d
+    monadLoggerLogSource a b c d = do
         hd <- ask
-        liftIO $ handlerLog hd a b (toLogStr c)
+        liftIO $ handlerLog hd a b c (toLogStr d)

yesod-core/Yesod/Internal/Core.hs

@@ -90,7 +90,7 @@ import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd)
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
 import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)
-import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther))
+import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
 import System.Log.FastLogger.Date (ZonedDate)
 import System.IO (stdout)
 
@@ -305,16 +305,29 @@ $doctype 5
     getLogger _ = mkLogger True stdout
 
     -- | Send a message to the @Logger@ provided by @getLogger@.
+    --
+    -- Note: This method is no longer used. Instead, you should override
+    -- 'messageLoggerSource'.
     messageLogger :: a
                   -> Logger
                   -> Loc -- ^ position in source code
                   -> LogLevel
                   -> LogStr -- ^ message
                   -> IO ()
-    messageLogger a logger loc level msg =
-        if level < logLevel a
-            then return ()
-            else formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger
+    messageLogger a logger loc = messageLoggerSource a logger loc ""
+
+    -- | Send a message to the @Logger@ provided by @getLogger@.
+    messageLoggerSource :: a
+                        -> Logger
+                        -> Loc -- ^ position in source code
+                        -> LogSource
+                        -> LogLevel
+                        -> LogStr -- ^ message
+                        -> IO ()
+    messageLoggerSource a logger loc source level msg =
+        if shouldLog a source level
+            then formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger
+            else return ()
 
     -- | The logging level in place for this application. Any messages below
     -- this level will simply be ignored.
@@ -353,6 +366,12 @@ $doctype 5
         | size > 50000 = FileUploadDisk tempFileBackEnd
         | otherwise = FileUploadMemory lbsBackEnd
 
+    -- | Should we log the given log source/level combination.
+    --
+    -- Default: Logs everything at or above 'logLevel'
+    shouldLog :: a -> LogSource -> LogLevel -> Bool
+    shouldLog a _ level = level >= logLevel a
+
 formatLogMessage :: IO ZonedDate
                  -> Loc
                  -> LogLevel
@@ -424,7 +443,7 @@ defaultYesodRunner logger handler master sub murl toMasterRoute msb req
                 handler
     let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
     let ra = resolveApproot master req
-    let log' = messageLogger master logger
+    let log' = messageLoggerSource master logger
     yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
         (yesodRender master ra) errorHandler rr murl sessionMap h
     extraHeaders <- case yar of
@@ -802,7 +821,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
           master
           master
           (fileUpload master)
-          (messageLogger master $ logger master)
+          (messageLoggerSource master $ logger master)
       errHandler err =
         YesodApp $ \_ _ _ session -> do
           liftIO $ I.writeIORef ret (Left err)

yesod-core/Yesod/Widget.hs

@@ -352,3 +352,4 @@ instance MonadResource (GWidget sub master) where
 
 instance MonadLogger (GWidget sub master) where
     monadLoggerLog a b = lift . monadLoggerLog a b
+    monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c

yesod-core/yesod-core.cabal

@@ -78,7 +78,7 @@ library
                    , vector                >= 0.9      && < 0.10
                    , aeson                 >= 0.5
                    , fast-logger           >= 0.2
-                   , monad-logger          >= 0.2      && < 0.3
+                   , monad-logger          >= 0.2.1    && < 0.3
                    , conduit               >= 0.5      && < 0.6
                    , resourcet             >= 0.3      && < 0.5
                    , lifted-base           >= 0.1      && < 0.2