rollbar-client (empty) → 0.1.0

raw patch · 14 files changed

+1121/−0 lines, 14 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, directory, exceptions, hspec, mtl, process, req, rollbar-client, text, unordered-containers, yaml

Files

• ChangeLog.md +3/−0
• LICENSE +19/−0
• README.md +12/−0
• Setup.hs +2/−0
• example/Main.hs +46/−0
• rollbar-client.cabal +100/−0
• src/Rollbar/Client.hs +61/−0
• src/Rollbar/Client/Deploy.hs +115/−0
• src/Rollbar/Client/Internal.hs +51/−0
• src/Rollbar/Client/Item.hs +401/−0
• src/Rollbar/Client/Ping.hs +32/−0
• src/Rollbar/Client/Settings.hs +133/−0
• test/Rollbar/ClientSpec.hs +145/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for rollbar-client++## Unreleased changes

@@ -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.

@@ -0,0 +1,12 @@+# Rollbar Client++Core library to communicate with [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).

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

@@ -0,0 +1,46 @@+module Main+  ( main+  ) where++import qualified Data.Text as Text+import Rollbar.Client+import System.Environment (getArgs)++-- To load this example using Cabal, run:+--+-- ROLLBAR_TOKEN=<...> cabal repl --flags example client-example+--+-- Or, if using Stack, replace the Cabal part with:+--+-- stack ghci --flag rollbar-client:example rollbar-client:exe:client-example+--+-- You can then test creating a Rollbar item. If there are no arguments, the+-- example uses the 'withRollbar' function, which automatically creates a+-- Rollbar item after catching an exception:+--+-- >>> :main+-- *** Exception: Boom+-- CallStack (from HasCallStack):+--   error, called at .../rollbar-haskell/rollbar-client/example/Main.hs:39:30 in main:Main+--+-- If there are arguments, the example uses the 'runRollbar' function, which+-- allows us to create and send our own Rollbar items. In this case, we send+-- the arguments as message and change the level to warning:+--+-- >>> :main Warning!+-- ItemId "55c3e83084d943d6af3bf940e80513e1"++main :: IO ()+main = do+  settings <- readSettings "rollbar.yaml"+  args <- getArgs+  case args of+    [] ->+      withRollbar settings $ error "Boom"+    _ -> do+      itemId <-+        runRollbar settings $ do+          let body = Text.pack (unwords args)+          item <- mkItem (PayloadMessage (Message body mempty))+          createItem item { itemLevel = Just LevelWarning }+      print itemId

@@ -0,0 +1,100 @@+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: b3e835bcc225cb66a06268126c5a04b48d06fd90b55677e26219ecfe207068d3++name:           rollbar-client+version:        0.1.0+synopsis:       Core library to communicate with Rollbar API.+description:    Please see the README on GitHub at+                <https://github.com/stackbuilders/rollbar-haskell/tree/master/rollbar-client>+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 <sestrella@stackbuilders.com>+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.Client+  other-modules:+      Rollbar.Client.Deploy+      Rollbar.Client.Internal+      Rollbar.Client.Item+      Rollbar.Client.Ping+      Rollbar.Client.Settings+      Paths_rollbar_client+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson >=1.4 && <2+    , base >=4.12 && <5+    , bytestring >=0.10 && <1+    , directory >=1.3 && <2+    , exceptions >=0.10 && <1+    , mtl >=2.2 && <3+    , process >=1.6 && <2+    , req >=2.1 && <4+    , text >=1.2 && <2+    , unordered-containers >=0.2 && <1+    , yaml >=0.11 && <1+  default-language: Haskell2010++executable client-example+  main-is: Main.hs+  other-modules:+      Paths_rollbar_client+  hs-source-dirs:+      example+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.12 && <5+    , rollbar-client+    , text+  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.ClientSpec+      Paths_rollbar_client+  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+    , mtl+    , rollbar-client+    , text+    , unordered-containers+    , yaml+  default-language: Haskell2010

