diff --git a/yesod-core/Yesod/Logger.hs b/yesod-core/Yesod/Logger.hs index 3ec47f69..eb9f8ba9 100644 --- a/yesod-core/Yesod/Logger.hs +++ b/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 -- diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 38963689..38e2ba1a 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 diff --git a/yesod-default/Yesod/Default/Main.hs b/yesod-default/Yesod/Default/Main.hs index c8f08ce9..c9f09c57 100644 --- a/yesod-default/Yesod/Default/Main.hs +++ b/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) diff --git a/yesod/scaffold/Foundation.hs.cg b/yesod/scaffold/Foundation.hs.cg index a92fb5c9..153b96ec 100644 --- a/yesod/scaffold/Foundation.hs.cg +++ b/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 diff --git a/yesod/scaffold/tiny/Foundation.hs.cg b/yesod/scaffold/tiny/Foundation.hs.cg index 17326b0b..37c14cd0 100644 --- a/yesod/scaffold/tiny/Foundation.hs.cg +++ b/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