diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for rollbar-wai + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright 2020 Stack Builders Inc. + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# Rollbar WAI + +Provides error reporting capabilities to +[WAI](http://hackage.haskell.org/package/wai) based applications through +[Rollbar API](https://explorer.docs.rollbar.com/). + +## Getting Started + +Read the instructions [here](../README.md). + +## Example + +For a complete example check the link [here](example/Main.hs). 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/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,18 @@ +module Main + ( main + ) where + +import Network.Wai +import Network.Wai.Handler.Warp +import Rollbar.Client (readSettings) +import Rollbar.Wai + +main :: IO () +main = do + settings <- readSettings "rollbar.yaml" + runSettings + (setOnException (rollbarOnException settings) defaultSettings) + app + +app :: Application +app _ _ = error "Boom" diff --git a/rollbar-wai.cabal b/rollbar-wai.cabal new file mode 100644 --- /dev/null +++ b/rollbar-wai.cabal @@ -0,0 +1,102 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 36882de3e15bbc25fa5b54c1ee7d9dbe96436e87f4502b002a3a388508677741 + +name: rollbar-wai +version: 0.1.0 +synopsis: Provides error reporting capabilities to WAI based applications through Rollbar API. + +description: Please see the README on GitHub at + +homepage: https://github.com/stackbuilders/rollbar-haskell#readme +bug-reports: https://github.com/stackbuilders/rollbar-haskell/issues +author: Stack Builders Inc. +maintainer: Sebastián Estrella +copyright: 2020 Stack Builders Inc. +license: MIT +license-file: LICENSE +tested-with: GHC ==8.6.5, GHC ==8.8.4, GHC ==8.10.2 +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/stackbuilders/rollbar-haskell + +flag example + description: Build the example + manual: False + default: False + +library + exposed-modules: + Rollbar.Wai + other-modules: + Paths_rollbar_wai + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson >=1.4 && <2 + , base >=4.12 && <5 + , bytestring >=0.10 && <1 + , case-insensitive >=1.2 && <2 + , http-types >=0.12 && <1 + , rollbar-client >=0.1 && <1 + , text >=1.2 && <2 + , unordered-containers >=0.2 && <1 + , wai >=3.2 && <4 + , wai-extra >=3.0 && <4 + default-language: Haskell2010 + +executable wai-example + main-is: Main.hs + other-modules: + Paths_rollbar_wai + hs-source-dirs: + example + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12 && <5 + , rollbar-client + , rollbar-wai + , wai + , warp + if flag(example) + buildable: True + else + buildable: False + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Rollbar.WaiSpec + Paths_rollbar_wai + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover >=2.7 && <3 + build-depends: + aeson + , base >=4.12 && <5 + , hspec >=2.7 && <3 + , http-types + , mtl >=2.2 && <3 + , process >=1.6 && <2 + , req >=2.1 && <4 + , rollbar-client + , rollbar-wai + , text + , unordered-containers + , wai + , warp >=3.3 && <4 + default-language: Haskell2010 diff --git a/src/Rollbar/Wai.hs b/src/Rollbar/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Rollbar/Wai.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Rollbar.Wai +-- Copyright: (c) 2020 Stack Builders Inc. +-- License: MIT +-- Maintainer: Sebastián Estrella +-- +-- For a fully working example check the following link: +-- +-- +module Rollbar.Wai + ( rollbarOnException + , rollbarOnExceptionWith + , mkRequest + ) where + +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HM +import qualified Data.Text.Encoding as T +import qualified Network.Wai as W +import qualified Network.Wai.Parse as W +import qualified Network.Wai.Request as W + +import Control.Concurrent (forkIO) +import Control.Exception +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Aeson +import Network.HTTP.Types (renderQuery) +import Rollbar.Client + +-- | Sends the captured 'SomeException' to Rollbar API using the given +-- 'Settings'. Under the hood, this function uses 'createItem' function from +-- rollbar-client. +-- +-- __Example__ +-- +-- > settings <- readSettings "rollbar.yaml" +-- > runSettings +-- > (setOnException (rollbarOnException settings) defaultSettings) +-- > app +-- +-- @since 0.1.0 +rollbarOnException + :: MonadIO m + => Settings + -> Maybe W.Request + -> SomeException + -> m () +rollbarOnException = rollbarOnExceptionWith (void . createItem) + +-- | Similar to 'rollbarOnExceptionWith', but it allows customize the function +-- used to send the 'Item' to Rollbar. +-- +-- @since 0.1.0 +rollbarOnExceptionWith + :: MonadIO m + => (Item -> Rollbar ()) + -> Settings + -> Maybe W.Request + -> SomeException + -> m () +rollbarOnExceptionWith f settings waiRequest ex = + void $ liftIO $ forkIO $ runRollbar settings $ do + item <- mkItem $ PayloadTrace $ Trace [] $ mkException ex + request <- mapM mkRequest waiRequest + f item + { itemFramework = Just "wai" + , itemRequest = request + } + +-- | Transforms a Wai 'W.Request' into a Rollbar 'Request'. +-- +-- @since 0.1.0 +mkRequest :: MonadIO m => W.Request -> m Request +mkRequest req = liftIO $ do + (params, _) <- W.parseRequestBody ignoreFiles req + return Request + { requestUrl = T.decodeUtf8 $ mconcat + [ W.guessApproot req + , W.rawPathInfo req + , W.rawQueryString req + ] + , requestMethod = T.decodeUtf8 $ W.requestMethod req + , requestHeaders = HM.fromList $ toHeader <$> W.requestHeaders req + , requestParams = mempty + , requestGet = HM.fromList $ toQuery <$> W.queryString req + , requestQueryStrings = T.decodeUtf8 $ renderQuery False $ W.queryString req + , requestPost = HM.fromList $ fmap toParam params + , requestBody = "" + , requestUserIp = "" + } + where + toHeader (key, value) = + (T.decodeUtf8 $ CI.original key, toJSON $ T.decodeUtf8 value) + toQuery (key, value) = + (T.decodeUtf8 key, toJSON $ T.decodeUtf8 <$> value) + toParam (key, value) = + (T.decodeUtf8 key, toJSON $ T.decodeUtf8 value) + +ignoreFiles :: W.BackEnd () +ignoreFiles _ _ _ = pure () diff --git a/test/Rollbar/WaiSpec.hs b/test/Rollbar/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rollbar/WaiSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Rollbar.WaiSpec + ( spec + ) where + +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Network.Wai as W +import qualified Network.Wai.Handler.Warp as W + +import Control.Concurrent (threadDelay) +import Control.Monad (join) +import Control.Monad.IO.Class +import Data.Aeson +import Data.IORef +import Network.HTTP.Req +import Network.HTTP.Types (status200, status404) +import Rollbar.Client +import Rollbar.Wai (rollbarOnExceptionWith) +import Test.Hspec + +spec :: Spec +spec = before getSettingsAndItemRef $ + describe "rollbarOnExceptionWith" $ do + context "when the response status code is 200" $ + it "does not trigger a call to Rollbar" $ + withApp $ \itemRef warpPort -> do + let url = http "localhost" /: "success" + response <- runReq + defaultHttpConfig + (req GET url NoReqBody bsResponse $ port warpPort) + responseStatusCode response `shouldBe` 200 + responseBody response `shouldBe` "OK" + threadDelay 500 + readIORef itemRef `shouldReturn` Nothing + + context "when the response status code is not 200" $ + it "triggers a call to Rollbar" $ + withApp $ \itemRef warpPort -> do + let url = http "localhost" /: "error" + response <- fmap responseBody $ runReq + (defaultHttpConfig { httpConfigCheckResponse = \_ _ _ -> Nothing }) + (req GET url NoReqBody bsResponse $ port warpPort) + response `shouldBe` "Something went wrong" + threadDelay 500 + let portAsText = T.pack $ show warpPort + join . fmap itemRequest <$> readIORef itemRef `shouldReturn` Just + ( Request + { requestUrl = "http://localhost:" <> portAsText <> "/error" + , requestMethod = "GET" + , requestHeaders = HM.fromList + [ ("Accept-Encoding", "gzip") + , ("Host", String $ "localhost:" <> portAsText) + ] + , requestParams = mempty + , requestGet = mempty + , requestQueryStrings = "" + , requestPost = mempty + , requestBody = "" + , requestUserIp = "" + } + ) + + +getSettingsAndItemRef :: IO (Settings, IORef (Maybe Item)) +getSettingsAndItemRef = + (,) <$> readSettings "rollbar.yaml" + <*> newIORef Nothing + +withApp + :: (IORef (Maybe Item) -> W.Port -> IO a) + -> (Settings, IORef (Maybe Item)) + -> IO a +withApp f (settings, itemRef) = do + let waiSettings = W.setOnException + (rollbarOnExceptionWith (createItemFake itemRef) settings) + W.defaultSettings + W.withApplicationSettings waiSettings (return app) $ f itemRef + +app :: W.Application +app wrequest respond = + case W.rawPathInfo wrequest of + "/error" -> error "Boom" + "/success" -> respond $ W.responseLBS status200 [] "OK" + _ -> respond $ W.responseLBS status404 [] "Not Found" + +createItemFake :: IORef (Maybe Item) -> Item -> Rollbar () +createItemFake itemRef item = do + requestModifier <- getRequestModifier + liftIO $ writeIORef itemRef $ Just $ + item { itemRequest = requestModifier <$> itemRequest item } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}