@@ -0,0 +1,61 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module: Rollbar.Client+-- Copyright: (c) 2020 Stack Builders Inc.+-- License: MIT+-- Maintainer: Sebastián Estrella <sestrella@stackbuilders.com>+module Rollbar.Client+  (+    -- * Deploy+    module Rollbar.Client.Deploy+    -- * Item+  , module Rollbar.Client.Item+    -- * Ping+  , module Rollbar.Client.Ping+    -- * Settings+  , module Rollbar.Client.Settings+  , Rollbar(..)+  , withRollbar+  , runRollbar+  ) where++import Control.Monad (void)+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (ReaderT(..), ask)+import Control.Monad.Trans (MonadTrans(..))+import Network.HTTP.Req+import Rollbar.Client.Deploy+import Rollbar.Client.Item+import Rollbar.Client.Ping+import Rollbar.Client.Settings++newtype Rollbar a = Rollbar (ReaderT Settings Req a)+  deriving+    ( Applicative+    , Functor+    , Monad+    , MonadIO+    )++instance MonadHttp Rollbar where+  handleHttpException = Rollbar . lift . handleHttpException++instance HasSettings Rollbar where+  getSettings = Rollbar ask++-- | Runs a computation, captures any 'E.SomeException' threw, and send it to+-- Rollbar.+withRollbar :: (MonadCatch m, MonadIO m) => Settings -> m a -> m a+withRollbar settings f = f `catch` \e -> do+  void $ runRollbar settings $ do+    item <- mkItem $ PayloadTrace $ Trace [] $ mkException (e :: SomeException)+    createItem item++  throwM e++-- | Run a computation in 'Rollbar' monad.+runRollbar :: MonadIO m => Settings -> Rollbar a -> m a+runRollbar settings (Rollbar f) = runReq defaultHttpConfig $+  runReaderT f settings

@@ -0,0 +1,115 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Rollbar.Client.Deploy+  ( -- ** Requests+    Deploy(..)+  , mkDeploy+  , Status(..)+    -- ** Responses+  , DeployId(..)+    -- ** Endpoints+  , reportDeploy+  ) where++import qualified Data.Text as T++import Control.Monad.IO.Class (MonadIO(..))+import Data.Aeson+import Data.Text+import Network.HTTP.Req+import Rollbar.Client.Internal+import Rollbar.Client.Settings+import System.Environment (lookupEnv)++data Deploy = Deploy+  { deployEnvironment :: Environment+    -- ^ Environment to which the revision was deployed.+  , deployRevision :: Revision+    -- ^ Git SHA of revision being deployed.+  , deployRollbarUsername :: Maybe Text+    -- ^ Rollbar username of person who deployed.+  , deployLocalUsername :: Maybe Text+    -- ^ Local username of person who deployed. Displayed in web app if no+    -- 'deployRollbarUsername' was specified.+  , deployComment :: Maybe Text+    -- ^ Additional text to include with the deploy.+  , deployStatus :: Maybe Status+    -- ^ Status of the deployment.+  } deriving (Eq, Show)++instance ToJSON Deploy where+  toJSON Deploy{..} = object+    [ "environment" .= deployEnvironment+    , "revision" .= deployRevision+    , "rollbar_username" .= deployRollbarUsername+    , "local_username" .= deployLocalUsername+    , "comment" .= deployComment+    , "status" .= deployStatus+    ]++-- | Builds a 'Deploy' based on a 'Revision'.+--+-- __Example__+--+-- > getRevision >>= mkDeploy+mkDeploy+  :: (HasSettings m, MonadIO m)+  => Revision+  -> m Deploy+mkDeploy revision = do+  env <- settingsEnvironment <$> getSettings+  muser <- fmap T.pack <$> liftIO (lookupEnv "USER")+  return Deploy+    { deployEnvironment = env+    , deployRevision = revision+    , deployRollbarUsername = Nothing+    , deployLocalUsername = muser+    , deployComment = Nothing+    , deployStatus = Just StatusSucceeded+    }++-- | Status of the deployment.+data Status+  = StatusStarted+  | StatusSucceeded+  | StatusFailed+  | StatusTimedOut+  deriving (Eq, Show)++instance ToJSON Status where+  toJSON StatusStarted = String "started"+  toJSON StatusSucceeded = String "succeeded"+  toJSON StatusFailed = String "failed"+  toJSON StatusTimedOut = String "timed_out"++newtype DeployId = DeployId Integer+  deriving (Eq, Num, Ord, Show)++instance FromJSON DeployId where+  parseJSON = withObject "DeployId" $ \o ->+    DeployId <$> o .: "deploy_id"++-- | Tracks a deploy in Rollbar.+--+-- __Example__+--+-- > settings <- readSettings "rollbar.yaml"+-- > runRollbar settings $ do+-- >   deploy <- getRevision >>= mkDeploy+-- >   reportDeploy deploy+--+-- __Reference__+--+-- <https://explorer.docs.rollbar.com/#operation/post-deploy>+reportDeploy+  :: (HasSettings m, MonadHttp m)+  => Deploy+  -> m DeployId+reportDeploy deploy =+  fmap+    (unDataResponse . responseBody)+    (rollbar POST url (ReqBodyJson deploy) jsonResponse)+  where+    url = baseUrl /: "deploy"

