{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Logging.Types
( Logger(..)
, Level(..)
, LogRecord(..)
, Filter(..)
, Filterer
, Formatter(..)
, StreamHandler(..)
, HandlerT(..)
, Sink(..)
, Manager(..)
, Filterable(..)
, Formattable(..)
, Handler(..)
) where
import Control.Concurrent.MVar (MVar, putMVar, takeMVar)
import Control.Exception (bracket)
import Control.Monad (unless, when)
import Data.Default
import Data.List (stripPrefix)
import Data.Map.Lazy (Map)
import Data.String
import Data.Time.Clock
import qualified Data.Time.Format as TF
import Data.Time.LocalTime
import Language.Haskell.TH.Syntax (Lift)
import Prelude hiding (filter)
import System.FilePath
import System.IO
import Text.Printf (printf)
type Logger = String
newtype Level = Level Int deriving (Lift, Eq, Ord)
instance Show Level where
show (Level 0) = "NOTSET"
show (Level 10) = "DEBUG"
show (Level 20) = "INFO"
show (Level 30) = "WARN"
show (Level 40) = "ERROR"
show (Level 50) = "FATAL"
show (Level v) = "LEVEL " ++ show v
instance Read Level where
readsPrec _ "NOTSET" = [(Level 0, "")]
readsPrec _ "DEBUG" = [(Level 10, "")]
readsPrec _ "INFO" = [(Level 20, "")]
readsPrec _ "WARN" = [(Level 30, "")]
readsPrec _ "ERROR" = [(Level 40, "")]
readsPrec _ "FATAL" = [(Level 50, "")]
readsPrec _ s = case (stripPrefix "LEVEL " s) of
Just v -> [(Level (read v), "")]
_ -> []
instance IsString Level where
fromString = read
instance Enum Level where
toEnum = Level
fromEnum (Level v) = v
instance Default Level where
def = "NOTSET"
data LogRecord = LogRecord { logger :: Logger
, level :: Level
, message :: String
, filename :: String
, packagename :: String
, modulename :: String
, lineno :: Int
, created :: ZonedTime
}
data Filter = Filter { name :: String
, nlen :: Int
}
instance IsString Filter where
fromString s = Filter s $ length s
instance Eq Filter where
(==) f s = (==) (name f) (name s)
type Filterer = [Filter]
data Formatter = Formatter { fmt :: String
, datefmt :: String
} deriving (Eq)
instance Default Formatter where
def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z"
data StreamHandler = StreamHandler { stream :: Handle
, level :: Level
, filterer :: Filterer
, formatter :: Formatter
, lock :: MVar ()
}
data HandlerT where
HandlerT :: Handler a => a -> HandlerT
data Sink = Sink { logger :: Logger
, level :: Level
, filterer :: Filterer
, handlers :: [HandlerT]
, disabled :: Bool
, propagate :: Bool
}
data Manager = Manager { root :: Sink
, sinks :: Map String Sink
, disabled :: Bool
, catchUncaughtException :: Bool
}
class Filterable a where
filter :: a -> LogRecord -> Bool
instance Filterable a => Filterable [a] where
filter [] _ = True
filter (f:fs) rcd = (filter f) rcd && (filter fs rcd)
instance Filterable Filter where
filter f rcd@LogRecord{..}
| (nlen f) == 0 = True
| otherwise = case stripPrefix (name f) logger of
Just "" -> True
Just ('.':_) -> True
_ -> False
instance Filterable Sink where
filter Sink{..} = filter filterer
class Formattable a where
format :: a -> LogRecord -> String
formatTime :: a -> LogRecord -> String
instance Formattable Formatter where
format f@Formatter{..} rcd@LogRecord{..} = formats fmt
where
formats :: String -> String
formats ('%':'%':cs) = ('%' :) $ formats cs
formats ('%':'(':cs) =
case break (== ')') cs of
(attr, ')':c:cs') -> (formatAttr attr c) ++ (formats cs')
_ -> error "Logging.Types.Formattable: no parse (Formatter)"
formats (c:cs) = (c :) $ formats cs
formats "" = ""
formatAttr :: String -> Char -> String
formatAttr "logger" fc = printf ['%', fc] logger
formatAttr "level" fc = printf ['%', fc] $ show level
formatAttr "pathname" fc = printf ['%', fc] $ takeDirectory filename
formatAttr "filename" fc = printf ['%', fc] $ takeFileName filename
formatAttr "module" fc = printf ['%', fc] modulename
formatAttr "lineno" fc = printf ['%', fc] lineno
formatAttr "created" fc = printf ['%', fc] $ toTimestamp created
formatAttr "asctime" fc = printf ['%', fc] $ formatTime f rcd
formatAttr "msecs" fc = printf ['%', fc] $ toMilliseconds created
formatAttr "message" fc = printf ['%', fc] message
formatAttr _ _ = "unknown"
utcZero :: UTCTime
utcZero = read "1970-01-01 00:00:00 UTC"
toTimestamp :: ZonedTime -> Double
toTimestamp lt = fromRational $ toRational $ diffUTCTime (zonedTimeToUTC lt) utcZero
toMilliseconds :: ZonedTime -> Integer
toMilliseconds lt = round $ (toTimestamp lt) * 1000
formatTime Formatter{..} LogRecord{..} =
TF.formatTime TF.defaultTimeLocale datefmt created
class Handler a where
getLevel :: a -> Level
setLevel :: a -> Level -> a
getFilterer :: a -> Filterer
setFilterer :: a -> Filterer -> a
getFormatter :: a -> Formatter
setFormatter :: a -> Formatter -> a
acquire :: a -> IO ()
release :: a -> IO ()
with :: a -> (a -> IO b) -> IO b
with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l)
emit :: a -> LogRecord -> IO ()
flush :: a -> IO ()
close :: a -> IO ()
handle :: a -> LogRecord -> IO Bool
handle hdl rcd = do
let rv = filter (getFilterer hdl) rcd
when rv $ with hdl (`emit` rcd)
return rv
instance Handler StreamHandler where
getLevel = level
setLevel h v = h { level = v }
getFilterer = filterer
setFilterer h f = h { filterer = f }
getFormatter = formatter
setFormatter h f = h { formatter = f }
acquire = takeMVar . lock
release = (`putMVar` ()) . lock
emit hdl rcd = do
hPutStrLn (stream hdl) $ format (getFormatter hdl) rcd
flush hdl
flush = hFlush . stream
close StreamHandler{..} = do
isClosed <- hIsClosed stream
unless isClosed $ hIsTerminalDevice stream >>= (`unless` (hClose stream))