Sends Happstack exceptions to Honeybadger.

ratel-happstack.hs

#!/usr/bin/env stack
-- stack --resolver lts-12.10 script
{-# OPTIONS_GHC -Weverything -Wno-unsafe -Wno-implicit-prelude #-}
module Main ( main ) where
import qualified Control.Concurrent as Concurrent
import qualified Control.Monad as Monad
import qualified Control.Monad.Catch as Catch
import qualified Control.Monad.IO.Class as IO
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified GHC.Stack as Stack
import qualified Happstack.Server as Happstack
import qualified Network.HTTP.Client.TLS as Tls
import qualified Ratel
import qualified System.Directory as Directory
import qualified System.Environment as Environment

main :: Stack.HasCallStack => IO ()
main = do
  putStrLn "Starting up ..."
  [honeybadgerApiKey] <- Environment.getArgs
  manager <- Tls.newTlsManager
  directory <- Directory.getCurrentDirectory
  Happstack.simpleHTTP Happstack.nullConf $ Catch.catch
    (mconcat
      [ Happstack.dir "undefined" undefined
      , Happstack.ok "Hello, world!"
      ])
    (\ exception -> do
      request <- Happstack.askRq
      Monad.void . IO.liftIO . Concurrent.forkIO $ do
        print (exception :: Catch.SomeException)
        Monad.void $ Ratel.notify honeybadgerApiKey (Just manager) Ratel.Payload
          { Ratel.payloadError = Ratel.toError exception
          , Ratel.payloadNotifier = Nothing
          , Ratel.payloadRequest = Just Ratel.Request
              { Ratel.requestAction = Just . show $ Happstack.rqMethod request
              , Ratel.requestCgiData = Just
                . Map.fromList
                . Maybe.mapMaybe (\ header -> case Happstack.hValue header of
                  value : _ -> Just
                    ( Text.unpack . Text.decodeUtf8 $ Happstack.hName header
                    , Text.unpack $ Text.decodeUtf8 value
                    )
                  _ -> Nothing)
                . Map.elems
                $ Happstack.rqHeaders request
              , Ratel.requestComponent = Just "controller.action"
              , Ratel.requestContext = Nothing
              , Ratel.requestParams = Just
                . Map.fromList
                . Maybe.mapMaybe (\ ( name, input ) ->
                  case Happstack.inputValue input of
                    Right bytes -> Just
                      ( name
                      , LazyText.unpack $ LazyText.decodeUtf8 bytes
                      )
                    _ -> Nothing)
                $ Happstack.rqInputsQuery request
              , Ratel.requestSession = Nothing
              , Ratel.requestUrl = Just $ Happstack.rqUri request
              }
          , Ratel.payloadServer = Ratel.Server
              { Ratel.serverEnvironmentName = Just "development"
              , Ratel.serverHostname = Just "localhost"
              , Ratel.serverProjectRoot = Just . Ratel.Project $ Just directory
              }
          }
      Happstack.internalServerError "oh no")