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.Monad               (when)
import           Data.Generics.Product.Typed
import           Data.Typeable
import           Lens.Micro                  (set)
import           Lens.Micro.Extras           (view)
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