{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE OverloadedStrings #-}

module Ratel
  ( notify,
    toError,
    toTraces,
    toTrace,
    ApiKey,
    Payload (..),
    Error (..),
    Notifier (..),
    Request (..),
    Server (..),
    Trace (..),
    Project (..),
    Notice (..),
    NoticeUuid (..),
  )
where

import qualified Control.Exception as Exception
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Typeable as Typeable
import qualified Data.UUID as UUID
import qualified Data.Version as Version
import qualified GHC.Stack as Stack
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Client.TLS as Client
import qualified Network.HTTP.Types as HTTP
import qualified Paths_ratel as This

notify :: ApiKey -> Maybe Client.Manager -> Payload -> IO UUID.UUID
notify :: [Char] -> Maybe Manager -> Payload -> IO UUID
notify [Char]
apiKey Maybe Manager
maybeManager Payload
initialPayload = do
  let notifier :: Notifier
notifier =
        Notifier
          { notifierName :: Maybe [Char]
notifierName = forall a. a -> Maybe a
Just [Char]
"Ratel",
            notifierUrl :: Maybe [Char]
notifierUrl = forall a. a -> Maybe a
Just [Char]
"https://github.com/tfausak/ratel",
            notifierVersion :: Maybe [Char]
notifierVersion = forall a. a -> Maybe a
Just (Version -> [Char]
Version.showVersion Version
This.version)
          }
  let payload :: Payload
payload = case Payload -> Maybe Notifier
payloadNotifier Payload
initialPayload of
        Maybe Notifier
Nothing -> Payload
initialPayload {payloadNotifier :: Maybe Notifier
payloadNotifier = forall a. a -> Maybe a
Just Notifier
notifier}
        Maybe Notifier
_ -> Payload
initialPayload

  Request
initialRequest <-
    forall (m :: * -> *). MonadThrow m => [Char] -> m Request
Client.parseUrlThrow
      [Char]
"https://api.honeybadger.io/v1/notices"
  let body :: RequestBody
body = ByteString -> RequestBody
Client.RequestBodyLBS (forall a. ToJSON a => a -> ByteString
JSON.encode Payload
payload)
  let headers :: [(HeaderName, ByteString)]
headers =
        [ (HeaderName
HTTP.hAccept, [Char] -> ByteString
BS.pack [Char]
"application/json"),
          (HeaderName
HTTP.hContentType, [Char] -> ByteString
BS.pack [Char]
"application/json"),
          (forall s. FoldCase s => s -> CI s
CI.mk ([Char] -> ByteString
BS.pack [Char]
"X-API-Key"), [Char] -> ByteString
BS.pack [Char]
apiKey)
        ]
  let request :: Request
request =
        Request
initialRequest
          { method :: ByteString
Client.method = [Char] -> ByteString
BS.pack [Char]
"POST",
            requestBody :: RequestBody
Client.requestBody = RequestBody
body,
            requestHeaders :: [(HeaderName, ByteString)]
Client.requestHeaders = [(HeaderName, ByteString)]
headers
          }

  Manager
manager <- case Maybe Manager
maybeManager of
    Maybe Manager
Nothing -> ManagerSettings -> IO Manager
Client.newManager ManagerSettings
Client.tlsManagerSettings
    Just Manager
manager -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. HasHttpManager a => a -> Manager
Client.getHttpManager Manager
manager)

  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
Client.httpLbs Request
request Manager
manager
  case forall a. FromJSON a => ByteString -> Either [Char] a
JSON.eitherDecode (forall body. Response body -> body
Client.responseBody Response ByteString
response) of
    Left [Char]
message -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
message
    Right Notice
notice -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (NoticeUuid -> UUID
unwrapNoticeUuid (Notice -> NoticeUuid
noticeUuid Notice
notice))

toError ::
  (Exception.Exception exception, Stack.HasCallStack) => exception -> Error
toError :: forall exception.
(Exception exception, HasCallStack) =>
exception -> Error
toError exception
exception =
  Error
    { errorBacktrace :: Maybe [Trace]
errorBacktrace = forall a. a -> Maybe a
Just (CallStack -> [Trace]
toTraces HasCallStack
?callStack),
      errorClass :: Maybe [Char]
errorClass = forall a. a -> Maybe a
Just (forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
Typeable.typeOf exception
exception)),
      errorMessage :: Maybe [Char]
