use fast-logger/wai-logger

yesod-core/Yesod/Logger.hs

@@ -1,68 +1,92 @@
--- blantantly taken from hakyll
--- http://hackage.haskell.org/packages/archive/hakyll/3.1.1.0/doc/html/src/Hakyll-Core-Logger.html
---
--- | Produce pretty, thread-safe logs
---
 {-# LANGUAGE BangPatterns #-}
 module Yesod.Logger
     ( Logger
     , makeLogger
+    , makeDefaultLogger
     , flushLogger
     , timed
     , logText
     , logLazyText
     , logString
+    , logBS
+    , logMsg
+    , formatLogText
     ) where
 
-import Control.Monad (forever)
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Applicative ((<$>), (<*>))
-import Control.Concurrent (forkIO)
-import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan)
-import Control.Concurrent.MVar.Strict (MVar, newEmptyMVar, takeMVar, putMVar)
-import Text.Printf (printf)
-import Data.Text
+import System.IO (Handle, stdout, hFlush)
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 (pack)
+import Data.ByteString.Lazy (toChunks)
 import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.IO
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Lazy.Encoding as TLE
+import System.Log.FastLogger
+import Network.Wai.Logger.Date (DateRef, dateInit, getDate)
+
+-- for timed logging
 import Data.Time (getCurrentTime, diffUTCTime)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Text.Printf (printf)
+import Data.Text (unpack)
 
-data Logger = Logger
-    { loggerChan :: Chan (Maybe TL.Text)  -- Nothing marks the end
-    , loggerSync :: MVar ()               -- Used for sync on quit
-    }
+-- for formatter
+import Language.Haskell.TH.Syntax (Loc)
+import Yesod.Core (LogLevel, fileLocationToString)
 
-makeLogger :: IO Logger
-makeLogger = do
-    logger <- Logger <$> newChan <*> newEmptyMVar
-    _ <- forkIO $ loggerThread logger
-    return logger
-  where
-    loggerThread logger = forever $ do
-        msg <- readChan $ loggerChan logger
-        case msg of
-            -- Stop: sync
-            Nothing -> putMVar (loggerSync logger) ()
-            -- Print and continue
-            Just m  -> Data.Text.Lazy.IO.putStrLn m
+data Logger = Logger {
+    loggerHandle  :: Handle
+  , loggerDateRef :: DateRef
+  }
+
+makeLogger :: Handle -> IO Logger
+makeLogger handle = dateInit >>= return . Logger handle
+
+-- | uses stdout handle
+makeDefaultLogger :: IO Logger
+makeDefaultLogger = makeLogger stdout
 
--- | Flush the logger (blocks until flushed)
---
 flushLogger :: Logger -> IO ()
-flushLogger logger = do
-    writeChan (loggerChan logger) Nothing
-    () <- takeMVar $ loggerSync logger
-    return ()
+flushLogger = hFlush . loggerHandle
+
+logMsg :: Logger -> [LogStr] -> IO ()
+logMsg = hPutLogStr . loggerHandle
 
--- | Send a raw message to the logger
---   Native format is lazy text
 logLazyText :: Logger -> TL.Text -> IO ()
-logLazyText logger = writeChan (loggerChan logger) . Just
+logLazyText logger msg = logMsg logger $
+  map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
 
 logText :: Logger -> Text -> IO ()
-logText logger = logLazyText logger . TL.fromStrict
+logText logger = logBS logger . encodeUtf8
+
+logBS :: Logger -> ByteString -> IO ()
+logBS logger msg = logMsg logger [LB msg, newLine]
 
 logString :: Logger -> String -> IO ()
-logString logger = logLazyText logger . TL.pack
+logString logger msg = logMsg logger [LS msg, newLine]
+
+formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr]
+formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)
+
+toLB :: Text -> LogStr
+toLB = LB . encodeUtf8
+
+formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr]
+formatLogMsg logger loc level msg = do
+    date <- liftIO $ getDate $ loggerDateRef logger
+    return
+        [ LB date
+        , LB $ pack" ["
+        , LS (drop 5 $ show level)
+        , LB $ pack "] "
+        , msg
+        , LB $ pack " @("
+        , LS (fileLocationToString loc)
+        , LB $ pack ") "
+        ]
+
+newLine :: LogStr
+newLine = LB $ pack "\"\n"
 
 -- | Execute a monadic action and log the duration
 --

