Thread.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Log.Logger.Handler
-- Copyright   :  (C) 2015 Flowbox
-- License     :  Apache-2.0
-- Maintainer  :  Wojciech Daniło <wojciech.danilo@gmail.com>
-- Stability   :  stable
-- Portability :  portable
-----------------------------------------------------------------------------

module System.Log.Logger.Thread where

import           System.Log.Data               (MonadRecord, appendRecord, Lvl(Lvl), readData, LevelData(LevelData), LookupDataSet)
import           System.Log.Logger.Handler     (MonadLoggerHandler(addHandler))
import           System.Log.Log                (LogFormat, MonadLogger)
import           System.Log.Logger.Base        (BaseLoggerT, runRawBaseLoggerT)
import           System.Log.Logger.Priority    (MonadPriorityLogger(getPriority,setPriority))
import           Control.Monad.Trans           (MonadTrans, lift)
import           Control.Monad.IO.Class        (MonadIO, liftIO)
import           Control.Applicative
import qualified Control.Monad.Reader          as Reader
import           Control.Monad.Reader          (ReaderT, runReaderT)
import           Control.Concurrent.Chan.Unagi (readChan, writeChan, newChan, InChan, OutChan)
import           Control.Exception             (throwIO, catch, SomeException)
import           Control.Concurrent            (forkIO)
import           Control.Concurrent.MVar       (newEmptyMVar, putMVar, takeMVar)


----------------------------------------------------------------------
-- ThreadedLoggerT
----------------------------------------------------------------------

newtype ThreadedLoggerT' d r m a = ThreadedLoggerT' { fromThreadedLoggerT :: ReaderT (InChan (ChMsg d r)) m a } deriving (Monad, MonadIO, Applicative, Functor, MonadTrans)
type ThreadedLoggerT d m a = ThreadedLoggerT' d a m a
type instance LogFormat (ThreadedLoggerT' d r m) = LogFormat m

data ChMsg m a = ChMsg (m ()) | End a | Exc SomeException

class MonadThreadLogger m n a | m-> n a where
    getLogChan :: m (InChan (ChMsg n a))

-- === Utils ===

runRawThreadedLoggerT :: InChan (ChMsg d r) -> ThreadedLoggerT' d r m a -> m a
runRawThreadedLoggerT ch = flip runReaderT ch . fromThreadedLoggerT

-- cutting out all the logs and sending them over channel, computing result
runRawBaseThreadedLoggerT :: InChan (ChMsg d r) -> ThreadedLoggerT' d r (BaseLoggerT l m) a -> m a
runRawBaseThreadedLoggerT ch = runRawBaseLoggerT . runRawThreadedLoggerT ch

runThreadedLoggerT :: (MonadIO m, Applicative m) => ThreadedLoggerT m (BaseLoggerT l IO) a -> m a
runThreadedLoggerT m = do
    (inChan, outChan) <- liftIO newChan
    liftIO $ forkIO $ do
        out <- (End <$> runRawBaseThreadedLoggerT inChan m) `catch` (return . Exc)
        writeChan inChan out
    loop outChan
    where loop :: (MonadIO m, Applicative m) => OutChan (ChMsg m a) -> m a
          loop ch = do
              l <- liftIO $ readChan ch
              case l of
                  End   a -> return a
                  ChMsg d -> d *> loop ch
                  Exc   e -> liftIO $ throwIO e

liftIOThread :: (MonadIO m, MonadThreadLogger m n a) => (IO () -> IO fa) -> ThreadedLoggerT' n a (BaseLoggerT l IO) b -> m b
liftIOThread f m = do
    inChan <- getLogChan
    ret    <- liftIO $ newEmptyMVar
    liftIO . f $ do
        out <- (End <$> runRawBaseThreadedLoggerT inChan m) `catch` (return . Exc)
        case out of
            End v -> putMVar ret v
            Exc e -> putMVar ret undefined *> writeChan inChan (Exc e)
    liftIO $ takeMVar ret

fork :: (MonadIO m, MonadThreadLogger m n a) => ThreadedLoggerT' n a (BaseLoggerT l IO) b -> m b
fork = liftIOThread forkIO

withTarget :: (MonadThreadLogger m n a, MonadIO m) => n () -> m ()
withTarget f = do
    ch <- getLogChan
    liftIO $ writeChan ch (ChMsg f)

-- === Instances ===

instance Monad m => MonadThreadLogger (ThreadedLoggerT' d r m) d r where
    getLogChan = ThreadedLoggerT' Reader.ask

---

instance (MonadIO m, MonadRecord d n) => MonadRecord d (ThreadedLoggerT' n a m) where
    appendRecord = withTarget . appendRecord

instance (MonadIO m, MonadLoggerHandler h d, LogFormat m ~ LogFormat d) => MonadLoggerHandler h (ThreadedLoggerT' d a m) where
    addHandler = withTarget . addHandler

instance (MonadIO m, MonadPriorityLogger d) => MonadPriorityLogger (ThreadedLoggerT' d a m) where
    setPriority = withTarget . setPriority
    getPriority = error "Cannot get priority from within ThreadLogger!"