module Control.Eff.Log.Channel
( LogChannel()
, withAsyncLogChannel
, handleLoggingAndIO
, handleLoggingAndIO_
)
where
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Eff as Eff
import Control.Eff.Lift
import Control.Exception ( evaluate )
import Control.Monad ( void
, unless
)
import Control.Eff.Log.Handler
import Data.Foldable ( traverse_ )
import Data.Kind ( )
import Control.DeepSeq
import GHC.Stack
withAsyncLogChannel
:: forall message a len
. (NFData message, Integral len)
=> len
-> LogWriter message IO
-> (LogChannel message -> IO a)
-> IO a
withAsyncLogChannel queueLen ioWriter action = do
msgQ <- newTBQueueIO (fromIntegral queueLen)
withAsync (logLoop msgQ) (action . ConcurrentLogChannel msgQ)
where
logLoop tq = do
ms <- atomically $ do
h <- readTBQueue tq
t <- flushTBQueue tq
return (h : t)
writeAllLogMessages ioWriter ms
logLoop tq
handleLoggingAndIO
:: (NFData m, HasCallStack)
=> Eff '[Logs m, LogWriterReader m IO, Lift IO] a
-> LogChannel m
-> IO a
handleLoggingAndIO e lc = runLift
(writeLogs (foldingLogWriter (traverse_ logChannelPutIO)) e)
where
logQ = fromLogChannel lc
logChannelPutIO (force -> me) = do
!m <- evaluate me
atomically
(do
dropMessage <- isFullTBQueue logQ
unless dropMessage (writeTBQueue logQ m)
)
handleLoggingAndIO_
:: (NFData m, HasCallStack)
=> Eff '[Logs m, LogWriterReader m IO, Lift IO] a
-> LogChannel m
-> IO ()
handleLoggingAndIO_ e lc = void (handleLoggingAndIO e lc)
data LogChannel message =
ConcurrentLogChannel
{ fromLogChannel :: TBQueue message
, _logChannelThread :: Async ()
}