module Network.Wai.Middleware.Rollbar (Settings(..), exceptions, requests) where
import Control.Concurrent (forkIO)
import Control.Exception
(Handler(Handler), SomeException, catches, displayException, throwIO)
import Control.Monad (when)
import Data.Aeson (ToJSON, defaultOptions, genericToEncoding, toEncoding)
import Data.Functor (void)
import Data.Maybe (fromMaybe)
import Data.Time (getCurrentTime)
import Data.UUID.V4 (nextRandom)
import GHC.Generics (Generic)
import GHC.TypeLits (Symbol)
import Network.HostName (getHostName)
import Network.HTTP.Client (HttpException)
import Network.HTTP.Simple
( JSONException
, Request
, defaultRequest
, httpNoBody
, setRequestBodyJSON
, setRequestHost
, setRequestIgnoreStatus
, setRequestMethod
, setRequestPath
, setRequestPort
, setRequestSecure
)
import Network.HTTP.Types.Status
(Status(Status), statusCode, statusIsServerError, statusMessage)
import Network.Wai (Middleware, ResponseReceived)
import System.Environment (getExecutablePath)
import System.IO (hPutStrLn, stderr)
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.Wai as NW
import qualified Rollbar.Item as RI
data Settings (headers :: [Symbol])
= Settings
{ accessToken :: RI.AccessToken
, branch :: Maybe RI.Branch
, codeVersion :: Maybe RI.CodeVersion
, environment :: RI.Environment
}
exceptions :: RI.RemoveHeaders headers => Settings headers -> Middleware
exceptions settings app req handler = app req handler `catches`
[ Handler $ handleSomeException settings req
]
requests :: RI.RemoveHeaders headers => Settings headers -> Middleware
requests settings app req handler' = app req handler
where
handler :: NW.Response -> IO ResponseReceived
handler res = do
_ <- forkIO $ handle500 settings req res
handler' res
handle500
:: RI.RemoveHeaders headers
=> Settings headers
-> NW.Request
-> NW.Response
-> IO ()
handle500 settings req res =
when (statusIsServerError $ NW.responseStatus res) (send settings req res)
`catches`
[ Handler handleHttpException
, Handler handleJSONException
]
send
:: forall headers
. RI.RemoveHeaders headers
=> Settings headers
-> NW.Request
-> NW.Response
-> IO ()
send settings req res = do
rReq <- mkRollbarRequest settings req payload messageBody
void $ httpNoBody rReq
where
Status{..} = NW.responseStatus res
messageBody = RI.MessageBody <$> myDecodeUtf8 statusMessage
referer = myDecodeUtf8 =<< NW.requestHeaderReferer req
range = myDecodeUtf8 =<< NW.requestHeaderRange req
userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req
payload = RequestPayload
{ statusMessage = myDecodeUtf8' statusMessage
, ..
}
handleHttpException :: HttpException -> IO ()
handleHttpException e = do
hPutStrLn stderr "Ran into an exception while sending a request to Rollbar:"
hPutStrLn stderr $ displayException e
handleJSONException :: JSONException -> IO ()
handleJSONException e = do
hPutStrLn stderr "Ran into an exception while parsing JSON response from Rollbar:"
hPutStrLn stderr $ displayException e
handleSomeException
:: forall a headers
. RI.RemoveHeaders headers
=> Settings headers
-> NW.Request
-> SomeException
-> IO a
handleSomeException settings req e = do
rReq <- mkRollbarRequest settings req payload messageBody
_ <- httpNoBody rReq
throwIO e
where
exception = T.pack $ displayException e
messageBody = Just $ RI.MessageBody $
T.intercalate " "
[ "Uncaught exception at:"
, myDecodeUtf8' $ NW.requestMethod req
, T.intercalate "/" $ NW.pathInfo req
]
referer = myDecodeUtf8 =<< NW.requestHeaderReferer req
range = myDecodeUtf8 =<< NW.requestHeaderRange req
userAgent = myDecodeUtf8 =<< NW.requestHeaderUserAgent req
payload = ExceptionPayload {..}
mkRollbarRequest
:: forall headers
. RI.RemoveHeaders headers
=> Settings headers
-> NW.Request
-> Payload
-> Maybe RI.MessageBody
-> IO Request
mkRollbarRequest Settings{..} req payload messageBody = do
uuid <- Just . RI.UUID4 <$> nextRandom
timestamp <- Just <$> getCurrentTime
host <- Just <$> getHostName
root <- Just . RI.Root . T.pack <$> getExecutablePath
let request = Just RI.Request {..}
let server = Just RI.Server { RI.serverCodeVersion = codeVersion, .. }
let itemData = (RI.error environment messageBody payload)
{ RI.codeVersion, RI.request, RI.server, RI.timestamp, RI.uuid }
pure $ rollbarRequest RI.Item{..}
where
headers :: RI.MissingHeaders headers
headers = RI.MissingHeaders $ NW.requestHeaders req
rawBody = ""
get = RI.Get $ NW.queryString req
method = RI.Method $ NW.requestMethod req
queryString = RI.QueryString $ NW.rawQueryString req
url = RI.URL (NW.requestHeaderHost req, NW.pathInfo req)
userIP = RI.IP $ NW.remoteHost req
myDecodeUtf8 :: BS.ByteString -> Maybe T.Text
myDecodeUtf8 = either (const Nothing) Just . TE.decodeUtf8'
myDecodeUtf8' :: BS.ByteString -> T.Text
myDecodeUtf8' = fromMaybe "" . myDecodeUtf8
rollbarRequest
:: (RI.RemoveHeaders headers, ToJSON a)
=> RI.Item a headers
-> Network.HTTP.Simple.Request
rollbarRequest payload =
setRequestMethod "POST"
. setRequestSecure True
. setRequestHost "api.rollbar.com"
. setRequestPort 443
. setRequestPath "api/1/item/"
. setRequestBodyJSON payload
. setRequestIgnoreStatus
$ defaultRequest
data Payload
= RequestPayload
{ statusCode :: Int
, statusMessage :: T.Text
, userAgent :: Maybe T.Text
, range :: Maybe T.Text
, referer :: Maybe T.Text
}
| ExceptionPayload
{ exception :: T.Text
, userAgent :: Maybe T.Text
, range :: Maybe T.Text
, referer :: Maybe T.Text
}
deriving (Generic, Show)
instance ToJSON Payload where
toEncoding = genericToEncoding defaultOptions