{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module: Rollbar.Wai
-- Copyright: (c) 2020 Stack Builders Inc.
-- License: MIT
-- Maintainer: Sebastián Estrella <sestrella@stackbuilders.com>
--
-- For a fully working example check the following link:
--
-- <https://github.com/stackbuilders/rollbar-haskell/blob/master/rollbar-wai/example/Main.hs>
module Rollbar.Wai
  ( rollbarOnException
  , rollbarOnExceptionWith
  , mkRequest
  ) where

import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HM
import qualified Data.Text.Encoding as T
import qualified Network.Wai as W
import qualified Network.Wai.Parse as W
import qualified Network.Wai.Request as W

import Control.Concurrent (forkIO)
import Control.Exception
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Aeson
import Network.HTTP.Types (renderQuery)
import Rollbar.Client

-- | Sends the captured 'SomeException' to Rollbar API using the given
-- 'Settings'. Under the hood, this function uses 'createItem' function from
-- rollbar-client.
--
-- __Example__
--
-- > settings <- readSettings "rollbar.yaml"
-- > runSettings
-- >   (setOnException (rollbarOnException settings) defaultSettings)
-- >   app
--
-- @since 0.1.0
rollbarOnException
  :: MonadIO m
  => Settings
  -> Maybe W.Request
  -> SomeException
  -> m ()
rollbarOnException :: Settings -> Maybe Request -> SomeException -> m ()
rollbarOnException = (Item -> Rollbar ())
-> Settings -> Maybe Request -> SomeException -> m ()
forall (m :: * -> *).
MonadIO m =>
(Item -> Rollbar ())
-> Settings -> Maybe Request -> SomeException -> m ()
rollbarOnExceptionWith (Rollbar ItemId -> Rollbar ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Rollbar ItemId -> Rollbar ())
-> (Item -> Rollbar ItemId) -> Item -> Rollbar ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> Rollbar ItemId
forall (m :: * -> *).
(HasSettings m, MonadHttp m) =>
Item -> m ItemId
createItem)

-- | Similar to 'rollbarOnExceptionWith', but it allows customize the function
-- used to send the 'Item' to Rollbar.
--
-- @since 0.1.0
rollbarOnExceptionWith
  :: MonadIO m
  => (Item -> Rollbar ())
  -> Settings
  -> Maybe W.Request
  -> SomeException
  -> m ()
rollbarOnExceptionWith :: (Item -> Rollbar ())
-> Settings -> Maybe Request -> SomeException -> m ()
rollbarOnExceptionWith Item -> Rollbar ()
f Settings
settings Maybe Request
waiRequest SomeException
ex =
  m ThreadId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ThreadId -> m ()) -> m ThreadId -> m ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Settings -> Rollbar () -> IO ()
forall (m :: * -> *) a. MonadIO m => Settings -> Rollbar a -> m a
runRollbar Settings
settings (Rollbar () -> IO ()) -> Rollbar () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Item
item <- Payload -> Rollbar Item
forall (m :: * -> *).
(HasSettings m, MonadIO m) =>
Payload -> m Item
mkItem (Payload -> Rollbar Item) -> Payload -> Rollbar Item
forall a b. (a -> b) -> a -> b
$ Trace -> Payload
PayloadTrace (Trace -> Payload) -> Trace -> Payload
forall a b. (a -> b) -> a -> b
$ [Frame] -> Exception -> Trace
Trace [] (Exception -> Trace) -> Exception -> Trace
forall a b. (a -> b) -> a -> b
$ SomeException -> Exception
forall e. Exception e => e -> Exception
mkException SomeException
ex
    Maybe Request
request <- (Request -> Rollbar Request)
-> Maybe Request -> Rollbar (Maybe Request)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Request -> Rollbar Request
forall (m :: * -> *). MonadIO m => Request -> m Request
mkRequest Maybe Request
waiRequest
    Item -> Rollbar ()
f Item
item
      { itemFramework :: Maybe Text
itemFramework = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"wai"
      , itemRequest :: Maybe Request
itemRequest = Maybe Request
request
      }

-- | Transforms a Wai 'W.Request' into a Rollbar 'Request'.
--
-- @since 0.1.0
mkRequest :: MonadIO m => W.Request -> m Request
mkRequest :: Request -> m Request
mkRequest Request
req = IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ do
  ([Param]
params, [File ()]
_) <- BackEnd () -> Request -> IO ([Param], [File ()])
forall y. BackEnd y -> Request -> IO ([Param], [File y])
W.parseRequestBody BackEnd ()
ignoreFiles Request
req
  Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request :: Text
-> Text
-> Object
-> Object
-> Object
-> Text
-> Object
-> Text
-> Text
-> Request
Request
    { requestUrl :: Text
requestUrl = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ Request -> ByteString
W.guessApproot Request
req
        , Request -> ByteString
W.rawPathInfo Request
req
        , Request -> ByteString
W.rawQueryString Request
req
        ]
    , requestMethod :: Text
requestMethod = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
W.requestMethod Request
req
    , requestHeaders :: Object
requestHeaders = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ (CI ByteString, ByteString) -> (Text, Value)
toHeader ((CI ByteString, ByteString) -> (Text, Value))
-> [(CI ByteString, ByteString)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> [(CI ByteString, ByteString)]
W.requestHeaders Request
req
    , requestParams :: Object
requestParams = Object
forall a. Monoid a => a
mempty
    , requestGet :: Object
requestGet = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ (ByteString, Maybe ByteString) -> (Text, Value)
forall (f :: * -> *).
(ToJSON (f Text), Functor f) =>
(ByteString, f ByteString) -> (Text, Value)
toQuery ((ByteString, Maybe ByteString) -> (Text, Value))
-> [(ByteString, Maybe ByteString)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> [(ByteString, Maybe ByteString)]
W.queryString Request
req
    , requestQueryStrings :: Text
requestQueryStrings = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> [(ByteString, Maybe ByteString)] -> ByteString
renderQuery Bool
False ([(ByteString, Maybe ByteString)] -> ByteString)
-> [(ByteString, Maybe ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
W.queryString Request
req
    , requestPost :: Object
requestPost = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$ (Param -> (Text, Value)) -> [Param] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Param -> (Text, Value)
toParam [Param]
params
    , requestBody :: Text
requestBody = Text
""
    , requestUserIp :: Text
requestUserIp = Text
""
    }
  where
    toHeader :: (CI ByteString, ByteString) -> (Text, Value)
toHeader (CI ByteString
key, ByteString
value) =
      (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
key, Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
value)
    toQuery :: (ByteString, f ByteString) -> (Text, Value)
toQuery (ByteString
key, f ByteString
value) =
      (ByteString -> Text
T.decodeUtf8 ByteString
key, f Text -> Value
forall a. ToJSON a => a -> Value
toJSON (f Text -> Value) -> f Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> f ByteString -> f Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f ByteString
value)
    toParam :: Param -> (Text, Value)
toParam (ByteString
key, ByteString
value) =
      (ByteString -> Text
T.decodeUtf8 ByteString
key, Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
value)

ignoreFiles :: W.BackEnd ()
ignoreFiles :: BackEnd ()
ignoreFiles ByteString
_ FileInfo ()
_ IO ByteString
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()