di-core 1.0.3 → 1.0.4

raw patch · 4 files changed

+45/−27 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• LICENSE.txt +1/−1
• di-core.cabal +2/−2
• lib/Di/Core.hs +33/−24

@@ -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).

@@ -1,4 +1,4 @@-Copyright (c) 2017-2018, Renzo Carbonara+Copyright (c) 2017, Renzo Carbonara  All rights reserved. 

@@ -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

@@ -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)