errorMessage = forall a. a -> Maybe a
Just (forall e. Exception e => e -> [Char]
Exception.displayException exception
exception),
      errorSource :: Maybe (Map [Char] [Char])
errorSource = forall a. Maybe a
Nothing,
      errorTags :: Maybe [[Char]]
errorTags = forall a. Maybe a
Nothing
    }

toTraces :: Stack.CallStack -> [Trace]
toTraces :: CallStack -> [Trace]
toTraces CallStack
callStack = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> SrcLoc -> Trace
toTrace) (CallStack -> [([Char], SrcLoc)]
Stack.getCallStack CallStack
callStack)

toTrace :: String -> Stack.SrcLoc -> Trace
toTrace :: [Char] -> SrcLoc -> Trace
toTrace [Char]
function SrcLoc
srcLoc =
  Trace
    { traceFile :: Maybe [Char]
traceFile = forall a. a -> Maybe a
Just (SrcLoc -> [Char]
Stack.srcLocFile SrcLoc
srcLoc),
      traceMethod :: Maybe [Char]
traceMethod =
        forall a. a -> Maybe a
Just
          (forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"." [SrcLoc -> [Char]
Stack.srcLocModule SrcLoc
srcLoc, [Char]
function]),
      traceNumber :: Maybe [Char]
traceNumber =
        forall a. a -> Maybe a
Just
          ( forall a. [a] -> [[a]] -> [a]
List.intercalate
              [Char]
":"
              (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> [Char]
show [SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
srcLoc, SrcLoc -> Int
Stack.srcLocStartCol SrcLoc
srcLoc])
          )
    }

type ApiKey = String

data Payload = Payload
  { Payload -> Error
payloadError :: Error,
    Payload -> Maybe Notifier
payloadNotifier :: Maybe Notifier,
    Payload -> Maybe Request
payloadRequest :: Maybe Request,
    Payload -> Server
payloadServer :: Server
  }
  deriving (Payload -> Payload -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Payload -> Payload -> Bool
$c/= :: Payload -> Payload -> Bool
== :: Payload -> Payload -> Bool
$c== :: Payload -> Payload -> Bool
Eq, Int -> Payload -> ShowS
[Payload] -> ShowS
Payload -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> [Char]
$cshow :: Payload -> [Char]
showsPrec :: Int -> Payload -> ShowS
$cshowsPrec :: Int -> Payload -> ShowS
Show)

instance JSON.ToJSON Payload where
  toJSON :: Payload -> Value
toJSON Payload
x =
    [Pair] -> Value
JSON.object
      [ Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Payload -> Error
payloadError Payload
x,
        Key
"notifier" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Payload -> Maybe Notifier
payloadNotifier Payload
x,
        Key
"request" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Payload -> Maybe Request
payloadRequest Payload
x,
        Key
"server" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Payload -> Server
payloadServer Payload
x
      ]

data Error = Error
  { Error -> Maybe [Trace]
errorBacktrace :: Maybe [Trace],
    Error -> Maybe [Char]
errorClass :: Maybe String,
    Error -> Maybe [Char]
errorMessage :: Maybe String,
    Error -> Maybe (Map [Char] [Char])
errorSource :: Maybe (Map.Map String String),
    Error -> Maybe [[Char]]
errorTags :: Maybe [String]
  }
  deriving (Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> [Char]
$cshow :: Error -> [Char]
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance JSON.ToJSON Error where
  toJSON :: Error -> Value
toJSON Error
x =
    [Pair] -> Value
JSON.object
      [ Key
"backtrace" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Error -> Maybe [Trace]
errorBacktrace Error
x,
        Key
"class" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Error -> Maybe [Char]
errorClass Error
x,
        Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Error -> Maybe [Char]
errorMessage Error
x,
        Key
"source" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Error -> Maybe (Map [Char] [Char])
errorSource Error
x,
        Key
"tags" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Error -> Maybe [[Char]]
errorTags Error
x
      ]

data Notifier = Notifier
  { Notifier -> Maybe [Char]
notifierName :: Maybe String,
    Notifier -> Maybe [Char]
notifierUrl :: Maybe String,
    Notifier -> Maybe [Char]
notifierVersion :: Maybe String
  }
  deriving (Notifier -> Notifier -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Notifier -> Notifier -> Bool
$c/= :: Notifier -> Notifier -> Bool
== :: Notifier -> Notifier -> Bool
$c== :: Notifier -> Notifier -> Bool
Eq, Int -> Notifier -> ShowS
[Notifier] -> ShowS
Notifier -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Notifier] -> ShowS
$cshowList :: [Notifier] -> ShowS
show :: Notifier -> [Char]
$cshow :: Notifier -> [Char]
showsPrec :: Int -> Notifier -> ShowS
$cshowsPrec :: Int -> Notifier -> ShowS
Show)