@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Rollbar.Client.Internal+  ( DataResponse(..)+  , ResultResponse(..)+  , rollbar+  , baseUrl+  ) where++import Data.Aeson+import Data.Proxy (Proxy)+import Network.HTTP.Req+import Rollbar.Client.Settings++newtype DataResponse a = DataResponse { unDataResponse :: a }+  deriving (Eq, Show)++instance FromJSON a => FromJSON (DataResponse a) where+  parseJSON = withObject "DataResponse" $ \o ->+    DataResponse <$> o .: "data"++data ResultResponse a = ResultResponse+  { resultResponseErr :: Integer+  , resultResponseResult :: a+  } deriving (Eq, Show)++instance FromJSON a => FromJSON (ResultResponse a) where+  parseJSON = withObject "ResultResponse" $ \o ->+    ResultResponse <$> o .: "err"+                   <*> o .: "result"++rollbar+  :: ( HasSettings m+     , HttpBody body+     , HttpBodyAllowed (AllowsBody method) (ProvidesBody body)+     , HttpMethod method+     , HttpResponse response+     , MonadHttp m+     )+  => method+  -> Url 'Https+  -> body+  -> Proxy response+  -> m response+rollbar method url body response = do+  Token token <- settingsToken <$> getSettings+  req method url body response $ header "X-Rollbar-Access-Token" token++baseUrl :: Url 'Https+baseUrl = https "api.rollbar.com" /: "api" /: "1"

