{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
module Control.Eff.Log
(
Logs(..)
, logMsg
, foldLog
, foldLogFast
, module ExtLog
, captureLogs
, ignoreLogs
, handleLogsWith
, LogChannel()
, logToChannel
, noLogger
, forkLogger
, filterLogChannel
, joinLogChannel
, killLogChannel
, closeLogChannelAfter
, logChannelBracket
, logChannelPutIO
)
where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Eff as Eff
import Control.Exception ( bracket )
import qualified Control.Exception as Exc
import Control.Monad ( void
, when
, unless
)
import Control.Monad.Log as ExtLog
hiding ( )
import Control.Monad.Trans.Control
import qualified Control.Eff.Lift as Eff
import qualified Control.Monad.Log as Log
import Data.Foldable ( traverse_ )
import Data.Kind()
import Data.Sequence (Seq())
import qualified Data.Sequence as Seq
import Data.String
import Data.Typeable
data Logs message a where
LogMsg :: message -> Logs message ()
logMsg :: Member (Logs m) r => m -> Eff r ()
logMsg msg = send (LogMsg msg)
foldLog :: forall r m a . Member (Logs m) r
=> (m -> Eff r ()) -> Eff r a -> Eff r a
foldLog interceptor effect =
interpose return go effect
where
go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y
go (LogMsg m) k =
do interceptor m
k ()
foldLogFast :: forall r m a f . (Foldable f, Member (Logs m) r)
=> (m -> f m) -> Eff r a -> Eff r a
foldLogFast interceptor effect =
interpose return go effect
where
go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y
go (LogMsg m) k =
do traverse_ logMsg (interceptor m)
k ()
captureLogs :: Eff (Logs message ': r) a
-> Eff r (a, Seq message)
captureLogs actionThatLogs =
Eff.handle_relay_s
Seq.empty
(\logs result -> return (result, logs))
handleLogs
actionThatLogs
where
handleLogs :: Seq message
-> Logs message x
-> (Seq message -> Arr r x y)
-> Eff r y
handleLogs logs (LogMsg m) k =
k (logs Seq.:|> m) ()
ignoreLogs :: Eff (Logs message ': r) a
-> Eff r a
ignoreLogs actionThatLogs =
Eff.handle_relay return handleLogs actionThatLogs
where
handleLogs :: Logs m x -> Arr r x y -> Eff r y
handleLogs (LogMsg _) k = k ()
handleLogsWith
:: forall m r message a
. (Monad m, SetMember Eff.Lift (Eff.Lift m) r)
=> Eff (Logs message ': r) a
-> (forall b . (Log.Handler m message -> m b) -> m b)
-> Eff r a
handleLogsWith actionThatLogs foldHandler = Eff.handle_relay return
go
actionThatLogs
where
go :: Logs message b -> (b -> Eff r c) -> Eff r c
go (LogMsg m) k =
Eff.lift (foldHandler (\doLog -> doLog m)) >>= k
data LogChannel message =
FilteredLogChannel (message -> Bool) (LogChannel message)
| DiscardLogs
| ConcurrentLogChannel
{ fromLogChannel :: TBQueue message
, _logChannelThread :: ThreadId
}
logToChannel
:: forall r message a
. (SetMember Eff.Lift (Eff.Lift IO) r)
=> LogChannel message
-> Eff (Logs message ': r) a
-> Eff r a
logToChannel logChan actionThatLogs = do
handleLogsWith actionThatLogs
(\withHandler -> withHandler (logChannelPutIO logChan))
logChannelPutIO :: LogChannel message -> message -> IO ()
logChannelPutIO DiscardLogs _ =
return ()
logChannelPutIO (FilteredLogChannel f lc) m =
when (f m) (logChannelPutIO lc m)
logChannelPutIO c m =
atomically $ do
dropMessage <- isFullTBQueue (fromLogChannel c)
unless dropMessage (writeTBQueue (fromLogChannel c) m)
noLogger :: LogChannel message
noLogger = DiscardLogs
forkLogger
:: forall message
. (Typeable message, Show message)
=> Int
-> (message -> IO ())
-> Maybe message
-> IO (LogChannel message)
forkLogger queueLen handle mFirstMsg = do
msgQ <- atomically
(do
tq <- newTBQueue queueLen
mapM_ (writeTBQueue tq) mFirstMsg
return tq
)
thread <- forkFinally (logLoop msgQ) (writeLastLogs msgQ)
return (ConcurrentLogChannel msgQ thread)
where
writeLastLogs :: TBQueue message -> Either Exc.SomeException () -> IO ()
writeLastLogs tq ee =
do logMessages <- atomically $ flushTBQueue tq
case ee of
Right _ -> return ()
Left se ->
case Exc.fromException se of
Just (JoinLogChannelException mCloseMsg) ->
do traverse_ handle logMessages
traverse_ handle mCloseMsg
Nothing ->
case Exc.fromException se of
Just (KillLogChannelException mCloseMsg) ->
traverse_ handle mCloseMsg
Nothing ->
mapM_ handle logMessages
logLoop :: TBQueue message -> IO ()
logLoop tq = do
m <- atomically $ readTBQueue tq
handle m
logLoop tq
filterLogChannel :: (message -> Bool) -> LogChannel message -> LogChannel message
filterLogChannel = FilteredLogChannel
closeLogChannelAfter :: (Show message, Typeable message, IsString message)
=> Maybe message
-> LogChannel message
-> IO a
-> IO a
closeLogChannelAfter mGoodbye logC ioAction =
do res <- closeLogAndRethrow `Exc.handle` ioAction
closeLogSuccess
return res
where
closeLogAndRethrow :: Exc.SomeException -> IO a
closeLogAndRethrow se =
do let closeMsg = Just (fromString (Exc.displayException se))
void $ Exc.try @Exc.SomeException
$ killLogChannel closeMsg logC
Exc.throw se
closeLogSuccess :: IO ()
closeLogSuccess =
joinLogChannel mGoodbye logC
joinLogChannel :: (Show message, Typeable message)
=> Maybe message -> LogChannel message -> IO ()
joinLogChannel _closeLogMessage DiscardLogs = return ()
joinLogChannel Nothing (FilteredLogChannel _f lc) = joinLogChannel Nothing lc
joinLogChannel (Just closeLogMessage) (FilteredLogChannel f lc) =
if f closeLogMessage then
joinLogChannel (Just closeLogMessage) lc
else
joinLogChannel Nothing lc
joinLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) = do
throwTo thread (JoinLogChannelException closeLogMessage)
killLogChannel :: (Show message, Typeable message)
=> Maybe message -> LogChannel message -> IO ()
killLogChannel _closeLogMessage DiscardLogs = return ()
killLogChannel Nothing (FilteredLogChannel _f lc) = killLogChannel Nothing lc
killLogChannel (Just closeLogMessage) (FilteredLogChannel f lc) =
if f closeLogMessage then
killLogChannel (Just closeLogMessage) lc
else
killLogChannel Nothing lc
killLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) =
throwTo thread (KillLogChannelException closeLogMessage)
newtype JoinLogChannelException m = JoinLogChannelException (Maybe m)
deriving (Show, Typeable)
instance (Typeable m, Show m) => Exc.Exception (JoinLogChannelException m)
newtype KillLogChannelException m = KillLogChannelException (Maybe m)
deriving (Show, Typeable)
instance (Typeable m, Show m) => Exc.Exception (KillLogChannelException m)
logChannelBracket
:: (Show message, Typeable message)
=> Int
-> Maybe message
-> Maybe message
-> (LogChannel message -> IO a)
-> LoggingT message IO a
logChannelBracket queueLen mWelcome mGoodbye f = control
(\runInIO -> do
let logHandler = void . runInIO . logMessage
bracket (forkLogger queueLen logHandler mWelcome) (joinLogChannel mGoodbye) f)