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,19 +148,29 @@ 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
-    Network.Wai.Handler.Warp.defaultSettings
+    logger <- makeLogger site
-        { Network.Wai.Handler.Warp.settingsPort = port
+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
-        {- FIXME
+        Network.Wai.Handler.Warp.defaultSettings
-        , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
+            { Network.Wai.Handler.Warp.settingsPort = port
-            [ "Warp/"
+            {- FIXME
-            , Network.Wai.Handler.Warp.warpVersion
+            , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
-            , " + Yesod/"
+                [ "Warp/"
-            , showVersion Paths_yesod_core.version
+                , Network.Wai.Handler.Warp.warpVersion
-            , " (core)"
+                , " + Yesod/"
-            ]
+                , showVersion Paths_yesod_core.version
-        -}
+                , " (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.
 --