@@ -0,0 +1,401 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Rollbar.Client.Item+  ( -- ** Requests+    Item(..)+  , mkItem+  , Body(..)+  , Payload(..)+  , Trace(..)+  , Frame(..)+  , Context(..)+  , Exception(..)+  , mkException+  , Message(..)+  , Level(..)+  , mkLevel+  , Request(..)+  , getRequestModifier+  , Server(..)+  , Notifier(..)+  , defaultNotifier+    -- ** Responses+  , ItemId(..)+    -- ** Endpoints+  , createItem+  ) where++import qualified Control.Exception as E+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++import Control.Monad.IO.Class (MonadIO(..))+import Data.Aeson+import Data.Maybe (catMaybes)+import Data.Monoid (Endo(..))+import Data.Text+import Network.HTTP.Req+import Rollbar.Client.Internal+import Rollbar.Client.Settings+import System.Directory (getCurrentDirectory)+import System.Info (arch, os)++data Item = Item+  { itemEnvironment :: Environment+    -- ^ The name of the environment in which this occurrence was seen. A+    -- string up to 255 characters. For best results, use "production" or+    -- "prod" for your production environment.  You don't need to configure+    -- anything in the Rollbar UI for new environment names; we'll detect them+    -- automatically.+  , itemBody :: Body+    -- ^ The main data being sent. It can either be a message, an exception, or+    -- a crash report.+  , itemLevel :: Maybe Level+    -- ^ The severity level. One of: "critical", "error", "warning", "info",+    -- "debug" Defaults to "error" for exceptions and "info" for messages.  The+    -- level of the *first* occurrence of an item is used as the item's level.+  -- timestamp+  -- code_version+  , itemPlatform :: Maybe Text+    -- ^ The platform on which this occurred. Meaningful platform names:+    -- "browser", "android", "ios", "flash", "client", "heroku",+    -- "google-app-engine" If this is a client-side event, be sure to specify+    -- the platform and use a post_client_item access token.+  , itemLanguage :: Maybe Text+    -- ^ The name of the language your code is written in.  This can affect the+    -- order of the frames in the stack trace. The following languages set the+    -- most recent call first - 'ruby', 'javascript', 'php', 'java',+    -- 'objective-c', 'lua' It will also change the way the individual frames+    -- are displayed, with what is most consistent with users of the language.+  , itemFramework :: Maybe Text+    -- ^ The name of the framework your code uses.+  -- context+  -- request+  , itemRequest :: Maybe Request+    -- ^ Data about the request this event occurred in.+  -- person+  , itemServer :: Maybe Server+    -- ^ Data about the server related to this event.+  -- client+  -- custom+  -- fingerprint+  -- title+  -- uuid+  , itemNotifier :: Notifier+    -- ^ Describes the library used to send this event.+  } deriving (Eq, Show)++instance ToJSON Item where+  toJSON Item{..} = object+    [ "data" .= object+        [ "environment" .= itemEnvironment+        , "body" .= itemBody+        , "level" .= itemLevel+        , "platform" .= itemPlatform+        , "language" .= itemLanguage+        , "framework" .= itemFramework+        , "request" .= itemRequest+        , "server" .= itemServer+        , "notifier" .= itemNotifier+        ]+    ]++-- | Builds an 'Item' based on a 'Payload'.+mkItem+  :: (HasSettings m, MonadIO m)+  => Payload+  -> m Item+mkItem payload = do+  environment <- settingsEnvironment <$> getSettings+  root <- liftIO getCurrentDirectory+  return Item+    { itemEnvironment = environment+    , itemBody = Body+        { bodyPayload = payload+        }+    , itemLevel = Just $ mkLevel payload+    , itemPlatform = Just $ T.pack os+    , itemLanguage = Just "haskell"+    , itemFramework = Nothing+    , itemRequest = Nothing+    , itemServer = Just Server+        { serverCpu = Just $ T.pack arch+        , serverHost = Nothing+        , serverRoot = Just $ T.pack root+        , serverBranch = Nothing+        , serverCodeVersion = Nothing+        }+    , itemNotifier = defaultNotifier+    }++-- | The main data being sent. It can either be a message, an exception, or a+-- crash report.+newtype Body = Body { bodyPayload :: Payload }+  deriving (Eq, Show)++instance ToJSON Body where+  toJSON Body{..} = object+    [ case bodyPayload of+        (PayloadTrace trace) -> ("trace", toJSON trace)+        (PayloadTraceChain traceChain) -> ("trace_chain", toJSON traceChain)+        (PayloadMessage message) -> ("message", toJSON message)+    ]++data Payload+  = PayloadTrace Trace+  | PayloadTraceChain [Trace]+  | PayloadMessage Message+  deriving (Eq, Show)++data Trace = Trace+  { traceFrames :: [Frame]+    -- ^ A list of stack frames, ordered such that the most recent call is last+    -- in the list.+  , traceException :: Exception+  } deriving (Eq, Show)++instance ToJSON Trace where+  toJSON Trace{..} = object+    [ "frames" .= traceFrames+    , "exception" .= traceException+    ]++data Frame = Frame+  { frameFilename :: Text+    -- ^ The filename including its full path.+  , frameLineno :: Maybe Integer+    -- ^ The line number as an integer.+  , frameColno :: Maybe Integer+    -- ^ The column number as an integer.+  , frameMethod :: Maybe Text+    -- ^ The method or function name.+  , frameCode :: Maybe Text+    -- ^ The line of code.+  , frameClassName :: Maybe Text+    -- ^ A string containing the class name.  Used in the UI when the payload's+    -- top-level "language" key has the value "java".+  , frameContext :: Maybe Context+    -- ^ Additional code before and after the "code" line.+  } deriving (Eq, Show)++instance ToJSON Frame where+  toJSON Frame{..} = object+    [ "filename" .= frameFilename+    , "lineno" .= frameLineno+    , "colno" .= frameColno+    , "method" .= frameMethod+    , "code" .= frameCode+    , "class_name" .= frameClassName+    , "context" .= frameContext+    ]++-- | Additional code before and after the "code" line.+data Context = Context+  { contextPre :: [Text]+    -- ^ List of lines of code before the "code" line.+  , contextPost :: [Text]+    -- ^ List of lines of code after the "code" line.+  } deriving (Eq, Show)++instance ToJSON Context where+  toJSON Context{..} = object+    [ "pre" .= contextPre+    , "post" .= contextPost+    ]++-- | An object describing the exception instance.+data Exception = Exception+  { exceptionClass :: Text+    -- ^ The exception class name.+  , exceptionMessage :: Maybe Text+    -- ^ The exception message, as a string.+  , exceptionDescription :: Maybe Text+    -- ^ An alternate human-readable string describing the exception Usually+    -- the original exception message will have been machine-generated; you can+    -- use this to send something custom.+  } deriving (Eq, Show)++instance ToJSON Exception where+  toJSON Exception{..} = object+    [ "class" .= exceptionClass+    , "message" .= exceptionMessage+    , "description" .= exceptionDescription+    ]++-- | Builds a 'Exception' based on 'E.SomeException'.+mkException :: E.Exception e => e -> Exception+mkException e = Exception+  { exceptionClass = T.pack $ E.displayException e+  , exceptionMessage = Nothing+  , exceptionDescription = Nothing+  }++data Message = Message+  { messageBody :: Text+  , messageMetadata :: Object+  } deriving (Eq, Show)++instance ToJSON Message where+  toJSON Message{..} = Object $+    HM.insert "body" (toJSON messageBody) messageMetadata++-- | The severity level. One of: "critical", "error", "warning", "info",+-- "debug" Defaults to "error" for exceptions and "info" for messages. The+-- level of the *first* occurrence of an item is used as the item's level.+data Level+  = LevelCritical+  | LevelError+  | LevelWarning+  | LevelInfo+  | LevelDebug+  deriving (Eq, Show)++instance ToJSON Level where+  toJSON = \case+    LevelCritical -> "critical"+    LevelError -> "error"+    LevelWarning -> "warning"+    LevelInfo -> "info"+    LevelDebug -> "debug"++-- | Builds a 'Level' based on a 'Payload'.+mkLevel :: Payload -> Level+mkLevel (PayloadMessage _) = LevelInfo+mkLevel _ = LevelError++-- | Data about the request this event occurred in.+data Request = Request+  { requestUrl :: Text+    -- ^ Full URL where this event occurred.+  , requestMethod :: Text+    -- ^ The request method.+  , requestHeaders :: Object+    -- ^ Object containing the request headers.+  , requestParams :: Object+    -- ^ Any routing parameters (i.e. for use with Rails Routes).+  , requestGet :: Object+    -- ^ Query string params.+  , requestQueryStrings :: Text+    -- ^ The raw query string.+  , requestPost :: Object+    -- ^ POST params.+  , requestBody :: Text+    -- ^ The raw POST body.+  , requestUserIp :: Text+    -- ^ Can also be the special value "$remote_ip", which will be replaced+    -- with the source IP of the API request.  Will be indexed, as long as it+    -- is a valid IPv4 address.+  } deriving (Eq, Show)++instance ToJSON Request where+  toJSON Request{..} = object+    [ "url" .= requestUrl+    , "method" .= requestMethod+    , "headers" .= requestHeaders+    , "params" .= requestParams+    , "GET" .= requestGet+    , "query_string" .= requestQueryStrings+    , "POST" .= requestPost+    , "body" .= requestBody+    , "user_ip" .= requestUserIp+    ]++-- | Pulls 'RequestModifiers' out of 'Settings' and build a list of 'Endo+-- Request' which are folded as a single request modifier function.+getRequestModifier :: (HasSettings m, Monad m) => m (Request -> Request)+getRequestModifier = do+  RequestModifiers{..} <- settingsRequestModifiers <$> getSettings+  return $ appEndo $ mconcat $ catMaybes+    [ withHeaders . excludeNames <$> requestModifiersExcludeHeaders+    , withParams . excludeNames <$> requestModifiersExcludeParams+    , withHeaders . includeNames <$> requestModifiersIncludeHeaders+    , withParams . includeNames <$> requestModifiersIncludeParams+    ]+  where+    withHeaders f = Endo $ \request -> request+      { requestHeaders = f $ requestHeaders request }+    withParams f = Endo $ \request -> request+      { requestParams = f $ requestParams request }+    excludeNames names = HM.filterWithKey $ \name _ -> name `notElem` names+    includeNames names = HM.filterWithKey $ \name _ -> name `elem` names++-- | Data about the server related to this event.+data Server = Server+  { serverCpu :: Maybe Text+    -- ^ A string up to 255 characters.+  , serverHost :: Maybe Text+    -- ^ The server hostname. Will be indexed.+  , serverRoot :: Maybe Text+    -- ^ Path to the application code root, not including the final slash.+    -- Used to collapse non-project code when displaying tracebacks.+  , serverBranch :: Maybe Text+    -- ^ Name of the checked-out source control branch. Defaults to "master".+  , serverCodeVersion :: Maybe Text+    -- ^ String describing the running code version on the server.+  } deriving (Eq, Show)++instance ToJSON Server where+  toJSON Server{..} = object+    [ "cpu" .= serverCpu+    , "host" .= serverHost+    , "root" .= serverRoot+    , "branch" .= serverBranch+    , "code_version" .= serverCodeVersion+    ]++data Notifier = Notifier+  { notifierName :: Text+  , notifierVersion :: Text+  } deriving (Eq, Show)++instance ToJSON Notifier where+  toJSON Notifier{..} = object+    [ "name" .= notifierName+    , "version" .= notifierVersion+    ]++-- | Returns information about this package such as the name and version.+defaultNotifier :: Notifier+defaultNotifier = Notifier+  { notifierName = "rollbar-client"+  , notifierVersion = "0.1.0"+  }++newtype ItemId = ItemId Text+  deriving (Eq, Show)++instance FromJSON ItemId where+  parseJSON = withObject "ItemId" $ \o ->+    ItemId <$> o .: "uuid"++-- | Reports an occurrence (exception or message) to Rollbar.+--+-- __Example__+--+-- > settings <- readSettings "rollbar.yaml"+-- > runRollbar settings $ do+-- >   item <- mkItem $ PayloadTrace $ Trace [] $ Exception+-- >     { exceptionClass = "NameError"+-- >     , exceptionMessage = Just "global name 'foo' is not defined"+-- >     , exceptionDescription = Just "Something went wrong while trying to save the user object"+-- >     }+-- >   createItem item+--+-- __Reference__+--+-- <https://explorer.docs.rollbar.com/#operation/create-item>+createItem+  :: (HasSettings m, MonadHttp m)+  => Item+  -> m ItemId+createItem item = do+  requestModifier <- getRequestModifier+  fmap+    (resultResponseResult . responseBody)+    (rollbar POST url (body requestModifier) jsonResponse)+  where+    url = baseUrl /: "item" /: ""+    body requestModifier = ReqBodyJson $+      item { itemRequest = requestModifier <$> itemRequest item }

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module Rollbar.Client.Ping+  ( -- ** Requests+    Pong(..)+    -- ** Endpoints+  , ping+  ) where++import Control.Monad (void)+import Network.HTTP.Req+import Rollbar.Client.Internal (baseUrl)++data Pong = Pong+  deriving (Eq, Show)++-- | Pings Rollbar API server, on success returns 'Pong'.+--+-- __Example__+--+-- > settings <- readSettings "rollbar.yaml"+-- > runRollbar settings ping+--+-- __Reference__+--+-- <https://explorer.docs.rollbar.com/#section/Ping>+ping :: MonadHttp m => m Pong+ping = do+  void $ req GET url NoReqBody ignoreResponse mempty+  return Pong+  where+    url = baseUrl /: "status" /: "ping"

