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)
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.
withAsync
TQueue
catchAny
finally
($!)