instance JSON.ToJSON Notifier where
  toJSON :: Notifier -> Value
toJSON Notifier
x =
    [Pair] -> Value
JSON.object
      [ Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Notifier -> Maybe [Char]
notifierName Notifier
x,
        Key
"url" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Notifier -> Maybe [Char]
notifierUrl Notifier
x,
        Key
"version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Notifier -> Maybe [Char]
notifierVersion Notifier
x
      ]

data Request = Request
  { Request -> Maybe [Char]
requestAction :: Maybe String,
    Request -> Maybe (Map [Char] [Char])
requestCgiData :: Maybe (Map.Map String String),
    Request -> Maybe [Char]
requestComponent :: Maybe String,
    Request -> Maybe (Map [Char] Value)
requestContext :: Maybe (Map.Map String JSON.Value),
    Request -> Maybe (Map [Char] [Char])
requestParams :: Maybe (Map.Map String String),
    Request -> Maybe (Map [Char] [Char])
requestSession :: Maybe (Map.Map String String),
    Request -> Maybe [Char]
requestUrl :: Maybe String
  }
  deriving (Request -> Request -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c== :: Request -> Request -> Bool
Eq, Int -> Request -> ShowS
[Request] -> ShowS
Request -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> [Char]
$cshow :: Request -> [Char]
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show)

instance JSON.ToJSON Request where
  toJSON :: Request -> Value
toJSON Request
x =
    [Pair] -> Value
JSON.object
      [ Key
"action" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe [Char]
requestAction Request
x,
        Key
"cgi_data" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe (Map [Char] [Char])
requestCgiData Request
x,
        Key
"component" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe [Char]
requestComponent Request
x,
        Key
"context" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe (Map [Char] Value)
requestContext Request
x,
        Key
"params" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe (Map [Char] [Char])
requestParams Request
x,
        Key
"session" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe (Map [Char] [Char])
requestSession Request
x,
        Key
"url" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Request -> Maybe [Char]
requestUrl Request
x
      ]

data Server = Server
  { Server -> Maybe [Char]
serverEnvironmentName :: Maybe String,
    Server -> Maybe [Char]
serverHostname :: Maybe String,
    Server -> Maybe Project
serverProjectRoot :: Maybe Project
  }
  deriving (Server -> Server -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Server -> Server -> Bool
$c/= :: Server -> Server -> Bool
== :: Server -> Server -> Bool
$c== :: Server -> Server -> Bool
Eq, Int -> Server -> ShowS
[Server] -> ShowS
Server -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Server] -> ShowS
$cshowList :: [Server] -> ShowS
show :: Server -> [Char]
$cshow :: Server -> [Char]
showsPrec :: Int -> Server -> ShowS
$cshowsPrec :: Int -> Server -> ShowS
Show)

instance JSON.ToJSON Server where
  toJSON :: Server -> Value
toJSON Server
x =
    [Pair] -> Value
JSON.object
      [ Key
"environment_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Server -> Maybe [Char]
serverEnvironmentName Server
x,
        Key
"hostname" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Server -> Maybe [Char]
serverHostname Server
x,
        Key
"project_root" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Server -> Maybe Project
serverProjectRoot Server
x
      ]

data Trace = Trace
  { Trace -> Maybe [Char]
traceFile :: Maybe String,
    Trace -> Maybe [Char]
traceMethod :: Maybe String,
    Trace -> Maybe [Char]
traceNumber :: Maybe String
  }
  deriving (Trace -> Trace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Trace -> Trace -> Bool
$c/= :: Trace -> Trace -> Bool
== :: Trace -> Trace -> Bool
$c== :: Trace -> Trace -> Bool
Eq, Int -> Trace -> ShowS
[Trace] -> ShowS
Trace -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Trace] -> ShowS
$cshowList :: [Trace] -> ShowS
show :: Trace -> [Char]
$cshow :: Trace -> [Char]
showsPrec :: Int -> Trace -> ShowS
$cshowsPrec :: Int -> Trace -> ShowS
Show)

