diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Joel Taylor +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +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/airbrake.cabal b/airbrake.cabal new file mode 100644 --- /dev/null +++ b/airbrake.cabal @@ -0,0 +1,32 @@ +name: airbrake +version: 0.1.0.0 +synopsis: An Airbrake notifier for Haskell +description: Airbrake notifier. +homepage: https://github.com/joelteon/airbrake +license: BSD3 +license-file: LICENSE +author: Joel Taylor +maintainer: me@joelt.io +category: Network +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Airbrake, Airbrake.WebRequest + other-modules: Paths_airbrake + build-depends: base == 4.* + , blaze-markup + , bytestring + , exceptions + , http-conduit + , monad-control + , network + , semigroups + , template-haskell + , text + , transformers + , utf8-string + , wai + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 diff --git a/src/Airbrake.hs b/src/Airbrake.hs new file mode 100644 --- /dev/null +++ b/src/Airbrake.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- | Utilities for notifying Airbrake of errors. An 'Error' type is +-- provided; you can convert any instance of 'Exception' to an 'Error' +-- using 'toError', which uses the exception's 'Typeable' instance. +-- +-- Airbrake requires a stack trace for any reported exception, but stack +-- trace information isn't readily available for Haskell exceptions. +-- 'notifyQ' and 'notifyReqQ' are provided for the purpose of providing the +-- current file position as the stack trace. +module Airbrake ( + -- * Notifying + notify, notifyReq, + notifyQ, notifyReqQ, + + -- * Notification metadata + -- *** Location lists + NonEmpty (..), Location, Locations, + + -- *** Wrapping errors + toError, Error (..), + + -- * Configuration building + APIKey, Environment, + airbrakeConf, defaultApiEndpoint, + AirbrakeConf (..), + Server (..) +) where + +import qualified Airbrake.WebRequest as W +import Control.Exception +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Data.ByteString.Lazy (ByteString) +import Data.Foldable +import Data.List.NonEmpty +import Data.String +import qualified Data.Text as T (Text) +import Data.Text (pack) +import Data.Typeable (typeOf) +import Data.Version +import Language.Haskell.TH.Syntax hiding (report) +import qualified Paths_airbrake as P +import Prelude hiding (error) +import Network.HTTP.Conduit +import qualified Network.Wai as Wai +import Text.Blaze +import Text.Blaze.Internal +import Text.Blaze.Renderer.Utf8 + +type APIKey = String +type Environment = String + +data Error = Error + { errorType :: T.Text + , errorDescription :: T.Text + } + +-- | Information to use when communicating with Airbrake. +data AirbrakeConf = AirbrakeConf + { acApiEndpoint :: String + , acApiKey :: APIKey + , acServer :: Server + } + +-- | Metadata about the server. +data Server = Server + { serverEnvironment :: Environment + , serverAppVersion :: Maybe Version + , serverRoot :: Maybe FilePath + } + +-- | A @(filename, line)@ pair. +type Location = (FilePath, Int) + +type Locations = NonEmpty Location + +-- | @"http:\/\/api.airbrake.io\/notifier_api\/v2\/notices"@ +defaultApiEndpoint :: String +defaultApiEndpoint = "http://api.airbrake.io/notifier_api/v2/notices" + +airbrakeConf :: APIKey -> Environment -> AirbrakeConf +airbrakeConf k env = + AirbrakeConf defaultApiEndpoint k (Server env Nothing Nothing) + +performNotify :: (MonadBaseControl IO m, MonadIO m, MonadThrow m, W.WebRequest req) + => Locations -> AirbrakeConf -> Maybe req -> Error -> m () +performNotify loc conf req e = do + let report = buildReport loc conf req e + req' <- parseUrl (acApiEndpoint conf) + let rq = req' { requestBody = RequestBodyLBS report, method = "POST" } + _ <- withManager (httpLbs rq) + return () + +-- | Notify Airbrake of an exception. +notify :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) + => AirbrakeConf -> Error -> Locations -> m () +notify conf e l = performNotify l conf (Nothing :: Maybe Wai.Request) e + +-- | Notify Airbrake of an exception, providing request metadata along with +-- it. +notifyReq :: (MonadBaseControl IO m, MonadIO m, MonadThrow m, W.WebRequest req) + => AirbrakeConf -> req -> Error -> Locations -> m () +notifyReq conf req e l = performNotify l conf (Just req) e + +-- | 'notify', fetching the current file location using Template Haskell. +-- +-- @ +-- $notifyQ :: ('MonadBaseControl' 'IO' m, 'MonadThrow' m, 'MonadIO' m) +-- => 'AirbrakeConf' -> 'Error' -> m () +-- @ +notifyQ :: Q Exp +notifyQ = do + Loc fn _ _ (st, _) _ <- qLocation + [| \ cc ee -> notify cc ee ((fn, st) :| []) |] + +-- | 'notifyReq', fetching the current file location using Template +-- Haskell. +-- +-- @ +-- $notifyReqQ :: ('MonadBaseControl' 'IO' m, 'MonadThrow' m, 'MonadIO' m, 'W.WebRequest' req) +-- => 'AirbrakeConf' -> req -> 'Error' -> m () +-- @ +notifyReqQ :: Q Exp +notifyReqQ = do + Loc fn _ _ (st, _) _ <- qLocation + [| \ cc r ee -> notifyReq cc r ee ((fn, st) :| []) |] + +-- | Convert any 'Exception' to an 'Error'. +toError :: Exception e => e -> Error +toError (toException -> SomeException e) = + Error (pack (show (typeOf e))) (pack (show e)) + +buildReport :: W.WebRequest a + => Locations -> AirbrakeConf -> Maybe a -> Error -> ByteString +buildReport locs conf req err = renderMarkup $ do + preEscapedText "" + notice ! nversion "2.3" $ do + api_key . toMarkup $ acApiKey conf + + notifier $ do + name "airbrake" + version . toMarkup $ showVersion P.version + url "http://hackage.haskell.org/package/airbrake" + + error $ do + class_ (toMarkup (errorType err)) + message (toMarkup (errorDescription err)) + backtrace $ forM_ locs $ \ (filename, line') -> + line ! file (toValue filename) + ! number (toValue line') + + forM_ req $ \ r -> request $ do + url (toMarkup . show $ W.url r) + forM_ (W.route r) $ \ rt -> component (toMarkup rt) + forM_ (W.action r) $ \ act -> action (toMarkup act) + cgi_data . forM_ (W.otherVars r) $ \ (k, v) -> + var ! key (toValue k) $ toMarkup v + + let serv = acServer conf + server_environment $ do + environment_name . toMarkup $ serverEnvironment serv + forM_ (serverAppVersion serv) $ \ v -> + app_version (toMarkup $ showVersion v) + + forM_ (serverRoot serv) $ \ v -> + project_root (toMarkup v) + where + notice = Parent "notice" "" + name = Parent "name" "" + notifier = Parent "notifier" "" + api_key = Parent "api-key" "" + version = Parent "version" "" + url = Parent "url" "" + class_ = Parent "class" "" + error = Parent "error" "" + message = Parent "message" "" + backtrace = Parent "backtrace" "" + line = Leaf "line" "" + file = attribute "file" " file=\"" + number = attribute "number" " number=\"" + server_environment = Parent "server-environment" "" + environment_name = Parent "environment-name" "" + app_version = Parent "app-version" "" + project_root = Parent "project-root" "" + request = Parent "request" "" + cgi_data = Parent "cgi-data" "" + action = Parent "action" "" + component = Parent "component" "" + var = Parent "var" "" + key = attribute "key" " key=\"" + nversion = attribute "version" " version=\"" diff --git a/src/Airbrake/WebRequest.hs b/src/Airbrake/WebRequest.hs new file mode 100644 --- /dev/null +++ b/src/Airbrake/WebRequest.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Class for extracting metadata from HTTP request types that come from +-- different libraries. +module Airbrake.WebRequest ( + WebRequest (..) +) where + +import Data.ByteString.UTF8 (toString) +import Data.Maybe +import qualified Network.Wai as Wai +import Network.URI + +class WebRequest a where + -- | The request URL. + url :: a -> URI + + -- | Current route. + -- This is a carryover from Rails-style MVC and is optional. + route :: a -> Maybe String + + -- | Controller action being used. + -- This is a carryover from Rails-style MVC and is optional. + action :: a -> Maybe String + + -- | Any other request metadata that you would like to include + -- (server name, user agent, etc.) + otherVars :: a -> [(String, String)] + +-- | @wai@ requests +instance WebRequest Wai.Request where + url req = case parseURI uriS of + Just u -> u + Nothing -> error "Failure producing URI from wai request." + where + uriS = (if Wai.isSecure req then "https://" else "http://") + ++ show (Wai.remoteHost req) + ++ toString (Wai.rawPathInfo req) + ++ toString (Wai.rawQueryString req) + + route _ = Nothing + action _ = Nothing + + otherVars req = catMaybes + [ k "Host" "HTTP_HOST" + , k "User-Agent" "HTTP_USER_AGENT" + , k "Referer" "HTTP_REFERER" + , k "Cookie" "HTTP_COOKIE" + , if Wai.isSecure req then Just ("HTTPS", "on") else Nothing] + where k hdr key = fmap (\ v -> (key, toString v)) + (lookup hdr (Wai.requestHeaders req))