Updated fast-logger/wai-logger
This commit is contained in:
parent
9fdb8c9d2d
commit
ddd1059983
@ -60,11 +60,7 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
|||||||
import Data.Monoid (mempty)
|
import Data.Monoid (mempty)
|
||||||
|
|
||||||
import Text.Hamlet (Html)
|
import Text.Hamlet (Html)
|
||||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
|
||||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||||
#else
|
|
||||||
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
|
|
||||||
#endif
|
|
||||||
import Data.String (IsString (fromString))
|
import Data.String (IsString (fromString))
|
||||||
import Network.Wai (FilePart)
|
import Network.Wai (FilePart)
|
||||||
import Data.Conduit (Source, ResourceT, Flush)
|
import Data.Conduit (Source, ResourceT, Flush)
|
||||||
|
|||||||
@ -20,8 +20,6 @@ module Yesod.Core
|
|||||||
, unauthorizedI
|
, unauthorizedI
|
||||||
-- * Logging
|
-- * Logging
|
||||||
, LogLevel (..)
|
, LogLevel (..)
|
||||||
, formatLogMessage
|
|
||||||
, fileLocationToString
|
|
||||||
, logDebug
|
, logDebug
|
||||||
, logInfo
|
, logInfo
|
||||||
, logWarn
|
, logWarn
|
||||||
@ -59,38 +57,7 @@ import Yesod.Request
|
|||||||
import Yesod.Widget
|
import Yesod.Widget
|
||||||
import Yesod.Message
|
import Yesod.Message
|
||||||
|
|
||||||
import Language.Haskell.TH.Syntax
|
import System.Log.FastLogger
|
||||||
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
|
|
||||||
|
|
||||||
-- | Return an 'Unauthorized' value, with the given i18n message.
|
-- | Return an 'Unauthorized' value, with the given i18n message.
|
||||||
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
|
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
|
||||||
|
|||||||
@ -28,7 +28,7 @@ module Yesod.Dispatch
|
|||||||
, WaiSubsite (..)
|
, WaiSubsite (..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Functor ((<$>))
|
import Control.Applicative ((<$>), (<*>))
|
||||||
import Prelude hiding (exp)
|
import Prelude hiding (exp)
|
||||||
import Yesod.Internal.Core
|
import Yesod.Internal.Core
|
||||||
import Yesod.Handler hiding (lift)
|
import Yesod.Handler hiding (lift)
|
||||||
@ -53,6 +53,7 @@ import Network.HTTP.Types (status301)
|
|||||||
import Yesod.Routes.TH
|
import Yesod.Routes.TH
|
||||||
import Yesod.Content (chooseRep)
|
import Yesod.Content (chooseRep)
|
||||||
import Yesod.Routes.Parse
|
import Yesod.Routes.Parse
|
||||||
|
import System.Log.FastLogger (Logger)
|
||||||
|
|
||||||
type Texts = [Text]
|
type Texts = [Text]
|
||||||
|
|
||||||
@ -119,7 +120,13 @@ mkYesodGeneral name args clazzes isSub resS = do
|
|||||||
let res = map (fmap parseType) resS
|
let res = map (fmap parseType) resS
|
||||||
renderRouteDec <- mkRenderRouteInstance arg res
|
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 master = mkName "master"
|
||||||
let ctx = if isSub
|
let ctx = if isSub
|
||||||
then ClassP (mkName "Yesod") [VarT master] : clazzes
|
then ClassP (mkName "Yesod") [VarT master] : clazzes
|
||||||
@ -160,23 +167,24 @@ toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
|
|||||||
toWaiAppPlain :: ( Yesod master
|
toWaiAppPlain :: ( Yesod master
|
||||||
, YesodDispatch master master
|
, YesodDispatch master master
|
||||||
) => master -> IO W.Application
|
) => master -> IO W.Application
|
||||||
toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a
|
toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a
|
||||||
|
|
||||||
|
|
||||||
toWaiApp' :: ( Yesod master
|
toWaiApp' :: ( Yesod master
|
||||||
, YesodDispatch master master
|
, YesodDispatch master master
|
||||||
)
|
)
|
||||||
=> master
|
=> master
|
||||||
|
-> Logger
|
||||||
-> Maybe (SessionBackend master)
|
-> Maybe (SessionBackend master)
|
||||||
-> W.Application
|
-> W.Application
|
||||||
toWaiApp' y sb env =
|
toWaiApp' y logger sb env =
|
||||||
case cleanPath y $ W.pathInfo env of
|
case cleanPath y $ W.pathInfo env of
|
||||||
Left pieces -> sendRedirect y pieces env
|
Left pieces -> sendRedirect y pieces env
|
||||||
Right pieces ->
|
Right pieces ->
|
||||||
yesodDispatch y y id app404 handler405 method pieces sb env
|
yesodDispatch logger y y id app404 handler405 method pieces sb env
|
||||||
where
|
where
|
||||||
app404 = yesodRunner notFound y y Nothing id
|
app404 = yesodRunner logger notFound y y Nothing id
|
||||||
handler405 route = yesodRunner badMethod y y (Just route) id
|
handler405 route = yesodRunner logger badMethod y y (Just route) id
|
||||||
method = decodeUtf8With lenientDecode $ W.requestMethod env
|
method = decodeUtf8With lenientDecode $ W.requestMethod env
|
||||||
|
|
||||||
sendRedirect :: Yesod master => master -> [Text] -> W.Application
|
sendRedirect :: Yesod master => master -> [Text] -> W.Application
|
||||||
@ -202,4 +210,4 @@ instance RenderRoute WaiSubsite where
|
|||||||
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
|
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
|
||||||
|
|
||||||
instance YesodDispatch WaiSubsite master where
|
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 qualified Network.HTTP.Types as H
|
||||||
|
|
||||||
import Text.Hamlet
|
import Text.Hamlet
|
||||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
|
||||||
import qualified Text.Blaze.Html.Renderer.Text as RenderText
|
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 qualified Data.Text as T
|
||||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
||||||
import Data.Text.Encoding.Error (lenientDecode)
|
import Data.Text.Encoding.Error (lenientDecode)
|
||||||
@ -165,12 +161,10 @@ import Blaze.ByteString.Builder (toByteString)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Yesod.Message (RenderMessage (..))
|
import Yesod.Message (RenderMessage (..))
|
||||||
|
|
||||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
|
||||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||||
#define preEscapedText preEscapedToMarkup
|
#define preEscapedText preEscapedToMarkup
|
||||||
#else
|
|
||||||
import Text.Blaze (toHtml, preEscapedText)
|
import System.Log.FastLogger
|
||||||
#endif
|
|
||||||
|
|
||||||
import qualified Yesod.Internal.Cache as Cache
|
import qualified Yesod.Internal.Cache as Cache
|
||||||
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
|
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
|
||||||
@ -183,6 +177,7 @@ import Control.Monad.Base
|
|||||||
import Yesod.Routes.Class
|
import Yesod.Routes.Class
|
||||||
import Data.Word (Word64)
|
import Data.Word (Word64)
|
||||||
import Data.Conduit (Sink)
|
import Data.Conduit (Sink)
|
||||||
|
import Language.Haskell.TH.Syntax (Loc)
|
||||||
|
|
||||||
class YesodSubRoute s y where
|
class YesodSubRoute s y where
|
||||||
fromSubRoute :: s -> y -> Route s -> Route y
|
fromSubRoute :: s -> y -> Route s -> Route y
|
||||||
@ -196,6 +191,7 @@ data HandlerData sub master = HandlerData
|
|||||||
, handlerToMaster :: Route sub -> Route master
|
, handlerToMaster :: Route sub -> Route master
|
||||||
, handlerState :: I.IORef GHState
|
, handlerState :: I.IORef GHState
|
||||||
, handlerUpload :: Word64 -> FileUpload
|
, handlerUpload :: Word64 -> FileUpload
|
||||||
|
, handlerLog :: Loc -> LogLevel -> LogStr -> IO ()
|
||||||
}
|
}
|
||||||
|
|
||||||
handlerSubData :: (Route sub -> Route master)
|
handlerSubData :: (Route sub -> Route master)
|
||||||
@ -396,8 +392,9 @@ runHandler :: HasReps c
|
|||||||
-> master
|
-> master
|
||||||
-> sub
|
-> sub
|
||||||
-> (Word64 -> FileUpload)
|
-> (Word64 -> FileUpload)
|
||||||
|
-> (Loc -> LogLevel -> LogStr -> IO ())
|
||||||
-> YesodApp
|
-> YesodApp
|
||||||
runHandler handler mrender sroute tomr master sub upload =
|
runHandler handler mrender sroute tomr master sub upload log' =
|
||||||
YesodApp $ \eh rr cts initSession -> do
|
YesodApp $ \eh rr cts initSession -> do
|
||||||
let toErrorHandler e =
|
let toErrorHandler e =
|
||||||
case fromException e of
|
case fromException e of
|
||||||
@ -419,6 +416,7 @@ runHandler handler mrender sroute tomr master sub upload =
|
|||||||
, handlerToMaster = tomr
|
, handlerToMaster = tomr
|
||||||
, handlerState = istate
|
, handlerState = istate
|
||||||
, handlerUpload = upload
|
, handlerUpload = upload
|
||||||
|
, handlerLog = log'
|
||||||
}
|
}
|
||||||
contents' <- catch (fmap Right $ unGHandler handler hd)
|
contents' <- catch (fmap Right $ unGHandler handler hd)
|
||||||
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
||||||
@ -792,6 +790,7 @@ handlerToYAR :: (HasReps a, HasReps b)
|
|||||||
=> master -- ^ master site foundation
|
=> master -- ^ master site foundation
|
||||||
-> sub -- ^ sub site foundation
|
-> sub -- ^ sub site foundation
|
||||||
-> (Word64 -> FileUpload)
|
-> (Word64 -> FileUpload)
|
||||||
|
-> (Loc -> LogLevel -> LogStr -> IO ())
|
||||||
-> (Route sub -> Route master)
|
-> (Route sub -> Route master)
|
||||||
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
||||||
-> (ErrorResponse -> GHandler sub master a)
|
-> (ErrorResponse -> GHandler sub master a)
|
||||||
@ -800,11 +799,11 @@ handlerToYAR :: (HasReps a, HasReps b)
|
|||||||
-> SessionMap
|
-> SessionMap
|
||||||
-> GHandler sub master b
|
-> GHandler sub master b
|
||||||
-> ResourceT IO YesodAppResult
|
-> 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
|
unYesodApp ya eh' rr types sessionMap
|
||||||
where
|
where
|
||||||
ya = runHandler h 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
|
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
|
||||||
types = httpAccept $ reqWaiRequest rr
|
types = httpAccept $ reqWaiRequest rr
|
||||||
errorHandler' = localNoCurrent . errorHandler
|
errorHandler' = localNoCurrent . errorHandler
|
||||||
|
|
||||||
@ -957,3 +956,8 @@ instance MonadResource (GHandler sub master) where
|
|||||||
register = lift . register
|
register = lift . register
|
||||||
release = lift . release
|
release = lift . release
|
||||||
resourceMask = lift . resourceMask
|
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
|
, defaultErrorHandler
|
||||||
-- * Data types
|
-- * Data types
|
||||||
, AuthResult (..)
|
, AuthResult (..)
|
||||||
-- * Logging
|
|
||||||
, LogLevel (..)
|
|
||||||
, formatLogMessage
|
|
||||||
, fileLocationToString
|
|
||||||
, messageLoggerHandler
|
|
||||||
-- * Sessions
|
-- * Sessions
|
||||||
, SessionBackend (..)
|
, SessionBackend (..)
|
||||||
, defaultClientSessionBackend
|
, defaultClientSessionBackend
|
||||||
@ -82,10 +77,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
|||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import qualified Network.HTTP.Types as H
|
import qualified Network.HTTP.Types as H
|
||||||
import Web.Cookie (SetCookie (..))
|
import Web.Cookie (SetCookie (..))
|
||||||
import qualified Data.Text.Lazy as TL
|
import Language.Haskell.TH.Syntax (Loc (..))
|
||||||
import qualified Data.Text.Lazy.IO
|
|
||||||
import qualified Data.Text.Lazy.Builder as TB
|
|
||||||
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
|
|
||||||
import Text.Blaze (preEscapedToMarkup)
|
import Text.Blaze (preEscapedToMarkup)
|
||||||
import Data.Aeson (Value (Array, String))
|
import Data.Aeson (Value (Array, String))
|
||||||
import Data.Aeson.Encode (encode)
|
import Data.Aeson.Encode (encode)
|
||||||
@ -94,6 +86,9 @@ import Network.Wai.Middleware.Gzip (GzipSettings, def)
|
|||||||
import Network.Wai.Parse (tempFileSink, lbsSink)
|
import Network.Wai.Parse (tempFileSink, lbsSink)
|
||||||
import qualified Paths_yesod_core
|
import qualified Paths_yesod_core
|
||||||
import Data.Version (showVersion)
|
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 :: String
|
||||||
yesodVersion = showVersion Paths_yesod_core.version
|
yesodVersion = showVersion Paths_yesod_core.version
|
||||||
@ -103,7 +98,8 @@ yesodVersion = showVersion Paths_yesod_core.version
|
|||||||
class YesodDispatch sub master where
|
class YesodDispatch sub master where
|
||||||
yesodDispatch
|
yesodDispatch
|
||||||
:: Yesod master
|
:: Yesod master
|
||||||
=> master
|
=> Logger
|
||||||
|
-> master
|
||||||
-> sub
|
-> sub
|
||||||
-> (Route sub -> Route master)
|
-> (Route sub -> Route master)
|
||||||
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
|
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
|
||||||
@ -114,7 +110,8 @@ class YesodDispatch sub master where
|
|||||||
-> W.Application
|
-> W.Application
|
||||||
|
|
||||||
yesodRunner :: Yesod master
|
yesodRunner :: Yesod master
|
||||||
=> GHandler sub master ChooseRep
|
=> Logger
|
||||||
|
-> GHandler sub master ChooseRep
|
||||||
-> master
|
-> master
|
||||||
-> sub
|
-> sub
|
||||||
-> Maybe (Route sub)
|
-> Maybe (Route sub)
|
||||||
@ -285,21 +282,28 @@ $doctype 5
|
|||||||
cookieDomain _ = Nothing
|
cookieDomain _ = Nothing
|
||||||
|
|
||||||
-- | Maximum allowed length of the request body, in bytes.
|
-- | Maximum allowed length of the request body, in bytes.
|
||||||
|
--
|
||||||
|
-- Default: 2 megabytes.
|
||||||
maximumContentLength :: a -> Maybe (Route a) -> Word64
|
maximumContentLength :: a -> Maybe (Route a) -> Word64
|
||||||
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
|
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
|
messageLogger :: a
|
||||||
|
-> Logger
|
||||||
-> Loc -- ^ position in source code
|
-> Loc -- ^ position in source code
|
||||||
-> LogLevel
|
-> LogLevel
|
||||||
-> Text -- ^ message
|
-> LogStr -- ^ message
|
||||||
-> IO ()
|
-> IO ()
|
||||||
messageLogger a loc level msg =
|
messageLogger a logger loc level msg =
|
||||||
if level < logLevel a
|
if level < logLevel a
|
||||||
then return ()
|
then return ()
|
||||||
else
|
else formatLogMessage (loggerDateRef logger) loc level msg >>= loggerPutStr logger
|
||||||
formatLogMessage loc level msg >>=
|
|
||||||
Data.Text.Lazy.IO.putStrLn
|
|
||||||
|
|
||||||
-- | The logging level in place for this application. Any messages below
|
-- | The logging level in place for this application. Any messages below
|
||||||
-- this level will simply be ignored.
|
-- this level will simply be ignored.
|
||||||
@ -338,37 +342,23 @@ $doctype 5
|
|||||||
| size > 50000 = FileUploadDisk tempFileSink
|
| size > 50000 = FileUploadDisk tempFileSink
|
||||||
| otherwise = FileUploadMemory lbsSink
|
| otherwise = FileUploadMemory lbsSink
|
||||||
|
|
||||||
messageLoggerHandler :: Yesod m
|
formatLogMessage :: DateRef
|
||||||
=> Loc -> LogLevel -> Text -> GHandler s m ()
|
-> Loc
|
||||||
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
|
|
||||||
-> LogLevel
|
-> LogLevel
|
||||||
-> Text -- ^ message
|
-> LogStr -- ^ message
|
||||||
-> IO TL.Text
|
-> IO [LogStr]
|
||||||
formatLogMessage loc level msg = do
|
formatLogMessage dateref loc level msg = do
|
||||||
now <- getCurrentTime
|
now <- getDate dateref
|
||||||
return $ TB.toLazyText $
|
return
|
||||||
TB.fromText (T.pack $ show now)
|
[ LB now
|
||||||
`mappend` TB.fromText " ["
|
, LB " ["
|
||||||
`mappend` TB.fromText (T.pack $ drop 5 $ show level)
|
, LS $ drop 5 $ show level
|
||||||
`mappend` TB.fromText "] "
|
, LB "] "
|
||||||
`mappend` TB.fromText msg
|
, msg
|
||||||
`mappend` TB.fromText " @("
|
, LB " @("
|
||||||
`mappend` TB.fromText (T.pack $ fileLocationToString loc)
|
, LS $ fileLocationToString loc
|
||||||
`mappend` TB.fromText ") "
|
, LB ")\n"
|
||||||
|
]
|
||||||
|
|
||||||
-- taken from file-location package
|
-- taken from file-location package
|
||||||
-- turn the TH Loc loaction information into a human readable string
|
-- 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
|
char = show . snd . loc_start
|
||||||
|
|
||||||
defaultYesodRunner :: Yesod master
|
defaultYesodRunner :: Yesod master
|
||||||
=> GHandler sub master ChooseRep
|
=> Logger
|
||||||
|
-> GHandler sub master ChooseRep
|
||||||
-> master
|
-> master
|
||||||
-> sub
|
-> sub
|
||||||
-> Maybe (Route sub)
|
-> Maybe (Route sub)
|
||||||
-> (Route sub -> Route master)
|
-> (Route sub -> Route master)
|
||||||
-> Maybe (SessionBackend master)
|
-> Maybe (SessionBackend master)
|
||||||
-> W.Application
|
-> 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 =
|
| maximumContentLength master (fmap toMasterRoute murl) < len =
|
||||||
return $ W.responseLBS
|
return $ W.responseLBS
|
||||||
(H.Status 413 "Too Large")
|
(H.Status 413 "Too Large")
|
||||||
@ -419,7 +410,8 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req
|
|||||||
handler
|
handler
|
||||||
let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
|
let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
|
||||||
let ra = resolveApproot master req
|
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
|
(yesodRender master ra) errorHandler rr murl sessionMap h
|
||||||
extraHeaders <- case yar of
|
extraHeaders <- case yar of
|
||||||
(YARPlain _ _ ct _ newSess) -> do
|
(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 Control.Exception (throwIO)
|
||||||
import qualified Text.Hamlet as NP
|
import qualified Text.Hamlet as NP
|
||||||
import Data.Text.Lazy.Builder (fromLazyText)
|
import Data.Text.Lazy.Builder (fromLazyText)
|
||||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
|
||||||
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
||||||
import qualified Data.Text.Lazy as TL
|
import qualified Data.Text.Lazy as TL
|
||||||
#else
|
|
||||||
import Text.Blaze (toHtml, preEscapedLazyText)
|
|
||||||
#endif
|
|
||||||
import Control.Monad.Base (MonadBase (liftBase))
|
import Control.Monad.Base (MonadBase (liftBase))
|
||||||
import Control.Arrow (first)
|
import Control.Arrow (first)
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
|
|
||||||
#if MIN_VERSION_blaze_html(0, 5, 0)
|
import System.Log.FastLogger
|
||||||
|
|
||||||
preEscapedLazyText :: TL.Text -> Html
|
preEscapedLazyText :: TL.Text -> Html
|
||||||
preEscapedLazyText = preEscapedToMarkup
|
preEscapedLazyText = preEscapedToMarkup
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | A generic widget, allowing specification of both the subsite and master
|
-- | A generic widget, allowing specification of both the subsite and master
|
||||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
-- 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
|
register = lift . register
|
||||||
release = lift . release
|
release = lift . release
|
||||||
resourceMask = lift . resourceMask
|
resourceMask = lift . resourceMask
|
||||||
|
|
||||||
|
instance MonadLogging (GWidget sub master) where
|
||||||
|
monadLoggingLog a b = lift . monadLoggingLog a b
|
||||||
|
|||||||
@ -5,7 +5,7 @@
|
|||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Network.Wai.Handler.Warp (run)
|
import Network.Wai.Handler.Warp (run)
|
||||||
import Data.Text (unpack)
|
import Data.Text (unpack, pack)
|
||||||
import Text.Julius (julius)
|
import Text.Julius (julius)
|
||||||
|
|
||||||
data Subsite = Subsite String
|
data Subsite = Subsite String
|
||||||
@ -22,13 +22,13 @@ getSubRootR = do
|
|||||||
Subsite s <- getYesodSub
|
Subsite s <- getYesodSub
|
||||||
tm <- getRouteToMaster
|
tm <- getRouteToMaster
|
||||||
render <- getUrlRender
|
render <- getUrlRender
|
||||||
$(logDebug) "I'm in SubRootR"
|
$logDebug "I'm in SubRootR"
|
||||||
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
|
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
|
||||||
|
|
||||||
handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
|
handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
|
||||||
handleSubMultiR x = do
|
handleSubMultiR x = do
|
||||||
Subsite y <- getYesodSub
|
Subsite y <- getYesodSub
|
||||||
$(logInfo) "In SubMultiR"
|
$logInfo "In SubMultiR"
|
||||||
return . RepPlain . toContent . show $ (x, y)
|
return . RepPlain . toContent . show $ (x, y)
|
||||||
|
|
||||||
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
|
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
|
||||||
@ -38,7 +38,7 @@ mkYesod "HelloWorld" [parseRoutes|
|
|||||||
|]
|
|]
|
||||||
instance Yesod HelloWorld where
|
instance Yesod HelloWorld where
|
||||||
addStaticContent a b c = do
|
addStaticContent a b c = do
|
||||||
liftIO $ print (a, b, c)
|
$logInfo $ pack $ show (a, b, c)
|
||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
getRootR = do
|
getRootR = do
|
||||||
|
|||||||
@ -26,7 +26,7 @@ instance RenderRoute Subsite where
|
|||||||
renderRoute (SubsiteRoute x) = (x, [])
|
renderRoute (SubsiteRoute x) = (x, [])
|
||||||
|
|
||||||
instance YesodDispatch Subsite master where
|
instance YesodDispatch Subsite master where
|
||||||
yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
|
yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS
|
||||||
status200
|
status200
|
||||||
[ ("Content-Type", "SUBSITE")
|
[ ("Content-Type", "SUBSITE")
|
||||||
] $ L8.pack $ show pieces
|
] $ L8.pack $ show pieces
|
||||||
|
|||||||
@ -24,7 +24,9 @@ mkYesod "App" [parseRoutes|
|
|||||||
instance Yesod App
|
instance Yesod App
|
||||||
|
|
||||||
getHomeR :: Handler RepHtml
|
getHomeR :: Handler RepHtml
|
||||||
getHomeR = defaultLayout $ toWidget [hamlet|
|
getHomeR = do
|
||||||
|
$logDebug "Testing logging"
|
||||||
|
defaultLayout $ toWidget [hamlet|
|
||||||
$doctype 5
|
$doctype 5
|
||||||
|
|
||||||
<html>
|
<html>
|
||||||
|
|||||||
@ -77,8 +77,7 @@ library
|
|||||||
, directory >= 1 && < 1.2
|
, directory >= 1 && < 1.2
|
||||||
, vector >= 0.9 && < 0.10
|
, vector >= 0.9 && < 0.10
|
||||||
, aeson >= 0.5
|
, aeson >= 0.5
|
||||||
, fast-logger >= 0.0.2
|
, fast-logger >= 0.1 && < 0.2
|
||||||
, wai-logger >= 0.0.1
|
|
||||||
, conduit >= 0.5 && < 0.6
|
, conduit >= 0.5 && < 0.6
|
||||||
, resourcet >= 0.3 && < 0.4
|
, resourcet >= 0.3 && < 0.4
|
||||||
, lifted-base >= 0.1 && < 0.2
|
, lifted-base >= 0.1 && < 0.2
|
||||||
@ -89,7 +88,6 @@ library
|
|||||||
Yesod.Core
|
Yesod.Core
|
||||||
Yesod.Dispatch
|
Yesod.Dispatch
|
||||||
Yesod.Handler
|
Yesod.Handler
|
||||||
Yesod.Logger
|
|
||||||
Yesod.Request
|
Yesod.Request
|
||||||
Yesod.Widget
|
Yesod.Widget
|
||||||
Yesod.Message
|
Yesod.Message
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user