diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,3 @@ +# 1.0.0 + +* Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/snap-error-collector.cabal b/snap-error-collector.cabal new file mode 100644 --- /dev/null +++ b/snap-error-collector.cabal @@ -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 diff --git a/src/Snap/ErrorCollector.hs b/src/Snap/ErrorCollector.hs new file mode 100644 --- /dev/null +++ b/src/Snap/ErrorCollector.hs @@ -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)