yesod-core/yesod-core.cabal

@@ -76,10 +76,10 @@ library
                    , directory             >= 1        && < 1.2
                    , data-object           >= 0.3      && < 0.4
                    , data-object-yaml      >= 0.3      && < 0.4
-                   -- for logger. Probably logger should be a separate package
-                   , strict-concurrency    >= 0.2.4    && < 0.2.5
                    , vector                >= 0.9      && < 0.10
                    , aeson                 >= 0.3
+                   , fast-logger           >= 0.0.1
+                   , wai-logger            >= 0.0.1
 
     exposed-modules: Yesod.Content
                      Yesod.Core

yesod-default/Yesod/Default/Main.hs

@@ -9,7 +9,7 @@ module Yesod.Default.Main
 
 import Yesod.Core hiding (AppConfig (..))
 import Yesod.Default.Config
-import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)
+import Yesod.Logger (Logger, makeDefaultLogger, logString, logLazyText, flushLogger)
 import Network.Wai (Application)
 import Network.Wai.Handler.Warp
     (runSettings, defaultSettings, settingsPort, settingsHost)
@@ -46,7 +46,7 @@ defaultMain :: (Show env, Read env)
             -> IO ()
 defaultMain load withSite = do
     config <- load
-    logger <- makeLogger
+    logger <- makeDefaultLogger
     withSite config logger $ runSettings defaultSettings
         { settingsHost = "0.0.0.0"
         , settingsPort = appPort config
@@ -109,7 +109,7 @@ defaultDevelAppWith :: (Show env, Read env)
                     -> ((Int, Application) -> IO ()) -> IO ()
 defaultDevelAppWith load withSite f = do
         conf   <- load
-        logger <- makeLogger
+        logger <- makeDefaultLogger
         let p = appPort conf
         logString logger $ "Devel application launched, listening on port " ++ show p
         withSite conf logger $ \app -> f (p, debugHandle (logHandle logger) app)

yesod/scaffold/Foundation.hs.cg

@@ -23,7 +23,7 @@ import Yesod.Auth
 import Yesod.Auth.OpenId
 import Yesod.Default.Config
 import Yesod.Default.Util (addStaticContentExternal)
-import Yesod.Logger (Logger, logLazyText)
+import Yesod.Logger (Logger, writeLogMsg, formatLogText, logLazyText)
 import qualified Settings
 import qualified Data.ByteString.Lazy as L
 import qualified Database.Persist.Base
@@ -108,7 +108,7 @@ instance Yesod ~sitearg~ where
     authRoute _ = Just $ AuthR LoginR
 
     messageLogger y loc level msg =
-      formatLogMessage loc level msg >>= logLazyText (getLogger y)
+      formatLogText (getLogger y) loc level msg >>= writeLogMsg (getLogger y)
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows

yesod/scaffold/tiny/Foundation.hs.cg

@@ -18,7 +18,7 @@ import Yesod.Default.Config
 import Yesod.Default.Util (addStaticContentExternal)
 import Yesod.Static (Static, base64md5, StaticRoute(..))
 import Settings.StaticFiles
-import Yesod.Logger (Logger, logLazyText)
+import Yesod.Logger (Logger, writeLogMsg, formatLogText, logLazyText)
 import qualified Settings
 import Settings (widgetFile)
 import Control.Monad.Trans.Class (lift)
@@ -89,7 +89,7 @@ instance Yesod ~sitearg~ where
     urlRenderOverride _ _ = Nothing
 
     messageLogger y loc level msg =
-      formatLogMessage loc level msg >>= logLazyText (getLogger y)
+      formatLogText (getLogger y) loc level msg >>= writeLogMsg (getLogger y)
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows