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