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

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


-- |'Level' also known as severity, a higher 'Level' means a bigger 'Int'.
--
-- There are 5 common severity levels:
--
-- [@DEBUG@] Level 10
-- [@INFO@] Level 20
-- [@WARN@] Level 30
-- [@ERROR@] Level 40
-- [@FATAL@] Level 50
--
-- >>> :set -XOverloadedStrings
-- >>> "DEBUG" :: Level
-- DEBUG
-- >>> "DEBUG" == (Level 10)
-- True
--
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"


-- |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.
newtype Filter = Filter Logger deriving (Read, Show, Eq)

instance IsString Filter where
  fromString = Filter


-- |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 -- ^ see "Data.Time.Format"
                           } deriving (Eq)

instance Default Formatter where
  def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z"


type Lock = MVar ()


-- |The 'SomeHandler' type is the root of the handler type hierarchy.
-- It hold the real 'Handler' instance
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


-- | 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'.
--
-- Note: 'FileHandler' is an alias of 'StreamHandler'
data StreamHandler = StreamHandler { stream    :: Handle
                                   , level     :: Level
                                   , filterer  :: Filterer
                                   , formatter :: Formatter
                                   , lock      :: Lock
                                   } deriving (Generic)


-- |'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  :: [SomeHandler]
                 , disabled  :: Bool
                 , propagate :: Bool -- ^ It will pop up until root or the
                                     -- ancestor's propagation is disabled
                 }


-- |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 (Filter self) rcd@LogRecord{..}
    | self == "" = True
    | otherwise = case stripPrefix self logger of
                    Just ""      -> True   -- self == logger
                    Just ('.':_) -> True   -- self == parent logger
                    _            -> 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 ( 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))