haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-27 11:21:56 +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 qualified Aws
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (catch)
import Control.Monad.Logger (runLoggingT, LoggingT, runStdoutLoggingT, defaultLogStr, LogLevel (LevelDebug)) import Control.Monad.Logger (runLoggingT, LoggingT, runStdoutLoggingT, defaultLogStr, LogLevel (LevelDebug))
import Control.Monad.Reader (MonadReader (..)) import Control.Monad.Reader (MonadReader (..))
import Control.Monad.Reader (runReaderT, ReaderT) import Control.Monad.Reader (runReaderT, ReaderT)
@ -22,6 +23,7 @@ import qualified Database.Persist
import Filesystem (getModified, removeTree) import Filesystem (getModified, removeTree)
import Import hiding (catch) import Import hiding (catch)
import Language.Haskell.TH.Syntax (Loc(..)) import Language.Haskell.TH.Syntax (Loc(..))
import Network.Wai (Middleware, responseLBS)
import Network.Wai.Logger (clockDateCacher) import Network.Wai.Logger (clockDateCacher)
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination
@ -99,9 +101,16 @@ makeApplication echo@False conf = do
-- Create the WAI application and apply middlewares -- Create the WAI application and apply middlewares
app <- toWaiAppPlain foundation app <- toWaiAppPlain foundation
let logFunc = messageLoggerSource foundation (appLogger foundation) let logFunc = messageLoggerSource foundation (appLogger foundation)
middleware = logWare . defaultMiddlewaresNoLogging middleware = nicerExceptions . logWare . defaultMiddlewaresNoLogging
return (middleware app, logFunc) 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 :: AppConfig DefaultEnv Extra -> IO Settings.PersistConf
getDbConf conf = getDbConf conf =
withYamlEnvironment "config/postgresql.yml" (appEnv conf) withYamlEnvironment "config/postgresql.yml" (appEnv conf)