{-# Language CPP, TemplateHaskell, NoImplicitPrelude, OverloadedStrings, ExtendedDefaultRules, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Rollbar where
import BasicPrelude
import Data.Aeson.TH hiding (Options)
import Data.Text (toLower, pack)
import qualified Data.Vector as V
import Network.BSD (HostName)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (runResourceT)
import Network.HTTP.Conduit
( RequestBody(RequestBodyLBS)
, Request(method, requestBody)
, parseUrlThrow
, newManager
, tlsManagerSettings
, http )
#if MIN_VERSION_aeson(1,2,0)
import Data.Aeson hiding (Options)
#else
import Data.Aeson
#endif
#if MIN_VERSION_basic_prelude(0,7,0)
import Control.Exception.Lifted (catch)
#endif
default (Text)
newtype ApiToken = ApiToken { unApiToken :: Text } deriving Show
newtype Environment = Environment { unEnvironment :: Text } deriving Show
data Person = Person
{ id :: Text
, username :: Maybe Text
, email :: Maybe Text
} deriving Show
deriveToJSON defaultOptions ''Person
data Settings = Settings
{ environment :: Environment
, token :: ApiToken
, hostName :: HostName
, reportErrors :: Bool
} deriving Show
data Options = Options
{ person :: Maybe Person
, revisionSha :: Maybe Text
} deriving Show
emptyOptions :: Options
emptyOptions = Options Nothing Nothing
reportErrorS :: (MonadIO m, MonadBaseControl IO m)
=> Settings
-> Options
-> Text
-> Text
-> m ()
reportErrorS settings opts section =
reportLoggerErrorS settings opts section logMessage
where
logMessage sec message = putStrLn $ "[Error#" `mappend` sec `mappend` "] " `mappend` " " `mappend` message
reportLoggerErrorS :: (MonadIO m, MonadBaseControl IO m)
=> Settings
-> Options
-> Text
-> (Text -> Text -> m ())
-> Text
-> m ()
reportLoggerErrorS settings opts section loggerS msg =
if reportErrors settings then
go
else
return ()
where
go = do
logger msg
liftIO $ do
initReq <- parseUrlThrow "https://api.rollbar.com/api/1/item/"
manager <- newManager tlsManagerSettings
let req = initReq { method = "POST", requestBody = RequestBodyLBS $ encode rollbarJson }
runResourceT $ void $ http req manager
`catch` (\(e::SomeException) -> logger $ pack $ show e)
logger = loggerS section
rollbarJson = buildJSON settings opts section msg Nothing
reportErrorSCustomFingerprint :: (MonadIO m, MonadBaseControl IO m)
=> Settings
-> Options
-> Text
-> Maybe (Text -> Text -> m ())
-> Text
-> Text
-> m ()
reportErrorSCustomFingerprint settings opts section loggerS msg fingerprint =
if reportErrors settings then
go
else
return ()
where
go = do
logger msg
liftIO $ do
initReq <- parseUrlThrow "https://api.rollbar.com/api/1/item/"
manager <- newManager tlsManagerSettings
let req = initReq { method = "POST", requestBody = RequestBodyLBS $ encode rollbarJson }
runResourceT $ void $ http req manager
`catch` (\(e::SomeException) -> logger $ pack $ show e)
logger = fromMaybe defaultLogger loggerS section
defaultLogger message = pure $ putStrLn $ "[Error#" `mappend` section `mappend` "] " `mappend` " " `mappend` message
rollbarJson = buildJSON settings opts section msg (Just fingerprint)
buildJSON :: Settings
-> Options
-> Text
-> Text
-> Maybe Text
-> Value
buildJSON settings opts section msg fingerprint =
object
[ "access_token" .= unApiToken (token settings)
, "data" .= object
([ "environment" .= toLower (unEnvironment $ environment settings)
, "level" .= ("error" :: Text)
, "server" .= object [ "host" .= hostName settings, "sha" .= revisionSha opts]
, "person" .= toJSON (person opts)
, "body" .= object
[ "trace" .= object
[ "frames" .= (Array $ V.fromList [])
, "exception" .= object ["class" .= section, "message" .= msg]
]
]
] ++ fp)
, "title" .= title
, "notifier" .= object [
"name" .= "rollbar-haskell"
, "version" .= "1.1.1"
]
]
where
title = section <> ": " <> msg
fp =
case fingerprint of
Just fp' ->
["fingerprint" .= fp']
Nothing ->
[]