@@ -0,0 +1,133 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Rollbar.Client.Settings+  ( HasSettings(..)+  , Settings(..)+  , readSettings+  , Token(..)+  , Environment(..)+  , Revision(..)+  , getRevision+  , getRevisionMaybe+  , RequestModifiers(..)+  , defaultRequestModifiers+  ) where++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Control.Exception (Exception, throwIO)+import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Aeson+import Data.ByteString (ByteString)+import Data.List.NonEmpty+import Data.Text (Text)+import Data.Yaml.Config (loadYamlSettings, requireEnv)+import System.Directory (findExecutable)+import System.Process++-- | Typeclass used to pull Rollbar 'Settings' out of a given 'Monad'.+class HasSettings m where+  getSettings :: m Settings++-- | General settings required to interact with Rollbar API.+data Settings = Settings+  { settingsToken :: Token+    -- ^ Rollbar API authentication token.+  , settingsEnvironment :: Environment+    -- ^ Environment to which the revision was deployed.+  , settingsRevision :: Maybe Revision+    -- ^ Git SHA of revision being deployed.+  , settingsRequestModifiers :: RequestModifiers+  } deriving (Eq, Show)++instance FromJSON Settings where+  parseJSON = withObject "Settings" $ \o ->+    Settings <$> o .: "token"+             <*> o .: "environment"+             <*> o .:? "revision" .!= Nothing+             <*> o .:? "request_modifiers" .!= defaultRequestModifiers++-- | Reads 'Settings' from a YAML file.+readSettings :: MonadIO m => FilePath -> m Settings+readSettings path = liftIO $ loadYamlSettings [path] [] requireEnv++newtype Token = Token ByteString+  deriving (Eq, Show)++instance FromJSON Token where+  parseJSON = withText "Token" $ pure . Token . T.encodeUtf8++-- | Environment to which the revision was deployed.+newtype Environment = Environment Text+  deriving (Eq, FromJSON, Show, ToJSON)++-- | Git SHA of revision being deployed.+newtype Revision = Revision Text+  deriving (Eq, FromJSON, Show, ToJSON)++-- | Similar to 'getRevisionMaybe', but it throws a 'RevisionNotFound' if the+-- 'Revision' is not found.+getRevision+  :: (HasSettings m, MonadIO m)+  => m Revision+getRevision = do+  mrevision <- getRevisionMaybe+  case mrevision of+    Nothing -> liftIO $ throwIO RevisionNotFound+    Just revision -> return revision++-- | Gets the 'Revision' from 'Settings' (if the value is present), otherwise+-- gets the 'Revision' from @git@ (if the executable is present) directly+-- by running the following command @git rev-parse HEAD@, if none of them are+-- present (neither the value nor the executable) returns 'Nothing'.+getRevisionMaybe+  :: (HasSettings m, MonadIO m)+  => m (Maybe Revision)+getRevisionMaybe = do+  mrevision <- settingsRevision <$> getSettings+  case mrevision of+    Nothing -> do+      mgitPath <- liftIO $ findExecutable "git"+      forM mgitPath $ \gitPath ->+        mkRevision <$> liftIO (readProcess gitPath ["rev-parse", "HEAD"] "")+    Just revision -> return $ Just revision+  where+    mkRevision = Revision . T.stripEnd . T.pack++-- | Represents a list of 'Request' modifiers that are combined by+-- 'getRequestModifier' into a single function.+data RequestModifiers = RequestModifiers+  { requestModifiersExcludeHeaders :: Maybe (NonEmpty Text)+    -- ^ A list of 'Request' header names to be excluded.+  , requestModifiersExcludeParams :: Maybe (NonEmpty Text)+    -- ^ A list of 'Request' param names to be excluded.+  , requestModifiersIncludeHeaders :: Maybe (NonEmpty Text)+    -- ^ A list of 'Request' header names to be included.+  , requestModifiersIncludeParams :: Maybe (NonEmpty Text)+    -- ^ A list of 'Request' params names to be included.+  } deriving (Eq, Show)++instance FromJSON RequestModifiers where+  parseJSON = withObject "RequestModifiers" $ \o ->+    RequestModifiers <$> o .:? "exclude_headers" .!= Nothing+                     <*> o .:? "exclude_params" .!= Nothing+                     <*> o .:? "include_headers" .!= Nothing+                     <*> o .:? "include_params" .!= Nothing++-- | Returns an empty 'RequestModifiers', the function produced by+-- 'getRequestModifier' given this values is equivalent to 'id'.+defaultRequestModifiers :: RequestModifiers+defaultRequestModifiers = RequestModifiers+  { requestModifiersExcludeHeaders = Nothing+  , requestModifiersExcludeParams = Nothing+  , requestModifiersIncludeHeaders = Nothing+  , requestModifiersIncludeParams = Nothing+  }++data RollbarError = RevisionNotFound+  deriving (Eq, Show)++instance Exception RollbarError

