@@ -52,6 +52,8 @@ import Data.Monoid (mconcat)
5252import Control.Monad.IO.Class (liftIO)
5353import Data.ByteString.Lazy.Internal (defaultChunkSize)
5454
55+import Data.IORef (IORef, writeIORef, readIORef, newIORef)
56+
5557run :: Port -> Application -> IO ()
5658run port = withSocketsDo .
5759 bracket
@@ -74,10 +76,11 @@ serveConnection port app conn remoteHost' = do
7476 (hClose conn))
7577 catchEOFError
7678 where serveConnection' = do
77− env <- parseRequest port conn remoteHost'
79+ (ilen, env) <- parseRequest port conn remoteHost'
7880 res <- app env
81+ remaining <- readIORef ilen
82+ _ <- B.hGet conn remaining -- FIXME just skip, don't read
7983 sendResponse (httpVersion env) conn res
80− -- FIXME drain request body
8184 hFlush conn
8285 when (isChunked $ httpVersion env) serveConnection'
8386
@@ -87,7 +90,7 @@ serveConnection port app conn remoteHost' = do
8790 Nothing -> ioError e
8891 | otherwise = ioError e
8992
90−parseRequest :: Port -> Handle -> String -> IO Request
93+parseRequest :: Port -> Handle -> String -> IO (IORef Int, Request)
9194parseRequest port conn remoteHost' = do
9295 headers' <- takeUntilBlank conn id
9396 parseRequest' port headers' conn remoteHost'
@@ -119,7 +122,7 @@ parseRequest' :: Port
119122 -> [ByteString]
120123 -> Handle
121124 -> String
122− -> IO Request
125+ -> IO (IORef Int, Request)
123126parseRequest' port lines' handle remoteHost' = do
124127 (firstLine, otherLines) <-
125128 case lines' of
@@ -138,7 +141,8 @@ parseRequest' port lines' handle remoteHost' = do
138141 (x, _):_ -> Just x
139142 _ -> Nothing
140143 let (serverName', _) = B.break (== ':') host
141− return $ Request
144+ ilen <- newIORef len
145+ return (ilen, Request
142146 { requestMethod = method
143147 , httpVersion = httpversion
144148 , pathInfo = B.pack rpath
@@ -147,10 +151,10 @@ parseRequest' port lines' handle remoteHost' = do
147151 , serverPort = port
148152 , requestHeaders = heads
149153 , isSecure = False
150− , requestBody = requestBodyHandle handle len
154+ , requestBody = requestBodyHandle handle ilen len
151155 , errorHandler = System.IO.hPutStr System.IO.stderr
152156 , remoteHost = B.pack remoteHost'
153− }
157+ })
154158
155159parseFirst :: ByteString
156160 -> IO (ByteString, ByteString, ByteString, HttpVersion)
@@ -218,21 +222,17 @@ parseHeaderNoAttr s =
218222 else rest
219223 in (k, rest')
220224
221−requestBodyHandle :: Handle -> Int -> E.Enumerator B.ByteString IO a
222−requestBodyHandle h =
223− requestBodyFunc go
225+requestBodyHandle :: Handle
226+ -> IORef Int
227+ -> Int
228+ -> E.Enumerator B.ByteString IO a
229+requestBodyHandle handle ilen initLen =
230+ go initLen
224231 where
225− go i = Just `fmap` B.hGet h (min i defaultChunkSize)
226−
227−requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
228− -> Int
229− -> E.Enumerator B.ByteString IO a
230−requestBodyFunc _ 0 step = E.returnI step
231−requestBodyFunc h len (E.Continue k) = do
232− mbs <- liftIO $ h len
233− case mbs of
234− Nothing -> E.continue k
235− Just bs -> do
236− let newLen = len - B.length bs
237− k (E.Chunks [bs]) >>== requestBodyFunc h newLen
238−requestBodyFunc _ _ step = E.returnI step
232+ go 0 step = E.returnI step
233+ go len (E.Continue k) = do
234+ bs <- liftIO $ B.hGet handle (min len defaultChunkSize) -- FIXME play with defaultChunkSize
235+ let newLen = len - B.length bs
236+ liftIO $ writeIORef ilen newLen
237+ k (E.Chunks [bs]) >>== go newLen
238+ go _ step = E.returnI step