snap-error-collector (empty) → 1.0.0

raw patch · 5 files changed

+171/−0 lines, 5 filesdep +MonadCatchIO-transformersdep +asyncdep +basesetup-changed

Dependencies added: MonadCatchIO-transformers, async, base, containers, monad-loops, snap, stm, time, transformers

Files

Changelog.md +3/−0
LICENSE +30/−0
Setup.hs +2/−0
snap-error-collector.cabal +27/−0
src/Snap/ErrorCollector.hs +109/−0

+ Changelog.md view

@@ -0,0 +1,3 @@+# 1.0.0++* Initial version.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Ollie Charles++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ollie Charles nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ snap-error-collector.cabal view

@@ -0,0 +1,27 @@+name: snap-error-collector+version: 1.0.0+synopsis: Collect errors in batches and dispatch them+homepage: http://github.com/ocharles/snap-error-collector+license: BSD3+license-file: LICENSE+author: Ollie Charles+maintainer: ollie@ocharles.org.uk+category: Web+build-type: Simple+cabal-version: >=1.10+extra-source-files: Changelog.md++library+  exposed-modules: Snap.ErrorCollector+  build-depends:+    MonadCatchIO-transformers >= 0.3.1.2 && < 0.4,+    async >= 2.0.1.6 && < 2.1,+    base >=4.7 && <4.8,+    containers >= 0.5.5.1 && < 0.6,+    monad-loops >= 0.4.2.1 && < 0.5,+    snap >= 0.13.3.1 && < 0.14,+    stm >= 2.4.3 && < 2.5,+    time >= 1.4.2 && < 1.5,+    transformers >= 0.3.0.0 && < 0.4+  hs-source-dirs: src+  default-language: Haskell2010

+ src/Snap/ErrorCollector.hs view

@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards #-}+{-|++@snap-error-collector@ extends a 'Snap' application with the ability to monitor+requests for uncaught exceptions. All routes are wrapped with an exception+handler, and exceptions are queued (and optionally filtered). Periodically,+the exception queue is flushed via an 'IO' computation - you can use this+to send emails, notify yourself on Twitter, increment counters, etc.++Example:++@+import "Snap.ErrorCollector"++initApp :: 'Snap.Initializer' MyApp MyApp+initApp = do+  ...+  'collectErrors' 'ErrorCollectorConfig'+    { 'ecFlush' = emailOpsTeam+    , 'ecFlushInterval' = 60000000+    , 'ecFilter' = 'const' 'True'+    }+@++-}+module Snap.ErrorCollector+  ( collectErrors+  , LoggedException(..)+  , ErrorCollectorConfig(..)+  , basicConfig+  ) where++import Control.Applicative+import Control.Concurrent (threadDelay)+import Control.Exception (SomeException)+import Control.Monad (forever, mplus, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Loops (unfoldM')+import Data.Sequence as Seq++import qualified Control.Concurrent.Async as Async+import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.CatchIO as MCIO+import qualified Data.Time as Time+import qualified Snap++-- | An exception logged by @snap-error-collector@, tagged with the request that+-- caused the exception, and the time the exception occured.+data LoggedException = LoggedException+  { leException :: !SomeException+  , leLoggedAt :: !Time.UTCTime+  , leRequest :: !Snap.Request+  } deriving (Show)++-- | How @snap-error-collector@ should run.+data ErrorCollectorConfig = ErrorCollectorConfig+  { ecFlush :: !(Time.UTCTime -> Seq LoggedException -> 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.++  , ecFlushInterval :: !Int+    -- ^ How long (in microseconds) to collect exceptions for until they are sent+    -- (via 'ecFlush'). You can pass '0' here, in which case @snap-error-collector@+    -- will idle until an exception happens.++  , ecFilter :: !(SomeException -> Bool)+    -- ^ A filter on which exceptions should be collected. SomeException's that+    -- return true under this predicate will be collected, other errors will be+    -- not.+  }++-- | A convenient constructor for 'ErrorCollectorConfig' that collects all+-- 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)++-- | 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+     Snap.onUnload (Async.cancel worker)+  where addWrapper q =+          Snap.wrapSite+            (\h ->+               do ex <- MCIO.try h+                  case ex of+                    Left se ->+                      do now <- liftIO Time.getCurrentTime+                         req <- Snap.getRequest+                         when (ecFilter se)+                              (liftIO (STM.atomically+                                         (STM.writeTQueue q+                                                          (LoggedException se now req))))+                         MCIO.throw se+                    Right a -> return a)+        processQueue q =+          do threadDelay ecFlushInterval+             exceptions <- STM.atomically+                             (do liftA2 (<|)+                                        (STM.readTQueue q)+                                        (unfoldM' (STM.tryReadTQueue q)))+             when (not (Seq.null exceptions))+                  (do now <- Time.getCurrentTime+                      ecFlush now exceptions)