Types.hs

{-# 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)

-- |'Logger' is just a name.
type Logger = String


-- |'Level' also known as severity, a higher 'Level' means a bigger 'Int'.
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"


-- |A 'LogRecord' represents an event being logged.
--
-- 'LogRecord's are created every time something is logged. They
-- contain all the information related to the event being logged.
--
-- It includes the main message as well as information such as
-- when the record was created, the source line where the logging call was made.
--
data LogRecord = LogRecord { logger      :: Logger
                           , level       :: Level
                           , message     :: String
                           , filename    :: String
                           , packagename :: String
                           , modulename  :: String
                           , lineno      :: Int
                           , created     :: ZonedTime
                           }


-- | 'Filter's are used to perform arbitrary filtering of 'LogRecord's.
--
-- 'Sink's and 'Handler's can optionally use 'Filter' to filter records
-- as desired. It allows events which are below a certain point in the
-- sink hierarchy. For example, a filter initialized with "A.B" will allow
-- events logged by loggers "A.B", "A.B.C", "A.B.C.D", "A.B.D" etc.
-- but not "A.BB", "B.A.B" etc.
-- If initialized name with the empty string, all events are passed.
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)


-- |List of Filter
type Filterer = [Filter]


-- |'Formatter's are used to convert a LogRecord to text.
--
-- 'Formatter's need to know how a 'LogRecord' is constructed. They are
-- responsible for converting a 'LogRecord' to (usually) a string which can
-- be interpreted by either a human or an external system. The base 'Formatter'
-- allows a formatting string to be specified. If none is supplied, the
-- default value, "%(message)s" is used.
--
--
-- The 'Formatter' can be initialized with a format string which makes use of
-- knowledge of the 'LogRecord' attributes - e.g. the default value mentioned
-- above makes use of a 'LogRecord''s message attribute. Currently, the useful
-- attributes in a 'LogRecord' are described by:
--
-- [@%(logger)s@]     Name of the logger (logging channel)
-- [@%(level)s@]      Numeric logging level for the message (DEBUG, INFO, WARN,
--                    ERROR, FATAL, LEVEL v)
-- [@%(pathname)s@]   Full pathname of the source file where the logging
--                    call was issued (if available)
-- [@%(filename)s@]   Filename portion of pathname
-- [@%(module)s@]     Module (name portion of filename)
-- [@%(lineno)d@]     Source line number where the logging call was issued
--                    (if available)
-- [@%(created)f@]    Time when the LogRecord was created (picoseconds
--                    since '1970-01-01 00:00:00')
-- [@%(asctime)s@]    Textual time when the 'LogRecord' was created
-- [@%(msecs)d@]      Millisecond portion of the creation time
-- [@%(message)s@]    The main message passed to 'logv' 'debug' 'info' ..
--
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"


-- | A handler type which writes logging records, appropriately formatted,
-- to a stream.
--
-- Note that this class does not close the stream when the stream is a
-- terminal device, e.g. 'stderr' and 'stdout'.
--
data StreamHandler = StreamHandler { stream    :: Handle
                                   , level     :: Level
                                   , filterer  :: Filterer
                                   , formatter :: Formatter
                                   , lock      :: MVar ()
                                   }


-- |A GADT represents any 'Handler' instance
data HandlerT where
  HandlerT :: Handler a => a -> HandlerT


-- |'Sink' represents a single logging channel.
--
-- A "logging channel" indicates an area of an application. Exactly how an
-- "area" is defined is up to the application developer. Since an
-- application can have any number of areas, logging channels are identified
-- by a unique string. Application areas can be nested (e.g. an area
-- of "input processing" might include sub-areas "read CSV files", "read
-- XLS files" and "read Gnumeric files"). To cater for this natural nesting,
-- channel names are organized into a namespace hierarchy where levels are
-- separated by periods, much like the  Haskell module namespace. So
-- in the instance given above, channel names might be "Input" for the upper
-- level, and "Input.Csv", "Input.Xls" and "Input.Gnu" for the sub-levels.
-- There is no arbitrary limit to the depth of nesting.
--
-- Note: The namespaces are case sensitive.
--
data Sink = Sink { logger    :: Logger
                 , level     :: Level
                 , filterer  :: Filterer
                 , handlers  :: [HandlerT]
                 , disabled  :: Bool
                 , propagate :: Bool
                 }


-- |There is __under normal circumstances__ just one Manager,
-- which holds the hierarchy of sinks.
data Manager = Manager { root                   :: Sink
                       , sinks                  :: Map String Sink
                       , disabled               :: Bool
                       , catchUncaughtException :: Bool
                       }


-- |A class represents a common trait of filtering 'LogRecord's
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 -- filter name == record logger
                    Just ('.':_) -> True -- filter name is record logger's child
                    _            -> False

instance Filterable Sink where
  filter Sink{..} = filter filterer


-- |A class represents a common trait of formatting 'LogRecord' as 'String'.
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 -- %(logger)s
      formatAttr "level" fc    = printf ['%', fc] $ show level -- %(level)s
      formatAttr "pathname" fc = printf ['%', fc] $ takeDirectory filename -- %(pathname)s
      formatAttr "filename" fc = printf ['%', fc] $ takeFileName filename -- %(filename)s
      formatAttr "module" fc   = printf ['%', fc] modulename -- %(module)s
      formatAttr "lineno" fc   = printf ['%', fc] lineno -- %(lineno)d
      formatAttr "created" fc  = printf ['%', fc] $ toTimestamp created -- %(created)f
      formatAttr "asctime" fc  = printf ['%', fc] $ formatTime f rcd -- %(asctime)s
      formatAttr "msecs" fc    = printf ['%', fc] $ toMilliseconds created -- %(msecs)d
      formatAttr "message" fc  = printf ['%', fc] message -- %(message)s
      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


-- |A type class that abstracts the characteristics of a 'Handler'
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))