@@ -21,7 +21,7 @@ import Control.Concurrent (forkIO, threadDelay)
2121import qualified Control.Concurrent.MVar as M
2222import qualified Control.Concurrent.Chan as C
2323import System.Directory (getModificationTime)
24−import Network.Wai.Handler.SimpleServer (parseRequest, sendResponse)
24+import Network.Wai.Handler.Warp (parseRequest, sendResponse, drainRequestBody)
2525import Control.Monad (filterM)
2626
2727import Control.Arrow ((&&&))
@@ -62,8 +62,10 @@ startApp queue withApp = do
6262 go app
6363 onErr :: SomeException -> IO Response
6464 onErr e = return
65− $ Response status500 [("Content-Type", "text/plain; charset=utf-8")]
66− $ ResponseLBS $ encodeUtf8 $ pack
65+ $ responseLBS
66+ status500
67+ [("Content-Type", "text/plain; charset=utf-8")]
68+ $ charsToLBS
6769 $ "Exception thrown while running application\n\n" ++ show e
6870 void x = x >> return ()
6971
@@ -155,15 +157,18 @@ swapApp app mqueue = do
155157
156158loadingApp :: Maybe SomeException -> Handler
157159loadingApp err f =
158− f $ const $ return $ Response status200
160+ f $ const $ return $ responseLBS status200
159161 ( ("Content-Type", "text/plain")
160162 : case err of
161163 Nothing -> [("Refresh", "1")]
162164 Just _ -> []
163− ) $ ResponseLBS $ L8.pack $ toMessage err
165+ ) $ toMessage err
164166 where
165167 toMessage Nothing = "Loading code changes, please wait"
166− toMessage (Just err') = "Error loading code: " ++ show err'
168+ toMessage (Just err') = charsToLBS $ "Error loading code: " ++ show err'
169+
170+charsToLBS :: String -> L8.ByteString
171+charsToLBS = encodeUtf8 . pack
167172
168173type Handler = (Application -> IO ()) -> IO ()
169174
@@ -198,10 +203,13 @@ type Queue = C.Chan (Maybe (Request, Response -> IO ()))
198203
199204serveConnection :: Port -> M.MVar Queue -> Handle -> String -> IO ()
200205serveConnection port mqueue conn remoteHost' = do
201− env <- parseRequest port conn remoteHost'
206+ (ilen, env) <- parseRequest port conn remoteHost'
202207 let onRes res =
203208 finally
204− (sendResponse (httpVersion env) conn res)
209+ (do
210+ _ <- sendResponse env (httpVersion env) conn res
211+ drainRequestBody conn ilen
212+ return ())
205213 (hClose conn)
206214 queue <- M.readMVar mqueue
207215 C.writeChan queue $ Just (env, onRes)