haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-12 04:08:29 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Slightly nicer exceptions (hopefully)

Browse Source
This commit is contained in:
Michael Snoyman 2014-11-18 15:46:24 +02:00
parent 1d49985c37
commit 5bd96ad60e
1 changed files with 10 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
Application.hs
View File

@ -8,6 +8,7 @@ module Application
import qualified Aws
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (catch)
import Control.Monad.Logger (runLoggingT, LoggingT, runStdoutLoggingT, defaultLogStr, LogLevel (LevelDebug))
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.Reader (runReaderT, ReaderT)
@ -22,6 +23,7 @@ import qualified Database.Persist
import Filesystem (getModified, removeTree)
import Import hiding (catch)
import Language.Haskell.TH.Syntax (Loc(..))
import Network.Wai (Middleware, responseLBS)
import Network.Wai.Logger (clockDateCacher)
import Network.Wai.Middleware.RequestLogger
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
@ -99,9 +101,16 @@ makeApplication echo@False conf = do
-- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation)
middleware = logWare . defaultMiddlewaresNoLogging
middleware = nicerExceptions . logWare . defaultMiddlewaresNoLogging
return (middleware app, logFunc)
nicerExceptions :: Middleware
nicerExceptions app req send = catch (app req send) $ \e -> do
let text = "Exception thrown to Warp: " ++ tshow (e :: SomeException)
putStrLn text
send $ responseLBS status500 [("Content-Type", "text/plain")] $
fromStrict $ encodeUtf8 text
getDbConf :: AppConfig DefaultEnv Extra -> IO Settings.PersistConf
getDbConf conf =
withYamlEnvironment "config/postgresql.yml" (appEnv conf)