{-# 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 { ApiToken -> Text
unApiToken :: Text } deriving Int -> ApiToken -> ShowS
[ApiToken] -> ShowS
ApiToken -> String
(Int -> ApiToken -> ShowS)
-> (ApiToken -> String) -> ([ApiToken] -> ShowS) -> Show ApiToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiToken] -> ShowS
$cshowList :: [ApiToken] -> ShowS
show :: ApiToken -> String
$cshow :: ApiToken -> String
showsPrec :: Int -> ApiToken -> ShowS
$cshowsPrec :: Int -> ApiToken -> ShowS
Show
newtype Environment = Environment { Environment -> Text
unEnvironment :: Text } deriving Int -> Environment -> ShowS
[Environment] -> ShowS
Environment -> String
(Int -> Environment -> ShowS)
-> (Environment -> String)
-> ([Environment] -> ShowS)
-> Show Environment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environment] -> ShowS
$cshowList :: [Environment] -> ShowS
show :: Environment -> String
$cshow :: Environment -> String
showsPrec :: Int -> Environment -> ShowS
$cshowsPrec :: Int -> Environment -> ShowS
Show
data Person = Person
{ Person -> Text
id :: Text
, Person -> Maybe Text
username :: Maybe Text
, Person -> Maybe Text
email :: Maybe Text
} deriving Int -> Person -> ShowS
[Person] -> ShowS
Person -> String
(Int -> Person -> ShowS)
-> (Person -> String) -> ([Person] -> ShowS) -> Show Person
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Person] -> ShowS
$cshowList :: [Person] -> ShowS
show :: Person -> String
$cshow :: Person -> String
showsPrec :: Int -> Person -> ShowS
$cshowsPrec :: Int -> Person -> ShowS
Show
deriveToJSON defaultOptions ''Person
data Settings = Settings
{ Settings -> Environment
environment :: Environment
, Settings -> ApiToken
token :: ApiToken
, Settings -> String
hostName :: HostName
, Settings -> Bool
reportErrors :: Bool
} deriving Int -> Settings -> ShowS
[Settings] -> ShowS
Settings -> String
(Int -> Settings -> ShowS)
-> (Settings -> String) -> ([Settings] -> ShowS) -> Show Settings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Settings] -> ShowS
$cshowList :: [Settings] -> ShowS
show :: Settings -> String
$cshow :: Settings -> String
showsPrec :: Int -> Settings -> ShowS
$cshowsPrec :: Int -> Settings -> ShowS
Show
data Options = Options
{ Options -> Maybe Person
person :: Maybe Person
, Options -> Maybe Text
revisionSha :: Maybe Text
} deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show
emptyOptions :: Options
emptyOptions :: Options
emptyOptions = Maybe Person -> Maybe Text -> Options
Options Maybe Person
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
reportErrorS :: (MonadIO m, MonadBaseControl IO m)
=> Settings
-> Options
-> Text
-> Text
-> m ()
reportErrorS :: Settings -> Options -> Text -> Text -> m ()
reportErrorS Settings
settings Options
opts Text
section =
Settings
-> Options -> Text -> (Text -> Text -> m ()) -> Text -> m ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
Settings
-> Options -> Text -> (Text -> Text -> m ()) -> Text -> m ()
reportLoggerErrorS Settings
settings Options
opts Text
section Text -> Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> Text -> m ()
logMessage
where
logMessage :: Text -> Text -> m ()
logMessage Text
sec Text
message = Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"[Error#" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
sec Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"] " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
" " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
message
reportLoggerErrorS :: (MonadIO m, MonadBaseControl IO m)
=> Settings
-> Options
-> Text
-> (Text -> Text -> m ())
-> Text
-> m ()
reportLoggerErrorS :: Settings
-> Options -> Text -> (Text -> Text -> m ()) -> Text -> m ()
reportLoggerErrorS Settings
settings Options
opts Text
section Text -> Text -> m ()
loggerS Text
msg =
if Settings -> Bool
reportErrors Settings
settings then
m ()
go
else
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
go :: m ()
go = do
Text -> m ()
logger Text
msg
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Request
initReq <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
"https://api.rollbar.com/api/1/item/"
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
let req :: Request
req = Request
initReq { method :: Method
method = Method
"POST", requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
rollbarJson }
ResourceT IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO () -> IO ()) -> ResourceT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
-> ResourceT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
-> ResourceT IO ())
-> ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
-> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ Request
-> Manager
-> ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
forall (m :: * -> *) i.
MonadResource m =>
Request -> Manager -> m (Response (ConduitM i Method m ()))
http Request
req Manager
manager
m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e::SomeException) -> Text -> m ()
logger (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
logger :: Text -> m ()
logger = Text -> Text -> m ()
loggerS Text
section
rollbarJson :: Value
rollbarJson = Settings -> Options -> Text -> Text -> Maybe Text -> Value
buildJSON Settings
settings Options
opts Text
section Text
msg Maybe Text
forall a. Maybe a
Nothing
reportErrorSCustomFingerprint :: (MonadIO m, MonadBaseControl IO m)
=> Settings
-> Options
-> Text
-> Maybe (Text -> Text -> m ())
-> Text
-> Text
-> m ()
reportErrorSCustomFingerprint :: Settings
-> Options
-> Text
-> Maybe (Text -> Text -> m ())
-> Text
-> Text
-> m ()
reportErrorSCustomFingerprint Settings
settings Options
opts Text
section Maybe (Text -> Text -> m ())
loggerS Text
msg Text
fingerprint =
if Settings -> Bool
reportErrors Settings
settings then
m ()
go
else
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
go :: m ()
go = do
Text -> m ()
logger Text
msg
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Request
initReq <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
"https://api.rollbar.com/api/1/item/"
Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
let req :: Request
req = Request
initReq { method :: Method
method = Method
"POST", requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
rollbarJson }
ResourceT IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO () -> IO ()) -> ResourceT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
-> ResourceT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
-> ResourceT IO ())
-> ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
-> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ Request
-> Manager
-> ResourceT IO (Response (ConduitM Any Method (ResourceT IO) ()))
forall (m :: * -> *) i.
MonadResource m =>
Request -> Manager -> m (Response (ConduitM i Method m ()))
http Request
req Manager
manager
m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeException
e::SomeException) -> Text -> m ()
logger (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
logger :: Text -> m ()
logger = (Text -> Text -> m ())
-> Maybe (Text -> Text -> m ()) -> Text -> Text -> m ()
forall a. a -> Maybe a -> a
fromMaybe Text -> Text -> m ()
forall (m :: * -> *) (f :: * -> *).
(MonadIO m, Applicative f) =>
Text -> f (m ())
defaultLogger Maybe (Text -> Text -> m ())
loggerS Text
section
defaultLogger :: Text -> f (m ())
defaultLogger Text
message = m () -> f (m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> f (m ())) -> m () -> f (m ())
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"[Error#" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
section Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"] " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
" " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
message
rollbarJson :: Value
rollbarJson = Settings -> Options -> Text -> Text -> Maybe Text -> Value
buildJSON Settings
settings Options
opts Text
section Text
msg (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
fingerprint)
buildJSON :: Settings
-> Options
-> Text
-> Text
-> Maybe Text
-> Value
buildJSON :: Settings -> Options -> Text -> Text -> Maybe Text -> Value
buildJSON Settings
settings Options
opts Text
section Text
msg Maybe Text
fingerprint =
[Pair] -> Value
object
[ Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ApiToken -> Text
unApiToken (Settings -> ApiToken
token Settings
settings)
, Text
"data" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
([ Text
"environment" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Text
toLower (Environment -> Text
unEnvironment (Environment -> Text) -> Environment -> Text
forall a b. (a -> b) -> a -> b
$ Settings -> Environment
environment Settings
settings)
, Text
"level" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"error" :: Text)
, Text
"server" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object [ Text
"host" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Settings -> String
hostName Settings
settings, Text
"sha" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Options -> Maybe Text
revisionSha Options
opts]
, Text
"person" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Person -> Value
forall a. ToJSON a => a -> Value
toJSON (Options -> Maybe Person
person Options
opts)
, Text
"body" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
[ Text
"trace" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
[ Text
"frames" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList [])
, Text
"exception" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object [Text
"class" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
section, Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
msg]
]
]
] [Pair] -> [Pair] -> [Pair]
forall a. Monoid a => a -> a -> a
++ [Pair]
fp)
, Text
"title" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
title
, Text
"notifier" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object [
Text
"name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
"rollbar-haskell"
, Text
"version" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
"1.1.1"
]
]
where
title :: Text
title = Text
section Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
fp :: [Pair]
fp =
case Maybe Text
fingerprint of
Just Text
fp' ->
[Text
"fingerprint" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
fp']
Maybe Text
Nothing ->
[]