Handler.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications      #-}

module Logging.Class.Handler ( SomeHandler(..), Handler(..) ) where

import           Control.Exception           (SomeException, catch)
import           Control.Lens                (set, view)
import           Control.Monad               (when)
import           Data.Generics.Product.Typed
import           Data.Typeable
import           Prelude                     hiding (filter)
import           Text.Format

import           Logging.Class.Filterable
import           Logging.Filter
import           Logging.Level
import           Logging.Record


-- | Generalised 'Handler' instance, it wraps all other 'Handler' instances
-- into one type.
--
-- The 'SomeHandler' type is the root of the handler type hierarchy.
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 Format1 SomeHandler where
  getTyped (SomeHandler h) = view (typed @Format1) h
  setTyped v (SomeHandler h) = SomeHandler $ set (typed @Format1) v h

instance Eq SomeHandler where
  (SomeHandler h1) == h2 = Just h1 == fromHandler h2

instance Handler SomeHandler where
  open (SomeHandler h) = open h
  emit (SomeHandler h) = emit h
  close (SomeHandler h) = close h
  handle (SomeHandler h) = handle h
  fromHandler = Just . id
  toHandler = id


-- |A type class that abstracts the characteristics of a 'Handler'
class ( HasType Level a
      , HasType Filterer a
      , HasType Format1 a
      , Typeable a
      , Eq a
      ) => Handler a where

  -- | Initialize the 'Handler' instance
  open :: a -> IO ()
  open _ = return ()

  -- | Emit log event, prepare log data, and send to bancked.
  --
  -- e.g. 1) Format 'LogRecord' into data in specific format (json, html, etc.),
  -- 2) write the data to a file or send the data to a server.
  emit :: a -> LogRecord -> IO ()

  -- | Terminate the 'Handler' instance
  close :: a -> IO ()
  close _ = return ()

  -- | Handle 'LogRecord' and decide whether to call 'emit'.
  --
  -- The default implementation is to filter 'LogRecord' by level and
  -- "Handler"'s filterer, if rejected, do nothing and return False,
  -- otherwise call emit and return True.
  --
  -- Note: You can override the default implementation.
  handle :: a -> LogRecord -> IO Bool
  handle hdl rcd@LogRecord{level=level', message=message}
      | level' < view (typed @Level) hdl = return False
      | not (filter (view (typed @Filterer) hdl) rcd) = return False
      | otherwise = catch (emit hdl rcd >> return True) handleError
    where
      -- TODO How to test
      handleError :: SomeException -> IO Bool
      handleError e = do
        putStrLn "--- Logging error ---"
        putStrLn $ show e
        putStrLn $ "Message: " ++ message
        return False

  fromHandler :: SomeHandler -> Maybe a
  fromHandler (SomeHandler h) = cast h

  toHandler :: a -> SomeHandler
  toHandler = SomeHandler