{-# Language CPP, TemplateHaskell, NoImplicitPrelude, OverloadedStrings, ExtendedDefaultRules, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-- | Main entry point to the application.
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

-- (development, production, etc)
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

-- | report errors to rollbar.com and log them to stdout
reportErrorS :: (MonadIO m, MonadBaseControl IO m)
             => Settings
             -> Options
             -> Text -- ^ log section
             -> Text -- ^ log message
             -> 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

-- | used by Rollbar.MonadLogger to pass a custom logger
reportLoggerErrorS :: (MonadIO m, MonadBaseControl IO m)
                   => Settings
                   -> Options
                   -> Text -- ^ log section
                   -> (Text -> Text -> m ()) -- ^ logger that takes the section and the message
                   -> Text -- ^ log message
                   -> 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
        -- It would be more efficient to have the user setup the manager
        -- But reporting errors should be infrequent

        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


-- | Pass in custom fingerprint for grouping on rollbar
reportErrorSCustomFingerprint :: (MonadIO m, MonadBaseControl IO m)
                   => Settings
                   -> Options
                   -> Text -- ^ log section
                   -> Maybe (Text -> Text -> m ()) -- ^ logger that takes the section and the message
                   -> Text -- ^ log message
                   -> Text -- fingerprint
                   -> 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 -- ^ log section
   -> Text -- ^ log message
   -> Maybe Text -- fingerprint
   -> 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 ->
          []