From 19653c9f83d8f419b14fc3d6d9cfd73cc033e7f8 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Tue, 22 Feb 2022 02:20:26 +0100
Subject: [PATCH] Add ExceptionChannel helper implementations
---
src/Quasar/Exceptions/ExceptionChannel.hs | 41 +++++++++++++++++++++++
1 file changed, 41 insertions(+)
diff --git a/src/Quasar/Exceptions/ExceptionChannel.hs b/src/Quasar/Exceptions/ExceptionChannel.hs
index 4974c2e..3109a90 100644
--- a/src/Quasar/Exceptions/ExceptionChannel.hs
+++ b/src/Quasar/Exceptions/ExceptionChannel.hs
@@ -1,6 +1,9 @@
module Quasar.Exceptions.ExceptionChannel (
panicChannel,
loggingExceptionChannel,
+ newExceptionChannelWitness,
+ newExceptionRedirector,
+ newExceptionCollector
) where
import Control.Concurrent (forkIO)
@@ -36,3 +39,41 @@ loggingExceptionChannel worker =
where
logFn :: SomeException -> ShortIO ()
logFn ex = unsafeShortIO $ Trace.traceIO $ displayException ex
+
+newExceptionChannelWitness :: ExceptionChannel -> STM (ExceptionChannel, STM Bool)
+newExceptionChannelWitness exChan = do
+ var <- newTVar False
+ let chan = ExceptionChannel \ex -> lock var >> throwToExceptionChannel exChan ex
+ pure (chan, readTVar var)
+ where
+ lock :: TVar Bool -> STM ()
+ lock var = unlessM (readTVar var) (writeTVar var True)
+
+newExceptionRedirector :: ExceptionChannel -> STM (ExceptionChannel, ExceptionChannel -> STM ())
+newExceptionRedirector initialExceptionChannel = do
+ channelVar <- newTVar initialExceptionChannel
+ pure (ExceptionChannel (channelFn channelVar), writeTVar channelVar)
+ where
+ channelFn :: TVar ExceptionChannel -> SomeException -> STM ()
+ channelFn channelVar ex = do
+ channel <- readTVar channelVar
+ throwToExceptionChannel channel ex
+
+-- | Collects exceptions. After they have been collected (by using the resulting
+-- transaction), further exceptions are forwarded to the backup exception sink.
+-- The collection transaction may only be used once.
+newExceptionCollector :: ExceptionChannel -> STM (ExceptionChannel, STM [SomeException])
+newExceptionCollector backupExceptionChannel = do
+ exceptionsVar <- newTVar (Just [])
+ pure (ExceptionChannel (channelFn exceptionsVar), gatherResult exceptionsVar)
+ where
+ channelFn :: TVar (Maybe [SomeException]) -> SomeException -> STM ()
+ channelFn exceptionsVar ex = do
+ readTVar exceptionsVar >>= \case
+ Just exceptions -> writeTVar exceptionsVar (Just (ex : exceptions))
+ Nothing -> throwToExceptionChannel backupExceptionChannel ex
+ gatherResult :: TVar (Maybe [SomeException]) -> STM [SomeException]
+ gatherResult exceptionsVar =
+ swapTVar exceptionsVar Nothing >>= \case
+ Just exceptions -> pure exceptions
+ Nothing -> throwSTM $ userError "Exception collector result can only be generated once."
--
GitLab