@@ -0,0 +1,145 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Rollbar.ClientSpec+  ( spec+  ) where++import qualified Data.HashMap.Strict as HM++import Control.Monad.Reader+import Data.Aeson+import Data.Text+import Data.Yaml.Config+import Rollbar.Client+import Test.Hspec++data Package = Package+  { packageName :: Text+  , packageVersion :: Text+  } deriving (Eq, Show)++instance FromJSON Package where+  parseJSON = withObject "Package" $ \o ->+    Package <$> o .: "name"+            <*> o .: "version"++instance HasSettings (Reader Settings) where+  getSettings = ask++spec :: Spec+spec = do+  describe "getRequestModifier" $ do+    let mkSettings modifiers = Settings+          { settingsToken = Token "invalid-token"+          , settingsEnvironment = Environment "test"+          , settingsRevision = Nothing+          , settingsRequestModifiers = modifiers+          }+        request = Request+          { requestUrl = "http://example.com"+          , requestMethod = "GET"+          , requestHeaders = HM.fromList+              [ ("Host", "example.com")+              , ("Secret", "p4ssw0rd")+              ]+          , requestParams = HM.fromList+              [ ("user", "John Doe")+              , ("password", "p4ssw0rd")+              ]+          , requestGet = mempty+          , requestQueryStrings = ""+          , requestPost = mempty+          , requestBody = ""+          , requestUserIp = ""+          }++    it "excludes the headers not matching the given names" $+      let requestModifier = runReader getRequestModifier $ mkSettings $+            defaultRequestModifiers+              { requestModifiersExcludeHeaders = Just $ pure "Secret" }+      in requestModifier request `shouldBe` request+           { requestHeaders = HM.fromList [("Host", "example.com")] }++    it "excludes the params not matching the given names" $+      let requestModifier = runReader getRequestModifier $ mkSettings $+            defaultRequestModifiers+              { requestModifiersExcludeParams = Just $ pure "password" }+      in requestModifier request `shouldBe` request+           { requestParams = HM.fromList [("user", "John Doe")] }++    it "includes only the headers matching the given names" $+      let requestModifier = runReader getRequestModifier $ mkSettings $+            defaultRequestModifiers+              { requestModifiersIncludeHeaders = Just $ pure "Host" }+      in requestModifier request `shouldBe` request+           { requestHeaders = HM.fromList [("Host", "example.com")] }++    it "includes only the params matching the given names" $+      let requestModifier = runReader getRequestModifier $ mkSettings $+            defaultRequestModifiers+              { requestModifiersIncludeParams = Just $ pure "user" }+      in requestModifier request `shouldBe` request+           { requestParams = HM.fromList [("user", "John Doe")] }++  describe "defaultNotifier" $+    it "matches the package name and version" $ do+      Package{..} <- loadYamlSettings ["package.yaml"] [] ignoreEnv+      defaultNotifier `shouldBe` Notifier+        { notifierName = packageName+        , notifierVersion = packageVersion+        }++  before (readSettings "rollbar.yaml") $ do+    describe "ping" $+      it "returns Pong" $ \settings ->+        runRollbar settings ping `shouldReturn` Pong++    describe "createItem" $ do+      context "PayloadTrace" $+        it "returns ItemId" $ \settings -> do+          itemId <- runRollbar settings $ do+            item <- mkItem $ PayloadTrace $ Trace [] $ Exception+              { exceptionClass = "NameError"+              , exceptionMessage = Just "global name 'foo' is not defined"+              , exceptionDescription = Just "Something went wrong while trying to save the user object"+              }+            createItem item++          itemId `shouldSatisfy` const True++      context "PayloadTraceChain" $+        it "returns ItemId" $ \settings -> do+          itemId <- runRollbar settings $ do+            item <- mkItem $ PayloadTraceChain $ pure $ Trace [] $ Exception+              { exceptionClass = "NameError"+              , exceptionMessage = Just "global name 'foo' is not defined"+              , exceptionDescription = Just "Something went wrong while trying to save the user object"+              }+            createItem item++          itemId `shouldSatisfy` const True++      context "PayloadMessage" $+        it "returns ItemId" $ \settings -> do+          itemId <- runRollbar settings $ do+            item <- mkItem $ PayloadMessage $ Message+              { messageBody = "Request over threshold of 10 seconds"+              , messageMetadata = HM.fromList+                  [ ("route", "home#index")+                  , ("time_elapsed", Number 15.23)+                  ]+              }+            createItem item++          itemId `shouldSatisfy` const True++    describe "reportDeploy" $+      it "returns DeployId" $ \settings -> do+        deployId <- runRollbar settings $ do+          deploy <- getRevision >>= mkDeploy+          reportDeploy deploy++        deployId `shouldSatisfy` (> 0)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}