{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Logging.Types
( Logger(..)
, Level(..)
, LogRecord(..)
, Filter(..)
, Filterer
, Formatter(..)
, SomeHandler(..)
, StreamHandler(..)
, Sink(..)
, Manager(..)
, Filterable(..)
, Formattable(..)
, Handler(..)
) where
import Control.Concurrent.MVar (MVar, putMVar, takeMVar)
import Control.Exception (bracket)
import Control.Lens (set, view)
import Control.Monad (unless, when)
import Data.Default
import Data.Generics.Product.Typed
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 Data.Typeable
import GHC.Generics
import Prelude hiding (filter)
import System.FilePath
import System.IO
import Text.Printf (printf)
type Logger = String
newtype Level = Level Int deriving (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
}
newtype Filter = Filter Logger deriving (Read, Show, Eq)
instance IsString Filter where
fromString = Filter
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"
type Lock = MVar ()
data SomeHandler where
SomeHandler :: Handler h => h -> SomeHandler
instance {-# OVERLAPPING #-} HasType Level SomeHandler where
getTyped (SomeHandler h) = view (typed @Level) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Level) v h
instance {-# OVERLAPPING #-} HasType Filterer SomeHandler where
getTyped (SomeHandler h) = view (typed @Filterer) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Filterer) v h
instance {-# OVERLAPPING #-} HasType Formatter SomeHandler where
getTyped (SomeHandler h) = view (typed @Formatter) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Formatter) v h
instance {-# OVERLAPPING #-} HasType Lock SomeHandler where
getTyped (SomeHandler h) = view (typed @Lock) h
setTyped v (SomeHandler h) = SomeHandler $ set (typed @Lock) v h
data StreamHandler = StreamHandler { stream :: Handle
, level :: Level
, filterer :: Filterer
, formatter :: Formatter
, lock :: Lock
} deriving (Generic)
data Sink = Sink { logger :: Logger
, level :: Level
, filterer :: Filterer
, handlers :: [SomeHandler]
, 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 (Filter self) rcd@LogRecord{..}
| self == "" = True
| otherwise = case stripPrefix self 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 ( HasType Level a
, HasType Filterer a
, HasType Formatter a
, HasType Lock a
, Typeable a
) => Handler a where
emit :: a -> LogRecord -> IO ()
flush :: a -> IO ()
flush _ = return ()
close :: a -> IO ()
close _ = return ()
handle :: a -> LogRecord -> IO Bool
handle hdl rcd = do
let rv = filter (view (typed @Filterer) hdl) rcd
when rv $ with hdl (`emit` rcd)
return rv
where
acquire :: a -> IO ()
acquire = takeMVar . (view $ typed @Lock)
release :: a -> IO ()
release = (`putMVar` ()) . (view $ typed @Lock)
with :: a -> (a -> IO b) -> IO b
with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l)
fromHandler :: SomeHandler -> Maybe a
fromHandler (SomeHandler h) = cast h
toHandler :: a -> SomeHandler
toHandler = SomeHandler
instance Handler SomeHandler where
emit (SomeHandler h) = emit h
flush (SomeHandler h) = flush h
close (SomeHandler h) = close h
fromHandler = Just . id
toHandler = id
instance Handler StreamHandler where
emit hdl rcd = do
hPutStrLn (stream hdl) $ format (view (typed @Formatter) hdl) rcd
flush hdl
flush = hFlush . stream
close StreamHandler{..} = do
isClosed <- hIsClosed stream
unless isClosed $ hIsTerminalDevice stream >>= (`unless` (hClose stream))