module Control.Eff.Log.Channel
( LogChannel()
, logToChannel
, noLogger
, forkLogger
, filterLogChannel
, joinLogChannel
, killLogChannel
, closeLogChannelAfter
, logChannelBracket
, logChannelPutIO
, JoinLogChannelException()
, KillLogChannelException()
)
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 Control.Eff.Log.Handler
import qualified Control.Eff.Lift as Eff
import Data.Foldable ( traverse_ )
import Data.Kind ( )
import Data.String
import Data.Typeable
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 =
handleLogsWithLoggingTHandler ($ 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)
=> Int
-> (message -> IO ())
-> Maybe message
-> IO (LogChannel message)
forkLogger queueLen handle mFirstMsg = do
msgQ <- atomically
(do
tq <- newTBQueue (fromIntegral @Int 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 -> traverse_ handle logMessages
Nothing -> case Exc.fromException se of
Just KillLogChannelException -> return ()
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
:: (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
void $ Exc.try @Exc.SomeException $ killLogChannel logC
Exc.throw se
closeLogSuccess :: IO ()
closeLogSuccess = joinLogChannel logC
joinLogChannel :: (Typeable message) => LogChannel message -> IO ()
joinLogChannel DiscardLogs = return ()
joinLogChannel (FilteredLogChannel _f lc) = joinLogChannel lc
joinLogChannel (ConcurrentLogChannel _tq thread) =
throwTo thread JoinLogChannelException
killLogChannel :: (Typeable message) => LogChannel message -> IO ()
killLogChannel DiscardLogs = return ()
killLogChannel (FilteredLogChannel _f lc) = killLogChannel lc
killLogChannel (ConcurrentLogChannel _tq thread) =
throwTo thread KillLogChannelException
data JoinLogChannelException = JoinLogChannelException
deriving (Show, Typeable)
instance Exc.Exception JoinLogChannelException
data KillLogChannelException = KillLogChannelException
deriving (Show, Typeable)
instance Exc.Exception KillLogChannelException
logChannelBracket
:: (Typeable message)
=> Int
-> Maybe message
-> (LogChannel message -> IO a)
-> LoggingT message IO a
logChannelBracket queueLen mWelcome f = control
(\runInIO -> do
let logHandler = void . runInIO . logMessage
bracket (forkLogger queueLen logHandler mWelcome) joinLogChannel f
)