Base.hs

{-# LANGUAGE OverloadedStrings, TemplateHaskell, RankNTypes, TypeFamilies #-}

module System.Log.Simple.Base (
	Level(..), level, level_,
	Component(..), Scope(..),
	Message(..),
	Converter, Consumer, consumer,
	LogHandler, handler,
	LogConfig(..), defCfg, logCfg, componentCfg, componentLevel,
	Log(..),
	newLog, rootLog, getLog, subLog, getLogConfig, updateLogConfig, updateLogHandlers, writeLog, stopLog,
	) where

import Prelude.Unicode

import Control.Applicative
import Control.Arrow
import qualified Control.Exception as E
import Control.Concurrent
import qualified Control.Concurrent.Async as A
import Control.DeepSeq
import Control.Monad
import Control.Monad.Cont
import Data.Default
import Data.Function (fix)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import Data.String
import Lens.Micro.Platform
import Lens.Micro.Internal
import Text.Format


-- Helper function
splitBy ∷ Char → Text → [Text]
splitBy _ "" = []
splitBy ch t = T.split (≡ ch) t



-- | Level of message
data Level = Trace | Debug | Info | Warning | Error | Fatal
	deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Default Level where
	def = Trace

instance Formattable Level where
	formattable Trace _ = "TRACE" `withFlags` ["gray"]
	formattable Debug _ = "DEBUG" `withFlags` ["yellow"]
	formattable Info _ = "INFO" `withFlags` ["blue"]
	formattable Warning _ = "WARN" `withFlags` ["darkyellow"]
	formattable Error _ = "ERROR" `withFlags` ["red"]
	formattable Fatal _ = "FATAL" `withFlags` ["bg=red"]

-- | Component — each one have separate log scopes and can have different politics
-- Child component's root politics inherits its parent root politics
-- Component name parts stored in reverse order
newtype Component = Component { componentPath ∷ [Text] } deriving (Eq, Ord)

instance Show Component where
	show = T.unpack ∘ T.intercalate "." ∘ reverse ∘ componentPath

instance Formattable Component

instance Read Component where
	readsPrec _ = return ∘ flip (,) "" ∘ Component ∘ reverse ∘ splitBy '.' ∘ T.pack

instance IsString Component where
	fromString = read

instance Semigroup Component where
	Component l <> Component r = Component $ r ++ l

instance Monoid Component where
	mempty = Component []
	Component l `mappend` Component r = Component $ r ++ l

instance NFData Component where
	rnf (Component cs) = rnf cs

-- | Log scope, also stored in reverse order
newtype Scope = Scope { scopePath ∷ [Text] } deriving (Eq, Ord)

instance Show Scope where
	show = T.unpack ∘ T.intercalate "/" ∘ reverse ∘ scopePath

instance Formattable Scope

instance Read Scope where
	readsPrec _ = return ∘ flip (,) "" ∘ Scope ∘ reverse ∘ splitBy '/' ∘ T.pack

instance IsString Scope where
	fromString = read

instance Semigroup Scope where
	Scope l <> Scope r = Scope $ r ++ l

instance Monoid Scope where
	mempty = Scope []
	Scope l `mappend` Scope r = Scope $ r ++ l

instance NFData Scope where
	rnf (Scope s) = rnf s

class HasParent a where
	getParent ∷ a → Maybe a

instance HasParent Component where
	getParent (Component []) = Nothing
	getParent (Component (_:cs)) = Just $ Component cs

instance HasParent Scope where
	getParent (Scope []) = Nothing
	getParent (Scope (_:ps)) = Just $ Scope ps

-- | Parse level
level ∷ Text → Maybe Level
level = flip M.lookup levels ∘ T.toLower where
	levels = M.fromList [(T.toLower ∘ T.pack ∘ show $ l', l') | l' ← [minBound .. maxBound]]

-- | Parse level, failing on invalid input
level_ ∷ Text → Level
level_ t = fromMaybe (error errMsg) ∘ level $ t where
	errMsg = "invalid level: " ++ T.unpack t

-- | Log message
data Message = Message {
	messageTime ∷ ZonedTime,
	messageLevel ∷ Level,
	messageComponent ∷ Component,
	messageScope ∷ Scope,
	messageText ∷ Text }
		deriving (Read, Show)

instance NFData Message where
	rnf (Message t l c s m) = t `seq` l  `seq` rnf c `seq` rnf s `seq` rnf m

type Converter a = Message → a

-- | Returns function which accepts consumed value
type Consumer a = ContT () IO (a → IO ())

-- | Make consumer
consumer ∷ (((a → IO ()) → IO ()) → IO ()) → Consumer a
consumer = ContT

-- | Message handler
type LogHandler = Consumer Message

handler ∷ Converter a → Consumer a → Consumer Message
handler conv = fmap (∘ conv)

data LogConfig = LogConfig {
	_logConfigMap ∷ Map Component Level }

makeLenses ''LogConfig

instance Default LogConfig where
	def = LogConfig mempty

instance Show LogConfig where
	show (LogConfig cfg) = unlines [show comp ++ ":" ++ show lev | (comp, lev) ← M.toList cfg]

type instance Index LogConfig = Component
type instance IxValue LogConfig = Level

instance Ixed LogConfig where
	ix n = logConfigMap ∘ ix n

instance At LogConfig where
	at n = logConfigMap ∘ at n

-- | Default log config — info level
defCfg ∷ LogConfig
defCfg = def

-- | Make log config by list of components and levels
logCfg ∷ [(Component, Level)] → LogConfig
logCfg = LogConfig ∘ M.fromList

-- | Component config level lens
componentCfg ∷ Component → Lens' LogConfig (Maybe Level)
componentCfg comp = logConfigMap . at comp

-- | Get politics for specified component
componentLevel ∷ LogConfig → Component → Level
componentLevel cfg comp = fromMaybe def $ (cfg ^. componentCfg comp) <|> (componentLevel cfg <$> getParent comp)

-- | Log
data Log = Log {
	-- | Current log component
	logComponent ∷ Component,
	-- | Current log scope
	logScope ∷ Scope,
	-- | Log message, it is low-level function, i.e. it doesn't take into account current component and scope and writes message as is
	logPost ∷ Message → IO (),
	-- | Stop log and wait until it writes all
	logStop ∷ IO (),
	-- | Log config
	logConfig ∷ MVar LogConfig,
	-- | Handlers list
	logHandlers ∷ MVar [LogHandler],
	-- | Restart all handlers
	logRestartHandlers ∷ IO () }

type FChan a = Chan (Maybe a)

writeFChan ∷ FChan a → a → IO ()
writeFChan ch = writeChan ch ∘ Just

stopFChan ∷ FChan a → IO ()
stopFChan ch = writeChan ch Nothing

-- | Create log, returns root logger for root component
--
-- Messages from distinct threads and components are splitted in several chans, where they are processed, and then messages combined back and sent to log-thread
--
newLog ∷ LogConfig → [LogHandler] → IO Log
newLog cfg handlers = do
	ch ← newChan ∷ IO (FChan Message)
	cfgVar ← newMVar cfg
	handlersVar ← newMVar handlers
	handlersThread ← newEmptyMVar

	let
		-- | Pass message firther if it passes config
		passMessage ∷ (Message → IO ()) → Message → IO ()
		passMessage fn msg = do
			cfg' ← readMVar cfgVar
			when (componentLevel cfg' (messageComponent msg) ≤ messageLevel msg) $ fn msg

		fatalMsg ∷ String → IO Message
		fatalMsg s = do
			tm ← getZonedTime
			return $ Message tm Fatal "*" "" $ fromString s

		-- | Perform log
		tryLog ∷ (Message → IO ()) → Message → IO ()
		tryLog logMsg m = E.handle onError (m `deepseq` logMsg m) where
			onError ∷ E.SomeException → IO ()
			onError e = E.handle ignoreError $ fatalMsg ("Exception during logging message: " ++ show e) >>= logMsg
			ignoreError ∷ E.SomeException → IO ()
			ignoreError _ = return ()

		-- | Consume messages and send to handlers
		runHandlers ∷ FChan Message → [LogHandler] → ContT () IO ()
		runHandlers inCh hs = do
			hs' ← sequence $ map (fmap tryLog) hs
			fix $ \loop' → do
				msg ← liftIO $ readChan inCh
				case msg of
					Just msg' → liftIO (mapM_ ($ msg') hs') >> loop'
					Nothing → return ()

		-- | Start handlers thread
		startHandlers ∷ IO (A.Async ())
		startHandlers = readMVar handlersVar >>= A.async ∘ flip runContT return ∘ runHandlers ch

		-- | Restart handlers thread
		restartHandlers ∷ IO ()
		restartHandlers = modifyMVar_ handlersThread $ \th → A.cancel th >> startHandlers

		-- | Write message with myThreadId
		writeMessage ∷ Message → IO ()
		writeMessage = passMessage (writeFChan ch)

		waitHandlers ∷ IO ()
		waitHandlers = readMVar handlersThread >>= A.wait

	startHandlers >>= putMVar handlersThread
	return $ Log {
		logComponent = mempty,
		logScope = mempty,
		logPost = writeMessage,
		logStop = stopFChan ch >> waitHandlers,
		logConfig = cfgVar,
		logHandlers = handlersVar,
		logRestartHandlers = restartHandlers }

-- | Get root log, i.e. just drop current component and scope
rootLog ∷ Log → Log
rootLog l = l { logComponent = mempty, logScope = mempty }

-- | Get log for specified component and scope
getLog ∷ Component → Scope → Log → Log
getLog comp scope l = l { logComponent = comp, logScope = scope }

-- | Get sub-log
subLog ∷ Component → Scope → Log → Log
subLog comp scope l = l {
	logComponent = logComponent l `mappend` comp,
	logScope = logScope l `mappend` scope }

-- | Read log config
getLogConfig ∷ MonadIO m ⇒ Log → m LogConfig
getLogConfig l = liftIO $ readMVar (logConfig l)

-- | Modify log config
updateLogConfig ∷ MonadIO m ⇒ Log → (LogConfig → LogConfig) → m LogConfig
updateLogConfig l update = liftIO $ modifyMVar (logConfig l) (return ∘ (update &&& id))

-- | Update log handlers, this restarts handlers thread
updateLogHandlers ∷ MonadIO m ⇒ Log → ([LogHandler] → [LogHandler]) → m ()
updateLogHandlers l update = liftIO $ modifyMVar_ (logHandlers l) (return ∘ update) >> logRestartHandlers l

-- | Write message to log for current component and scope
writeLog ∷ MonadIO m ⇒ Log → Level → Text → m ()
writeLog l lev msg = liftIO $ do
	tm ← getZonedTime
	logPost l $ Message tm lev (logComponent l) (logScope l) msg

-- | Wait log messages and stop log
stopLog ∷ MonadIO m ⇒ Log → m ()
stopLog = liftIO ∘ logStop