module Unclog.Subscriber
  ( -- * subscribing to a log channel
    Subscriber (..)
  , colourSubscriber
  , simpleSubscriber
  , fileSubscriber

    -- * run a logging situation
  , withLoggingWithSubscribers

    -- * creating, subscribing and reading from channels
  , newLogChan
  , newLogChanIO
  , subscribeLog
  , readLogEntry

    -- * helpers
  , withSubscriber
  , mkSubscriber
  , mkSubscriberSimple
  , bracketSubscriber
  , refSubscriber
  )
where

import Control.Concurrent.Async (cancelMany)
import Control.Monad (forever, when)
import Control.Monad.Codensity
import Data.ByteString.Builder qualified as BS
import Unclog.Common (LogEntry (level), LogLevel, PLogChan (..), SLogChan (..))
import Unclog.Render (colouredBuilder, simpleBuilder)
import UnliftIO

-- | a 'Subscriber' is something that can observe log entries and do something with them in the Monad @m@
newtype Subscriber m = MkSubscriber {forall (m :: * -> *).
Subscriber m -> Codensity m (LogEntry -> m ())
runSubscriber :: Codensity m (LogEntry -> m ())}

-- | make a subscriber with a possible clean up (useful if you need to bracket your subscriber)
mkSubscriber :: (forall r. ((LogEntry -> m ()) -> m r) -> m r) -> Subscriber m
mkSubscriber :: forall (m :: * -> *).
(forall r. ((LogEntry -> m ()) -> m r) -> m r) -> Subscriber m
mkSubscriber forall r. ((LogEntry -> m ()) -> m r) -> m r
k = Codensity m (LogEntry -> m ()) -> Subscriber m
forall (m :: * -> *).
Codensity m (LogEntry -> m ()) -> Subscriber m
MkSubscriber ((forall r. ((LogEntry -> m ()) -> m r) -> m r)
-> Codensity m (LogEntry -> m ())
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((LogEntry -> m ()) -> m b) -> m b
forall r. ((LogEntry -> m ()) -> m r) -> m r
k)
{-# INLINE mkSubscriber #-}

-- | make a subscriber from a simple log function
mkSubscriberSimple :: (LogEntry -> m ()) -> Subscriber m
mkSubscriberSimple :: forall (m :: * -> *). (LogEntry -> m ()) -> Subscriber m
mkSubscriberSimple LogEntry -> m ()
k = Codensity m (LogEntry -> m ()) -> Subscriber m
forall (m :: * -> *).
Codensity m (LogEntry -> m ()) -> Subscriber m
MkSubscriber ((LogEntry -> m ()) -> Codensity m (LogEntry -> m ())
forall a. a -> Codensity m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogEntry -> m ()
k)
{-# INLINE mkSubscriberSimple #-}

-- | destruct a subscriber
withSubscriber :: Subscriber m -> ((LogEntry -> m ()) -> m b) -> m b
withSubscriber :: forall (m :: * -> *) b.
Subscriber m -> ((LogEntry -> m ()) -> m b) -> m b
withSubscriber Subscriber m
sub = Codensity m (LogEntry -> m ())
-> forall b. ((LogEntry -> m ()) -> m b) -> m b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (Subscriber m -> Codensity m (LogEntry -> m ())
forall (m :: * -> *).
Subscriber m -> Codensity m (LogEntry -> m ())
runSubscriber Subscriber m
sub)
{-# INLINE withSubscriber #-}

-- | write a log entry to a handle, printing all information, but use colour
colourSubscriber
  :: MonadIO m
  => LogLevel
  -- ^ the lowest loglevel to still log
  -> Handle
  -- ^ the handle to log to
  -> Subscriber m
colourSubscriber :: forall (m :: * -> *).
MonadIO m =>
LogLevel -> Handle -> Subscriber m
colourSubscriber LogLevel
lvl Handle
hdl = (LogEntry -> m ()) -> Subscriber m
forall (m :: * -> *). (LogEntry -> m ()) -> Subscriber m
mkSubscriberSimple \LogEntry
entry -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogEntry
entry.level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
lvl) do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
BS.hPutBuilder Handle
hdl (LogEntry -> Builder
colouredBuilder LogEntry
entry)
{-# INLINEABLE colourSubscriber #-}

-- | write a log entry to a handle, printing all information
simpleSubscriber
  :: MonadIO m
  => LogLevel
  -- ^ the lowest loglevel to still log
  -> Handle
  -- ^ the handle to log to
  -> Subscriber m
simpleSubscriber :: forall (m :: * -> *).
MonadIO m =>
LogLevel -> Handle -> Subscriber m
simpleSubscriber LogLevel
lvl Handle
hdl = (LogEntry -> m ()) -> Subscriber m
forall (m :: * -> *). (LogEntry -> m ()) -> Subscriber m
mkSubscriberSimple \LogEntry
entry -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogEntry
entry.level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
lvl) do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
BS.hPutBuilder Handle
hdl (LogEntry -> Builder
simpleBuilder LogEntry
entry)
{-# INLINEABLE simpleSubscriber #-}

-- | create a simple subscriber that writes to a file
fileSubscriber
  :: MonadUnliftIO m
  => LogLevel
  -- ^ the lowest loglevel to still log
  -> FilePath
  -- ^ the file to log (append) to
  -> Subscriber m
fileSubscriber :: forall (m :: * -> *).
MonadUnliftIO m =>
LogLevel -> FilePath -> Subscriber m
fileSubscriber LogLevel
lvl FilePath
fp = (forall r. ((LogEntry -> m ()) -> m r) -> m r) -> Subscriber m
forall (m :: * -> *).
(forall r. ((LogEntry -> m ()) -> m r) -> m r) -> Subscriber m
mkSubscriber \(LogEntry -> m ()) -> m r
k ->
  FilePath -> IOMode -> (Handle -> m r) -> m r
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withFile FilePath
fp IOMode
AppendMode \Handle
hdl ->
    Subscriber m -> ((LogEntry -> m ()) -> m r) -> m r
forall (m :: * -> *) b.
Subscriber m -> ((LogEntry -> m ()) -> m b) -> m b
withSubscriber (LogLevel -> Handle -> Subscriber m
forall (m :: * -> *).
MonadIO m =>
LogLevel -> Handle -> Subscriber m
simpleSubscriber LogLevel
lvl Handle
hdl) (LogEntry -> m ()) -> m r
k
{-# INLINEABLE fileSubscriber #-}

-- | build a subscriber that requires a resource
bracketSubscriber
  :: MonadUnliftIO m
  => m a
  -- ^ acquire the resource
  -> (a -> m b)
  -- ^ release the resource
  -> (a -> LogEntry -> m ())
  -- ^ how to write a log entry given a resource
  -> Subscriber m
bracketSubscriber :: forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> LogEntry -> m ()) -> Subscriber m
bracketSubscriber m a
acquire a -> m b
release a -> LogEntry -> m ()
entry = (forall r. ((LogEntry -> m ()) -> m r) -> m r) -> Subscriber m
forall (m :: * -> *).
(forall r. ((LogEntry -> m ()) -> m r) -> m r) -> Subscriber m
mkSubscriber \(LogEntry -> m ()) -> m r
k ->
  m a -> (a -> m b) -> (a -> m r) -> m r
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    m a
acquire
    a -> m b
release
    ((LogEntry -> m ()) -> m r
k ((LogEntry -> m ()) -> m r) -> (a -> LogEntry -> m ()) -> a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LogEntry -> m ()
entry)
{-# INLINEABLE bracketSubscriber #-}

-- | write log entries to an 'IORef'
refSubscriber :: MonadIO m => IORef [LogEntry] -> Subscriber m
refSubscriber :: forall (m :: * -> *). MonadIO m => IORef [LogEntry] -> Subscriber m
refSubscriber IORef [LogEntry]
ref = (LogEntry -> m ()) -> Subscriber m
forall (m :: * -> *). (LogEntry -> m ()) -> Subscriber m
mkSubscriberSimple \LogEntry
entry -> IORef [LogEntry] -> ([LogEntry] -> ([LogEntry], ())) -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [LogEntry]
ref \[LogEntry]
old -> (LogEntry
entry LogEntry -> [LogEntry] -> [LogEntry]
forall a. a -> [a] -> [a]
: [LogEntry]
old, ())
{-# INLINEABLE refSubscriber #-}

-- | it is not a priori unsafe to escape the chan out of the context, it will just mean that
--   all the subscribers are gone and nothing is logged anymore
withLoggingWithSubscribers
  :: forall m r
   . MonadUnliftIO m
  => [Subscriber m]
  -- ^ a list of subscribers
  -> (PLogChan -> m r)
  -- ^ a channel, a client can write to
  -> m r
withLoggingWithSubscribers :: forall (m :: * -> *) r.
MonadUnliftIO m =>
[Subscriber m] -> (PLogChan -> m r) -> m r
withLoggingWithSubscribers [Subscriber m]
subscribers PLogChan -> m r
k = do
  (PLogChan
chan, [(SLogChan, Subscriber m)]
subchans) <- STM (PLogChan, [(SLogChan, Subscriber m)])
-> m (PLogChan, [(SLogChan, Subscriber m)])
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically do
    PLogChan
c <- STM PLogChan
newLogChan
    (PLogChan
c,) ([(SLogChan, Subscriber m)]
 -> (PLogChan, [(SLogChan, Subscriber m)]))
-> STM [(SLogChan, Subscriber m)]
-> STM (PLogChan, [(SLogChan, Subscriber m)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Subscriber m -> STM (SLogChan, Subscriber m))
-> [Subscriber m] -> STM [(SLogChan, Subscriber m)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\Subscriber m
sub -> (,Subscriber m
sub) (SLogChan -> (SLogChan, Subscriber m))
-> STM SLogChan -> STM (SLogChan, Subscriber m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PLogChan -> STM SLogChan
subscribeLog PLogChan
c) [Subscriber m]
subscribers
  [Async Any]
subAsyncs <- ((SLogChan, Subscriber m) -> m (Async Any))
-> [(SLogChan, Subscriber m)] -> m [Async Any]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((SLogChan -> Subscriber m -> m (Async Any))
-> (SLogChan, Subscriber m) -> m (Async Any)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SLogChan -> Subscriber m -> m (Async Any)
forall b. SLogChan -> Subscriber m -> m (Async b)
mkSubscriberAsync) [(SLogChan, Subscriber m)]
subchans
  PLogChan -> m r
k PLogChan
chan m r -> m () -> m r
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Async Any] -> IO ()
forall a. [Async a] -> IO ()
cancelMany [Async Any]
subAsyncs)
 where
  mkSubscriberAsync :: SLogChan -> Subscriber m -> m (Async b)
  mkSubscriberAsync :: forall b. SLogChan -> Subscriber m -> m (Async b)
mkSubscriberAsync SLogChan
chan Subscriber m
subscription = m b -> m (Async b)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m b -> m (Async b)) -> m b -> m (Async b)
forall a b. (a -> b) -> a -> b
$ Codensity m (LogEntry -> m ())
-> forall b. ((LogEntry -> m ()) -> m b) -> m b
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity (Subscriber m -> Codensity m (LogEntry -> m ())
forall (m :: * -> *).
Subscriber m -> Codensity m (LogEntry -> m ())
runSubscriber Subscriber m
subscription) \LogEntry -> m ()
sub -> do
    let -- this mask is needed because if we receive a cancel in the middle of executing the subcriber, the
        -- subscriber is aborted and we're missing a log entry. This can happen when the subscribers are
        -- still reading but the main task as stopped writing and is trying to flush the subscribers
        runSubscription :: m b
runSubscription = m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ do
          -- the normal case just reads the next log entry from the channel and runs the subscriber on it
          STM LogEntry -> m LogEntry
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (SLogChan -> STM LogEntry
readLogEntry SLogChan
chan)
            m LogEntry -> (LogEntry -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogEntry -> m ()
sub

        flushSubscription :: m ()
flushSubscription = do
          STM (Maybe LogEntry) -> m (Maybe LogEntry)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TChan LogEntry -> STM (Maybe LogEntry)
forall a. TChan a -> STM (Maybe a)
tryReadTChan (SLogChan -> TChan LogEntry
unSLogChan SLogChan
chan)) m (Maybe LogEntry) -> (Maybe LogEntry -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe LogEntry
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just LogEntry
a -> do
              LogEntry -> m ()
sub LogEntry
a
              m ()
flushSubscription

    m b
runSubscription m b -> m () -> m b
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` m ()
flushSubscription
{-# INLINEABLE withLoggingWithSubscribers #-}

-- | create a new 'LogChan'
newLogChan :: STM PLogChan
newLogChan :: STM PLogChan
newLogChan = TChan LogEntry -> PLogChan
MkPLogChan (TChan LogEntry -> PLogChan)
-> STM (TChan LogEntry) -> STM PLogChan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (TChan LogEntry)
forall a. STM (TChan a)
newBroadcastTChan
{-# INLINE newLogChan #-}

-- | create a new 'LogChan' in 'IO'
newLogChanIO :: MonadIO m => m PLogChan
newLogChanIO :: forall (m :: * -> *). MonadIO m => m PLogChan
newLogChanIO = TChan LogEntry -> PLogChan
MkPLogChan (TChan LogEntry -> PLogChan) -> m (TChan LogEntry) -> m PLogChan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (TChan LogEntry)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
newBroadcastTChanIO
{-# INLINE newLogChanIO #-}

-- | subscribe to a publishing log chan to obtain a subscriber log chan
subscribeLog :: PLogChan -> STM SLogChan
subscribeLog :: PLogChan -> STM SLogChan
subscribeLog = (TChan LogEntry -> SLogChan)
-> STM (TChan LogEntry) -> STM SLogChan
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TChan LogEntry -> SLogChan
MkSLogChan (STM (TChan LogEntry) -> STM SLogChan)
-> (PLogChan -> STM (TChan LogEntry)) -> PLogChan -> STM SLogChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan LogEntry -> STM (TChan LogEntry)
forall a. TChan a -> STM (TChan a)
dupTChan (TChan LogEntry -> STM (TChan LogEntry))
-> (PLogChan -> TChan LogEntry) -> PLogChan -> STM (TChan LogEntry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PLogChan -> TChan LogEntry
unPLogChan
{-# INLINE subscribeLog #-}

-- | read one log entry from a subscriber log chan
readLogEntry :: SLogChan -> STM LogEntry
readLogEntry :: SLogChan -> STM LogEntry
readLogEntry = TChan LogEntry -> STM LogEntry
forall a. TChan a -> STM a
readTChan (TChan LogEntry -> STM LogEntry)
-> (SLogChan -> TChan LogEntry) -> SLogChan -> STM LogEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SLogChan -> TChan LogEntry
unSLogChan
{-# INLINE readLogEntry #-}