Logging

[chris-martin]

I like concurrent logging as the subject as a Phrasebook example because it's a common need and a good excuse to concisely put together a lot of topics.

Here's some code that comes straight out of the repo for the Type Classes server. It probably contains a few too many topics and needs to be significantly simplified and better focused.

• Starting threads with withAsync
• Concurrent queues TQueue
• Catching exceptions with catchAny
• Cleaning up after interrupts with finally
• Introducing strictness with ($!)

import Control.Concurrent.Async (withAsync)
import Control.Concurrent.STM
import Control.Exception.Safe (Exception (displayException), catchAny, finally)
import Control.Monad (forever)
import Control.Monad.Trans.Cont
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import System.IO (stderr)

data Log =
  Log
    { logText :: Text -> IO ()
    , logString :: String -> IO ()
    }

withLogging :: ContT a IO Log
withLogging = ContT \continue ->
  do
    q <- atomically newTQueue

    let
        logText msg = atomically (writeTQueue q $! msg)
        logString = logText . Text.pack
        l = Log {..}

    withAsync (runLogger q) \_ -> (continue l)

runLogger :: TQueue Text -> IO ()
runLogger q = finally runForever runUntilEmpty
  where
    runForever = forever $ atomically (readTQueue q) >>= write

    runUntilEmpty =
        atomically (tryReadTQueue q) >>=
        \case
            Nothing -> return ()
            Just msg -> write msg *> runUntilEmpty

    write msg = Text.hPutStrLn stderr msg

recover :: Log -> IO a -> IO (Maybe a)
recover log a = catchAny (fmap Just a) (\e -> logException log e *> return Nothing)

logException :: Exception e => Log -> e -> IO ()
logException log e = logString log (displayException e)