Log exceptions from Warp

yesod-core/Yesod/Core/Dispatch.hs

@@ -41,7 +41,7 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Monoid (mappend)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
@@ -118,6 +118,10 @@ toWaiAppYre yre req =
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
     logger <- makeLogger site
+    toWaiAppLogger logger site
+
+toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
+toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
     let yre = YesodRunnerEnv
                 { yreLogger = logger
@@ -144,7 +148,9 @@ toWaiApp site = do
 --
 -- Since 1.2.0
 warp :: YesodDispatch site => Int -> site -> IO ()
-warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
+warp port site = do
+    logger <- makeLogger site
+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
         Network.Wai.Handler.Warp.defaultSettings
             { Network.Wai.Handler.Warp.settingsPort = port
             {- FIXME
@@ -156,6 +162,14 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
                 , " (core)"
                 ]
             -}
+            , Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
+                messageLoggerSource
+                    site
+                    logger
+                    $(qLocation >>= liftLoc)
+                    "yesod-core"
+                    LevelError
+                    (toLogStr $ "Exception from Warp: " ++ show e)
             }
 
 -- | A default set of middlewares.