Updated fast-logger/wai-logger
This commit is contained in:
Michael Snoyman
parent
9fdb8c9d2d
commit
ddd1059983
@ -60,11 +60,7 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
import Text.Hamlet (Html)
|
||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
#else
|
||||
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
|
||||
#endif
|
||||
import Data.String (IsString (fromString))
|
||||
import Network.Wai (FilePart)
|
||||
import Data.Conduit (Source, ResourceT, Flush)
|
||||
|
||||
@ -20,8 +20,6 @@ module Yesod.Core
|
||||
, unauthorizedI
|
||||
-- * Logging
|
||||
, LogLevel (..)
|
||||
, formatLogMessage
|
||||
, fileLocationToString
|
||||
, logDebug
|
||||
, logInfo
|
||||
, logWarn
|
||||
@ -59,38 +57,7 @@ import Yesod.Request
|
||||
import Yesod.Widget
|
||||
import Yesod.Message
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
import Data.Text (Text)
|
||||
|
||||
logTH :: LogLevel -> Q Exp
|
||||
logTH level =
|
||||
[|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|]
|
||||
where
|
||||
liftLoc :: Loc -> Q Exp
|
||||
liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|]
|
||||
|
||||
-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
|
||||
--
|
||||
-- > $(logDebug) "This is a debug log message"
|
||||
logDebug :: Q Exp
|
||||
logDebug = logTH LevelDebug
|
||||
|
||||
-- | See 'logDebug'
|
||||
logInfo :: Q Exp
|
||||
logInfo = logTH LevelInfo
|
||||
-- | See 'logDebug'
|
||||
logWarn :: Q Exp
|
||||
logWarn = logTH LevelWarn
|
||||
-- | See 'logDebug'
|
||||
logError :: Q Exp
|
||||
logError = logTH LevelError
|
||||
|
||||
-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
|
||||
--
|
||||
-- > $(logOther "My new level") "This is a log message"
|
||||
logOther :: Text -> Q Exp
|
||||
logOther = logTH . LevelOther
|
||||
import System.Log.FastLogger
|
||||
|
||||
-- | Return an 'Unauthorized' value, with the given i18n message.
|
||||
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
|
||||
|
||||
@ -28,7 +28,7 @@ module Yesod.Dispatch
|
||||
, WaiSubsite (..)
|
||||
) where
|
||||
|
||||
import Data.Functor ((<$>))
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Internal.Core
|
||||
import Yesod.Handler hiding (lift)
|
||||
@ -53,6 +53,7 @@ import Network.HTTP.Types (status301)
|
||||
import Yesod.Routes.TH
|
||||
import Yesod.Content (chooseRep)
|
||||
import Yesod.Routes.Parse
|
||||
import System.Log.FastLogger (Logger)
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
@ -119,7 +120,13 @@ mkYesodGeneral name args clazzes isSub resS = do
|
||||
let res = map (fmap parseType) resS
|
||||
renderRouteDec <- mkRenderRouteInstance arg res
|
||||
|
||||
disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
|
||||
let logger = mkName "logger"
|
||||
Clause pat body decs <- mkDispatchClause
|
||||
[|yesodRunner $(return $ VarE logger)|]
|
||||
[|yesodDispatch $(return $ VarE logger)|]
|
||||
[|fmap chooseRep|]
|
||||
res
|
||||
let disp = Clause (VarP logger : pat) body decs
|
||||
let master = mkName "master"
|
||||
let ctx = if isSub
|
||||
then ClassP (mkName "Yesod") [VarT master] : clazzes
|
||||
@ -160,23 +167,24 @@ toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
|
||||
toWaiAppPlain :: ( Yesod master
|
||||
, YesodDispatch master master
|
||||
) => master -> IO W.Application
|
||||
toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a
|
||||
toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a
|
||||
|
||||
|
||||
toWaiApp' :: ( Yesod master
|
||||
, YesodDispatch master master
|
||||
)
|
||||
=> master
|
||||
-> Logger
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
toWaiApp' y sb env =
|
||||
toWaiApp' y logger sb env =
|
||||
case cleanPath y $ W.pathInfo env of
|
||||
Left pieces -> sendRedirect y pieces env
|
||||
Right pieces ->
|
||||
yesodDispatch y y id app404 handler405 method pieces sb env
|
||||
yesodDispatch logger y y id app404 handler405 method pieces sb env
|
||||
where
|
||||
app404 = yesodRunner notFound y y Nothing id
|
||||
handler405 route = yesodRunner badMethod y y (Just route) id
|
||||
app404 = yesodRunner logger notFound y y Nothing id
|
||||
handler405 route = yesodRunner logger badMethod y y (Just route) id
|
||||
method = decodeUtf8With lenientDecode $ W.requestMethod env
|
||||
|
||||
sendRedirect :: Yesod master => master -> [Text] -> W.Application
|
||||
@ -202,4 +210,4 @@ instance RenderRoute WaiSubsite where
|
||||
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
|
||||
|
||||
instance YesodDispatch WaiSubsite master where
|
||||
yesodDispatch _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
|
||||
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
|
||||
|
||||
@ -138,11 +138,7 @@ import qualified Network.Wai as W
|
||||
import qualified Network.HTTP.Types as H
|
||||
|
||||
import Text.Hamlet
|
||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
||||
import qualified Text.Blaze.Html.Renderer.Text as RenderText
|
||||
#else
|
||||
import qualified Text.Blaze.Renderer.Text as RenderText
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
@ -165,12 +161,10 @@ import Blaze.ByteString.Builder (toByteString)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||
#define preEscapedText preEscapedToMarkup
|
||||
#else
|
||||
import Text.Blaze (toHtml, preEscapedText)
|
||||
#endif
|
||||
|
||||
import System.Log.FastLogger
|
||||
|
||||
import qualified Yesod.Internal.Cache as Cache
|
||||
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
|
||||
@ -183,6 +177,7 @@ import Control.Monad.Base
|
||||
import Yesod.Routes.Class
|
||||
import Data.Word (Word64)
|
||||
import Data.Conduit (Sink)
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
|
||||
class YesodSubRoute s y where
|
||||
fromSubRoute :: s -> y -> Route s -> Route y
|
||||
@ -196,6 +191,7 @@ data HandlerData sub master = HandlerData
|
||||
, handlerToMaster :: Route sub -> Route master
|
||||
, handlerState :: I.IORef GHState
|
||||
, handlerUpload :: Word64 -> FileUpload
|
||||
, handlerLog :: Loc -> LogLevel -> LogStr -> IO ()
|
||||
}
|
||||
|
||||
handlerSubData :: (Route sub -> Route master)
|
||||
@ -396,8 +392,9 @@ runHandler :: HasReps c
|
||||
-> master
|
||||
-> sub
|
||||
-> (Word64 -> FileUpload)
|
||||
-> (Loc -> LogLevel -> LogStr -> IO ())
|
||||
-> YesodApp
|
||||
runHandler handler mrender sroute tomr master sub upload =
|
||||
runHandler handler mrender sroute tomr master sub upload log' =
|
||||
YesodApp $ \eh rr cts initSession -> do
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
@ -419,6 +416,7 @@ runHandler handler mrender sroute tomr master sub upload =
|
||||
, handlerToMaster = tomr
|
||||
, handlerState = istate
|
||||
, handlerUpload = upload
|
||||
, handlerLog = log'
|
||||
}
|
||||
contents' <- catch (fmap Right $ unGHandler handler hd)
|
||||
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
||||
@ -792,6 +790,7 @@ handlerToYAR :: (HasReps a, HasReps b)
|
||||
=> master -- ^ master site foundation
|
||||
-> sub -- ^ sub site foundation
|
||||
-> (Word64 -> FileUpload)
|
||||
-> (Loc -> LogLevel -> LogStr -> IO ())
|
||||
-> (Route sub -> Route master)
|
||||
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
||||
-> (ErrorResponse -> GHandler sub master a)
|
||||
@ -800,11 +799,11 @@ handlerToYAR :: (HasReps a, HasReps b)
|
||||
-> SessionMap
|
||||
-> GHandler sub master b
|
||||
-> ResourceT IO YesodAppResult
|
||||
handlerToYAR y s upload toMasterRoute render errorHandler rr murl sessionMap h =
|
||||
handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =
|
||||
unYesodApp ya eh' rr types sessionMap
|
||||
where
|
||||
ya = runHandler h render murl toMasterRoute y s upload
|
||||
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload
|
||||
ya = runHandler h render murl toMasterRoute y s upload log'
|
||||
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
|
||||
types = httpAccept $ reqWaiRequest rr
|
||||
errorHandler' = localNoCurrent . errorHandler
|
||||
|
||||
@ -957,3 +956,8 @@ instance MonadResource (GHandler sub master) where
|
||||
register = lift . register
|
||||
release = lift . release
|
||||
resourceMask = lift . resourceMask
|
||||
|
||||
instance MonadLogging (GHandler sub master) where
|
||||
monadLoggingLog a b c = do
|
||||
hd <- ask
|
||||
liftIO $ handlerLog hd a b (toLogStr c)
|
||||
|
||||
@ -20,11 +20,6 @@ module Yesod.Internal.Core
|
||||
, defaultErrorHandler
|
||||
-- * Data types
|
||||
, AuthResult (..)
|
||||
-- * Logging
|
||||
, LogLevel (..)
|
||||
, formatLogMessage
|
||||
, fileLocationToString
|
||||
, messageLoggerHandler
|
||||
-- * Sessions
|
||||
, SessionBackend (..)
|
||||
, defaultClientSessionBackend
|
||||
@ -82,10 +77,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import Data.List (foldl')
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.IO
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
|
||||
import Language.Haskell.TH.Syntax (Loc (..))
|
||||
import Text.Blaze (preEscapedToMarkup)
|
||||
import Data.Aeson (Value (Array, String))
|
||||
import Data.Aeson.Encode (encode)
|
||||
@ -94,6 +86,9 @@ import Network.Wai.Middleware.Gzip (GzipSettings, def)
|
||||
import Network.Wai.Parse (tempFileSink, lbsSink)
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import System.Log.FastLogger (LogLevel (LevelInfo), Logger, mkLogger, loggerDateRef, LogStr (..), loggerPutStr)
|
||||
import System.Log.FastLogger.Date (getDate, DateRef)
|
||||
import System.IO (stdout)
|
||||
|
||||
yesodVersion :: String
|
||||
yesodVersion = showVersion Paths_yesod_core.version
|
||||
@ -103,7 +98,8 @@ yesodVersion = showVersion Paths_yesod_core.version
|
||||
class YesodDispatch sub master where
|
||||
yesodDispatch
|
||||
:: Yesod master
|
||||
=> master
|
||||
=> Logger
|
||||
-> master
|
||||
-> sub
|
||||
-> (Route sub -> Route master)
|
||||
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
|
||||
@ -114,7 +110,8 @@ class YesodDispatch sub master where
|
||||
-> W.Application
|
||||
|
||||
yesodRunner :: Yesod master
|
||||
=> GHandler sub master ChooseRep
|
||||
=> Logger
|
||||
-> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
@ -285,21 +282,28 @@ $doctype 5
|
||||
cookieDomain _ = Nothing
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes.
|
||||
--
|
||||
-- Default: 2 megabytes.
|
||||
maximumContentLength :: a -> Maybe (Route a) -> Word64
|
||||
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
|
||||
|
||||
-- | Send a message to the log. By default, prints to stdout.
|
||||
-- | Returns a @Logger@ to use for log messages.
|
||||
--
|
||||
-- Default: Sends to stdout and automatically flushes on each write.
|
||||
getLogger :: a -> IO Logger
|
||||
getLogger _ = mkLogger True stdout
|
||||
|
||||
-- | Send a message to the @Logger@ provided by @getLogger@.
|
||||
messageLogger :: a
|
||||
-> Logger
|
||||
-> Loc -- ^ position in source code
|
||||
-> LogLevel
|
||||
-> Text -- ^ message
|
||||
-> LogStr -- ^ message
|
||||
-> IO ()
|
||||
messageLogger a loc level msg =
|
||||
messageLogger a logger loc level msg =
|
||||
if level < logLevel a
|
||||
then return ()
|
||||
else
|
||||
formatLogMessage loc level msg >>=
|
||||
Data.Text.Lazy.IO.putStrLn
|
||||
else formatLogMessage (loggerDateRef logger) loc level msg >>= loggerPutStr logger
|
||||
|
||||
-- | The logging level in place for this application. Any messages below
|
||||
-- this level will simply be ignored.
|
||||
@ -338,37 +342,23 @@ $doctype 5
|
||||
| size > 50000 = FileUploadDisk tempFileSink
|
||||
| otherwise = FileUploadMemory lbsSink
|
||||
|
||||
messageLoggerHandler :: Yesod m
|
||||
=> Loc -> LogLevel -> Text -> GHandler s m ()
|
||||
messageLoggerHandler loc level msg = do
|
||||
y <- getYesod
|
||||
liftIO $ messageLogger y loc level msg
|
||||
|
||||
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
|
||||
deriving (Eq, Show, Read, Ord)
|
||||
|
||||
instance Lift LogLevel where
|
||||
lift LevelDebug = [|LevelDebug|]
|
||||
lift LevelInfo = [|LevelInfo|]
|
||||
lift LevelWarn = [|LevelWarn|]
|
||||
lift LevelError = [|LevelError|]
|
||||
lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
|
||||
|
||||
formatLogMessage :: Loc
|
||||
formatLogMessage :: DateRef
|
||||
-> Loc
|
||||
-> LogLevel
|
||||
-> Text -- ^ message
|
||||
-> IO TL.Text
|
||||
formatLogMessage loc level msg = do
|
||||
now <- getCurrentTime
|
||||
return $ TB.toLazyText $
|
||||
TB.fromText (T.pack $ show now)
|
||||
`mappend` TB.fromText " ["
|
||||
`mappend` TB.fromText (T.pack $ drop 5 $ show level)
|
||||
`mappend` TB.fromText "] "
|
||||
`mappend` TB.fromText msg
|
||||
`mappend` TB.fromText " @("
|
||||
`mappend` TB.fromText (T.pack $ fileLocationToString loc)
|
||||
`mappend` TB.fromText ") "
|
||||
-> LogStr -- ^ message
|
||||
-> IO [LogStr]
|
||||
formatLogMessage dateref loc level msg = do
|
||||
now <- getDate dateref
|
||||
return
|
||||
[ LB now
|
||||
, LB " ["
|
||||
, LS $ drop 5 $ show level
|
||||
, LB "] "
|
||||
, msg
|
||||
, LB " @("
|
||||
, LS $ fileLocationToString loc
|
||||
, LB ")\n"
|
||||
]
|
||||
|
||||
-- taken from file-location package
|
||||
-- turn the TH Loc loaction information into a human readable string
|
||||
@ -381,14 +371,15 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
|
||||
char = show . snd . loc_start
|
||||
|
||||
defaultYesodRunner :: Yesod master
|
||||
=> GHandler sub master ChooseRep
|
||||
=> Logger
|
||||
-> GHandler sub master ChooseRep
|
||||
-> master
|
||||
-> sub
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> Maybe (SessionBackend master)
|
||||
-> W.Application
|
||||
defaultYesodRunner handler master sub murl toMasterRoute msb req
|
||||
defaultYesodRunner logger handler master sub murl toMasterRoute msb req
|
||||
| maximumContentLength master (fmap toMasterRoute murl) < len =
|
||||
return $ W.responseLBS
|
||||
(H.Status 413 "Too Large")
|
||||
@ -419,7 +410,8 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req
|
||||
handler
|
||||
let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
|
||||
let ra = resolveApproot master req
|
||||
yar <- handlerToYAR master sub (fileUpload master) toMasterRoute
|
||||
let log' = messageLogger master logger
|
||||
yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
|
||||
(yesodRender master ra) errorHandler rr murl sessionMap h
|
||||
extraHeaders <- case yar of
|
||||
(YARPlain _ _ ct _ newSess) -> do
|
||||
|
||||
@ -1,138 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Yesod.Logger
|
||||
( Logger
|
||||
, handle
|
||||
, developmentLogger, productionLogger
|
||||
, defaultDevelopmentLogger, defaultProductionLogger
|
||||
, toProduction
|
||||
, flushLogger
|
||||
, logText
|
||||
, logLazyText
|
||||
, logString
|
||||
, logBS
|
||||
, logMsg
|
||||
, formatLogText
|
||||
, timed
|
||||
-- * Deprecated
|
||||
, makeLoggerWithHandle
|
||||
, makeDefaultLogger
|
||||
) where
|
||||
|
||||
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 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)
|
||||
|
||||
-- for formatter
|
||||
import Language.Haskell.TH.Syntax (Loc)
|
||||
import Yesod.Core (LogLevel, fileLocationToString)
|
||||
|
||||
data Logger = Logger {
|
||||
loggerLogFun :: [LogStr] -> IO ()
|
||||
, loggerHandle :: Handle
|
||||
, loggerDateRef :: DateRef
|
||||
}
|
||||
|
||||
handle :: Logger -> Handle
|
||||
handle = loggerHandle
|
||||
|
||||
flushLogger :: Logger -> IO ()
|
||||
flushLogger = hFlush . loggerHandle
|
||||
|
||||
makeDefaultLogger :: IO Logger
|
||||
makeDefaultLogger = defaultDevelopmentLogger
|
||||
{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-}
|
||||
|
||||
makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger
|
||||
makeLoggerWithHandle = productionLogger
|
||||
{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-}
|
||||
|
||||
-- | uses stdout handle
|
||||
defaultProductionLogger, defaultDevelopmentLogger :: IO Logger
|
||||
defaultProductionLogger = productionLogger stdout
|
||||
defaultDevelopmentLogger = developmentLogger stdout
|
||||
|
||||
|
||||
productionLogger h = mkLogger h (handleToLogFun h)
|
||||
-- | a development logger gets automatically flushed
|
||||
developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)
|
||||
|
||||
mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger
|
||||
mkLogger h logFun = do
|
||||
initHandle h
|
||||
dateInit >>= return . Logger logFun h
|
||||
|
||||
-- convert (a development) logger to production settings
|
||||
toProduction :: Logger -> Logger
|
||||
toProduction (Logger _ h d) = Logger (handleToLogFun h) h d
|
||||
|
||||
handleToLogFun :: Handle -> ([LogStr] -> IO ())
|
||||
handleToLogFun = hPutLogStr
|
||||
|
||||
logMsg :: Logger -> [LogStr] -> IO ()
|
||||
logMsg = hPutLogStr . handle
|
||||
|
||||
logLazyText :: Logger -> TL.Text -> IO ()
|
||||
logLazyText logger msg = loggerLogFun logger $
|
||||
map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
|
||||
|
||||
logText :: Logger -> Text -> IO ()
|
||||
logText logger = logBS logger . encodeUtf8
|
||||
|
||||
logBS :: Logger -> ByteString -> IO ()
|
||||
logBS logger msg = loggerLogFun logger $ [LB msg, newLine]
|
||||
|
||||
logString :: Logger -> String -> IO ()
|
||||
logString logger msg = loggerLogFun 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
|
||||
--
|
||||
timed :: MonadIO m
|
||||
=> Logger -- ^ Logger
|
||||
-> Text -- ^ Message
|
||||
-> m a -- ^ Action
|
||||
-> m a -- ^ Timed and logged action
|
||||
timed logger msg action = do
|
||||
start <- liftIO getCurrentTime
|
||||
!result <- action
|
||||
stop <- liftIO getCurrentTime
|
||||
let diff = fromEnum $ diffUTCTime stop start
|
||||
ms = diff `div` 10 ^ (9 :: Int)
|
||||
formatted = printf " [%4dms] %s" ms (unpack msg)
|
||||
liftIO $ logString logger formatted
|
||||
return result
|
||||
@ -81,20 +81,16 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Exception (throwIO)
|
||||
import qualified Text.Hamlet as NP
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
#else
|
||||
import Text.Blaze (toHtml, preEscapedLazyText)
|
||||
#endif
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad.Trans.Resource
|
||||
|
||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
||||
import System.Log.FastLogger
|
||||
|
||||
preEscapedLazyText :: TL.Text -> Html
|
||||
preEscapedLazyText = preEscapedToMarkup
|
||||
#endif
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
||||
@ -348,3 +344,6 @@ instance MonadResource (GWidget sub master) where
|
||||
register = lift . register
|
||||
release = lift . release
|
||||
resourceMask = lift . resourceMask
|
||||
|
||||
instance MonadLogging (GWidget sub master) where
|
||||
monadLoggingLog a b = lift . monadLoggingLog a b
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
import Yesod.Core
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Data.Text (unpack)
|
||||
import Data.Text (unpack, pack)
|
||||
import Text.Julius (julius)
|
||||
|
||||
data Subsite = Subsite String
|
||||
@ -22,13 +22,13 @@ getSubRootR = do
|
||||
Subsite s <- getYesodSub
|
||||
tm <- getRouteToMaster
|
||||
render <- getUrlRender
|
||||
$(logDebug) "I'm in SubRootR"
|
||||
$logDebug "I'm in SubRootR"
|
||||
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
|
||||
|
||||
handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
|
||||
handleSubMultiR x = do
|
||||
Subsite y <- getYesodSub
|
||||
$(logInfo) "In SubMultiR"
|
||||
$logInfo "In SubMultiR"
|
||||
return . RepPlain . toContent . show $ (x, y)
|
||||
|
||||
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
|
||||
@ -38,7 +38,7 @@ mkYesod "HelloWorld" [parseRoutes|
|
||||
|]
|
||||
instance Yesod HelloWorld where
|
||||
addStaticContent a b c = do
|
||||
liftIO $ print (a, b, c)
|
||||
$logInfo $ pack $ show (a, b, c)
|
||||
return Nothing
|
||||
|
||||
getRootR = do
|
||||
|
||||
@ -26,7 +26,7 @@ instance RenderRoute Subsite where
|
||||
renderRoute (SubsiteRoute x) = (x, [])
|
||||
|
||||
instance YesodDispatch Subsite master where
|
||||
yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
|
||||
yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS
|
||||
status200
|
||||
[ ("Content-Type", "SUBSITE")
|
||||
] $ L8.pack $ show pieces
|
||||
|
||||
@ -24,7 +24,9 @@ mkYesod "App" [parseRoutes|
|
||||
instance Yesod App
|
||||
|
||||
getHomeR :: Handler RepHtml
|
||||
getHomeR = defaultLayout $ toWidget [hamlet|
|
||||
getHomeR = do
|
||||
$logDebug "Testing logging"
|
||||
defaultLayout $ toWidget [hamlet|
|
||||
$doctype 5
|
||||
|
||||
<html>
|
||||
|
||||
@ -77,8 +77,7 @@ library
|
||||
, directory >= 1 && < 1.2
|
||||
, vector >= 0.9 && < 0.10
|
||||
, aeson >= 0.5
|
||||
, fast-logger >= 0.0.2
|
||||
, wai-logger >= 0.0.1
|
||||
, fast-logger >= 0.1 && < 0.2
|
||||
, conduit >= 0.5 && < 0.6
|
||||
, resourcet >= 0.3 && < 0.4
|
||||
, lifted-base >= 0.1 && < 0.2
|
||||
@ -89,7 +88,6 @@ library
|
||||
Yesod.Core
|
||||
Yesod.Dispatch
|
||||
Yesod.Handler
|
||||
Yesod.Logger
|
||||
Yesod.Request
|
||||
Yesod.Widget
|
||||
Yesod.Message
|
||||
|
||||
Loading…
Reference in New Issue
Block a user