snap-error-collector 1.0.0 → 1.1.0

raw patch · 3 files changed

+52/−22 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog.md +7/−0
• snap-error-collector.cabal +1/−1
• src/Snap/ErrorCollector.hs +44/−21

@@ -1,3 +1,10 @@+# 1.1.0++* Add an upper bound on the amount of errors collected. This means that even+  when things go horribly wrong in other code, you at least won't run out of+  memory by collecting all the exceptions! Thanks to @gregorycollins for+  this advice.+ # 1.0.0  * Initial version.

@@ -1,5 +1,5 @@ name: snap-error-collector-version: 1.0.0+version: 1.1.0 synopsis: Collect errors in batches and dispatch them homepage: http://github.com/ocharles/snap-error-collector license: BSD3

@@ -19,7 +19,12 @@     { 'ecFlush' = emailOpsTeam     , 'ecFlushInterval' = 60000000     , 'ecFilter' = 'const' 'True'+    , 'ecUpperBound' = 1000     }++emailOpsTeam :: 'Time.UTCTime' -> 'Seq' 'LoggedException' -> 'Int' -> 'IO' '()'+emailOpsTeam = ...+ @  -}@@ -36,6 +41,7 @@ import Control.Monad (forever, mplus, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Loops (unfoldM')+import Data.Foldable (msum) import Data.Sequence as Seq  import qualified Control.Concurrent.Async as Async@@ -54,11 +60,12 @@  -- | How @snap-error-collector@ should run. data ErrorCollectorConfig = ErrorCollectorConfig-  { ecFlush :: !(Time.UTCTime -> Seq LoggedException -> IO ())+  { ecFlush :: !(Time.UTCTime -> Seq LoggedException -> Int -> IO ())     -- ^ An IO action to perform with the list of exceptions that were-    -- thrown during the last collection period. The computation will be-    -- executed asynchronously, but subsequent collections will not be-    -- flushed until outstanding computations complete.+    -- thrown during the last collection period, and the amount of exceptions that+    -- had to be dropped. The computation will be executed asynchronously, but+    -- subsequent collections will not be flushed until outstanding computations+    -- complete.    , ecFlushInterval :: !Int     -- ^ How long (in microseconds) to collect exceptions for until they are sent@@ -69,22 +76,33 @@     -- ^ A filter on which exceptions should be collected. SomeException's that     -- return true under this predicate will be collected, other errors will be     -- not.++  , ecExceptionUpperBound :: !Int+    -- ^ The maximum amount of exceptions to store within 'ecFlushInterval'.+    -- Currently, if more exceptions than this are thrown, subsequent exceptions+    -- will be dropped on the floor (and a counter incremented). This allows you+    -- to maintain predictable memory usage if something in the rest of your+    -- application goes horribly wrong.+    --+    -- If dropping exceptions on the floor doesn't suit your needs, please+    -- open a bug report on the issue tracker and we can discuss alternatives.   } --- | A convenient constructor for 'ErrorCollectorConfig' that collects all--- exceptions and flushes the queue every minute. You have to supply the+-- | A convenient constructor for 'ErrorCollectorConfig' that collects up to+-- 100 exceptions and flushes the queue every minute. You have to supply the -- 'IO' action to run when the queue is flushed.-basicConfig :: (Time.UTCTime -> Seq LoggedException -> IO ()) -> ErrorCollectorConfig-basicConfig m = ErrorCollectorConfig m 60000000 (const True)+basicConfig :: (Time.UTCTime -> Seq LoggedException -> Int -> IO ()) -> ErrorCollectorConfig+basicConfig m = ErrorCollectorConfig m 60000000 (const True) 100  -- | Wrap a 'Snap' website to collect errors. collectErrors :: ErrorCollectorConfig -> Snap.Initializer b v () collectErrors ErrorCollectorConfig{..} =-  do q <- liftIO STM.newTQueueIO-     worker <- liftIO (Async.async (forever (processQueue q)))-     addWrapper q+  do q <- liftIO (STM.newTBQueueIO ecExceptionUpperBound)+     dropped <- liftIO (STM.newTVarIO 0)+     worker <- liftIO (Async.async (forever (processQueue q dropped)))+     addWrapper q dropped      Snap.onUnload (Async.cancel worker)-  where addWrapper q =+  where addWrapper q dropped =           Snap.wrapSite             (\h ->                do ex <- MCIO.try h@@ -94,16 +112,21 @@                          req <- Snap.getRequest                          when (ecFilter se)                               (liftIO (STM.atomically-                                         (STM.writeTQueue q-                                                          (LoggedException se now req))))+                                         (msum [STM.writeTBQueue q+                                                                 (LoggedException se now req)+                                               ,STM.modifyTVar dropped succ])))                          MCIO.throw se                     Right a -> return a)-        processQueue q =+        processQueue q dropped =           do threadDelay ecFlushInterval-             exceptions <- STM.atomically-                             (do liftA2 (<|)-                                        (STM.readTQueue q)-                                        (unfoldM' (STM.tryReadTQueue q)))-             when (not (Seq.null exceptions))+             (exceptions,dropped) <- STM.atomically+                                       (do exceptions <- liftA2 (<|)+                                                                (STM.readTBQueue q)+                                                                (unfoldM' (STM.tryReadTBQueue q))+                                           dropped <- STM.readTVar dropped <*+                                                      STM.writeTVar dropped 0+                                           return (exceptions,dropped))+             when (not (Seq.null exceptions) ||+                   dropped > 0)                   (do now <- Time.getCurrentTime-                      ecFlush now exceptions)+                      ecFlush now exceptions dropped)