diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +# Version 1.0.4 + +* Improve exception handling when worker stops. + +* Added `LoggingWorkerNotRunning`. + +* Fixed path rendering when logging exceptions. + + # Version 1.0.3 * Fix handling of async exceptions even more (now with tests). diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,4 +1,4 @@ -Copyright (c) 2017-2018, Renzo Carbonara +Copyright (c) 2017, Renzo Carbonara All rights reserved. diff --git a/di-core.cabal b/di-core.cabal --- a/di-core.cabal +++ b/di-core.cabal @@ -1,8 +1,8 @@ name: di-core -version: 1.0.3 +version: 1.0.4 author: Renzo Carbonara maintainer: renλren.zone -copyright: Renzo Carbonara 2017-2018 +copyright: Renzo Carbonara 2017 license: BSD3 license-file: LICENSE.txt extra-source-files: README.md CHANGELOG.md diff --git a/lib/Di/Core.hs b/lib/Di/Core.hs --- a/lib/Di/Core.hs +++ b/lib/Di/Core.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK not-home #-} @@ -21,6 +22,7 @@ , contramsg , Log(Log, log_time, log_level, log_path, log_message) , ExceptionInLoggingWorker(ExceptionInLoggingWorker) + , LoggingWorkerNotRunning(LoggingWorkerNotRunning) ) where import Control.Concurrent (forkIOWithUnmask, myThreadId) @@ -75,14 +77,14 @@ -- the spanish word for an imperative form of the verb \"decir", which in -- english means "to say", which clearly must have something to do with logging. data Di level path msg = Di - { di_filter :: !(level -> Seq path -> msg -> Bool) + { di_filter :: level -> Seq path -> msg -> Bool -- ^ Whether a particular combination of @level@, @path@s and @msg@ should -- be logged. - , di_send :: !(Log level path msg -> STM ()) + , di_send :: Log level path msg -> STM () -- ^ Send a 'Log' for processing. - , di_flush :: !(STM ()) + , di_flush :: STM () -- ^ Block until all logs finish being processed. - , di_logex :: Ex.SomeException -> Maybe (STM ()) + , di_logex :: Seq path -> Ex.SomeException -> Maybe (STM ()) -- ^ If an exception deserves logging, then returns an 'STM' action -- that will perform the logging. } @@ -139,20 +141,18 @@ new commit act = do tqLogs :: STM.TQueue (Log level path msg) <- liftIO STM.newTQueueIO - tmvWOut :: STM.TMVar (Maybe ExceptionInLoggingWorker) + tmvWOut :: STM.TMVar Ex.SomeException <- liftIO STM.newEmptyTMVarIO let di = Di { di_filter = \_ _ _ -> True - , di_logex = \_ -> Just (pure ()) + , di_logex = \_ _ -> Just (pure ()) , di_send = \x -> STM.tryReadTMVar tmvWOut >>= \case Nothing -> STM.writeTQueue tqLogs x - Just (Just ex) -> STM.throwSTM ex - Just Nothing -> error "di_send: the impossible happened" + Just ex -> STM.throwSTM ex , di_flush = STM.tryReadTMVar tmvWOut >>= \case Nothing -> STM.isEmptyTQueue tqLogs >>= \case True -> pure () False -> STM.retry - Just (Just ex) -> STM.throwSTM ex - Just Nothing -> error "di_flush: the impossible happened" + Just ex -> STM.throwSTM ex } tIdMe <- liftIO myThreadId Ex.uninterruptibleMask $ \restore -> do @@ -160,15 +160,16 @@ -- the main thread and save it to `tmvWOut`. tIdWorker <- liftIO $ forkIOWithUnmask $ \unmask -> do Ex.tryAsync (unmask (worker tqLogs)) >>= \case - Right () -> STM.atomically (STM.putTMVar tmvWOut Nothing) + Right () -> STM.atomically $ do + STM.putTMVar tmvWOut (Ex.toException LoggingWorkerNotRunning) Left (se :: Ex.SomeException) -> case Ex.fromException se of - Just MyThreadKilled -> do - STM.atomically (STM.putTMVar tmvWOut Nothing) + Just MyThreadKilled -> STM.atomically $ do + STM.putTMVar tmvWOut (Ex.toException LoggingWorkerNotRunning) Nothing -> do let ex = ExceptionInLoggingWorker se Ex.finally (Ex.throwTo tIdMe (Ex.asyncExceptionToException ex)) - (STM.atomically (STM.putTMVar tmvWOut (Just ex))) + (STM.atomically (STM.putTMVar tmvWOut (Ex.toException ex))) -- Run `act`, flushing and killing the worker when we are done. Ex.finally (restore (act di)) @@ -215,6 +216,12 @@ deriving (Show) instance Ex.Exception ExceptionInLoggingWorker +-- | This exception is thrown if somebody tries to log or flush a message +-- when the logging worker is not running. +data LoggingWorkerNotRunning = LoggingWorkerNotRunning + deriving (Show) +instance Ex.Exception LoggingWorkerNotRunning + -- | Internal. This is our own version of 'Ex.ThreadKilled' which we use -- inside 'new' so that we can identify it and prevent its propagation. data MyThreadKilled = MyThreadKilled @@ -382,7 +389,7 @@ -> m a throw' nat di = \e -> do -- If logging throws an exception, then it will be propagated instead of `e`. - nat (sequence_ (di_logex di (Ex.toException e))) + nat (sequence_ (di_logex di mempty (Ex.toException e))) -- By throwing from inside 'STM' we avoid potentially entering into an -- infinite loop in case the implementation of 'Ex.throwM' would take us back -- to 'throw''. Also, notice that we need to call `nat` again here, otherwise @@ -439,10 +446,10 @@ -> Di level path msg -> Di level path msg -- ^ onException f = \di0 -> di0 - { di_logex = \se -> do - _ <- di_logex di0 se - (l, ps, m) <- f se - let di1 = foldl' (flip push) di0 ps + { di_logex = \ps0 se -> do + _ <- di_logex di0 ps0 se + (l, ps1, m) <- f se + let di1 = foldl' (flip push) di0 (ps1 <> ps0) Just (log' id di1 l m) } @@ -490,7 +497,8 @@ push :: path -> Di level path msg -> Di level path msg push p = \di -> di { di_send = \x -> di_send di (x { log_path = p Seq.<| log_path x }) - , di_filter = \l ps m -> di_filter di l (p Seq.<| ps) m } + , di_filter = \l ps m -> di_filter di l (p Seq.<| ps) m + , di_logex = \ps se -> di_logex di (p Seq.<| ps) se } {-# INLINABLE push #-} -- | A 'Di' is contravariant in its @level@ argument. @@ -555,6 +563,7 @@ contrapath f = \di -> di { di_send = \x -> di_send di (x { log_path = fmap f (log_path x) }) , di_filter = \l ps m -> di_filter di l (fmap f ps) m + , di_logex = \ps se -> di_logex di (fmap f ps) se } {-# INLINABLE contrapath #-} @@ -593,21 +602,21 @@ -------------------------------------------------------------------------------- data Log level path msg = Log - { log_time :: !Time.SystemTime + { log_time :: Time.SystemTime -- ^ First known timestamp when the log was generated. -- -- We use 'Time.SystemTime' rather than 'Time.UTCTime' because it is -- cheaper to obtain and to render. You can use -- 'Data.Time.Clock.System.systemToUTCTime' to convert it if necessary. - , log_level :: !level + , log_level :: level -- ^ Importance level of the logged message (e.g., “info”, “warning”, -- “error”, etc.). - , log_path :: !(Seq path) + , log_path :: Seq path -- ^ Path where the logged message was created from. -- -- The leftmost @path@ is the root @path@. The rightmost @path@ is the -- @path@ closest to where the log was generated. - , log_message :: !msg + , log_message :: msg -- ^ Human-readable message itself. } deriving (Eq, Show)