instance JSON.ToJSON Trace where
  toJSON :: Trace -> Value
toJSON Trace
x =
    [Pair] -> Value
JSON.object
      [ Key
"file" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Trace -> Maybe [Char]
traceFile Trace
x,
        Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Trace -> Maybe [Char]
traceMethod Trace
x,
        Key
"number" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Trace -> Maybe [Char]
traceNumber Trace
x
      ]

newtype Project = Project
  { Project -> Maybe [Char]
projectPath :: Maybe String
  }
  deriving (Project -> Project -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Project -> Project -> Bool
$c/= :: Project -> Project -> Bool
== :: Project -> Project -> Bool
$c== :: Project -> Project -> Bool
Eq, Int -> Project -> ShowS
[Project] -> ShowS
Project -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Project] -> ShowS
$cshowList :: [Project] -> ShowS
show :: Project -> [Char]
$cshow :: Project -> [Char]
showsPrec :: Int -> Project -> ShowS
$cshowsPrec :: Int -> Project -> ShowS
Show)

instance JSON.ToJSON Project where
  toJSON :: Project -> Value
toJSON Project
x = [Pair] -> Value
JSON.object [Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JSON..= Project -> Maybe [Char]
projectPath Project
x]

newtype Notice = Notice
  { Notice -> NoticeUuid
noticeUuid :: NoticeUuid
  }
  deriving (Notice -> Notice -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Notice -> Notice -> Bool
$c/= :: Notice -> Notice -> Bool
== :: Notice -> Notice -> Bool
$c== :: Notice -> Notice -> Bool
Eq, Int -> Notice -> ShowS
[Notice] -> ShowS
Notice -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Notice] -> ShowS
$cshowList :: [Notice] -> ShowS
show :: Notice -> [Char]
$cshow :: Notice -> [Char]
showsPrec :: Int -> Notice -> ShowS
$cshowsPrec :: Int -> Notice -> ShowS
Show)

instance JSON.FromJSON Notice where
  parseJSON :: Value -> Parser Notice
parseJSON Value
json = case Value
json of
    JSON.Object Object
object -> do
      NoticeUuid
uuid <- Object
object forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"id"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Notice {noticeUuid :: NoticeUuid
noticeUuid = NoticeUuid
uuid}
    Value
_ -> forall a. [Char] -> Value -> Parser a
JSON.typeMismatch [Char]
"Notice" Value
json

newtype NoticeUuid = NoticeUuid
  { NoticeUuid -> UUID
unwrapNoticeUuid :: UUID.UUID
  }
  deriving (NoticeUuid -> NoticeUuid -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoticeUuid -> NoticeUuid -> Bool
$c/= :: NoticeUuid -> NoticeUuid -> Bool
== :: NoticeUuid -> NoticeUuid -> Bool
$c== :: NoticeUuid -> NoticeUuid -> Bool
Eq, Int -> NoticeUuid -> ShowS
[NoticeUuid] -> ShowS
NoticeUuid -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NoticeUuid] -> ShowS
$cshowList :: [NoticeUuid] -> ShowS
show :: NoticeUuid -> [Char]
$cshow :: NoticeUuid -> [Char]
showsPrec :: Int -> NoticeUuid -> ShowS
$cshowsPrec :: Int -> NoticeUuid -> ShowS
Show)

instance JSON.FromJSON NoticeUuid where
  parseJSON :: Value -> Parser NoticeUuid
parseJSON Value
json = case Value
json of
    JSON.String Text
text -> case Text -> Maybe UUID
UUID.fromText Text
text of
      Maybe UUID
Nothing -> forall a. [Char] -> Value -> Parser a
JSON.typeMismatch [Char]
"UUID" Value
json
      Just UUID
uuid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (UUID -> NoticeUuid
NoticeUuid UUID
uuid)
    Value
_ -> forall a. [Char] -> Value -> Parser a
JSON.typeMismatch [Char]
"UUID" Value
json