Non-chunked input

[Lucu.git] / Network / HTTP / Lucu / Preprocess.hs

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index e8fdfc630b20bf4dea3de677f6daeb392d7fd852..1c11f89784cb622ec6ee5fae0e67c7acd666c9c1 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -54,69 +54,61 @@ preprocess itr
             reqVer /= HttpVersion 1 1 then
 
              do setStatus itr HttpVersionNotSupported
-                writeTVar (itrWillClose itr) True
+                writeItr itr itrWillClose True
 
            else
              do if reqVer == HttpVersion 1 0 then
                     -- HTTP/1.0 では Keep-Alive できない
-                    writeTVar (itrWillClose itr) True
+                    writeItr itr itrWillClose True
                   else
                     -- URI または Host: ヘッダのどちらかにホストが無ければ
                     -- ならない。
                     when (uriAuthority (reqURI req) == Nothing &&
-                          getHeader req "Host"      == Nothing)
+                          getHeader "Host" req      == Nothing)
                              $ setStatus itr BadRequest
 
                 case reqMethod req of
                   GET  -> return ()
-                  HEAD -> writeTVar (itrWillDiscardBody itr) True
-                  POST -> ensureHavingBody itr
-                  PUT  -> ensureHavingBody itr
+                  HEAD -> writeItr itr itrWillDiscardBody True
+                  POST -> writeItr itr itrRequestHasBody True
+                  PUT  -> writeItr itr itrRequestHasBody True
                   _    -> setStatus itr NotImplemented
                   
                 mapM_ (preprocessHeader itr) (reqHeaders req)
     where
-      ensureHavingBody itr
-          = let req = fromJust $ itrRequest itr
-            in
-              if getHeader req "Content-Length"    == Nothing &&
-                 getHeader req "Transfer-Encoding" == Nothing then
-
-                  setStatus itr LengthRequired
-              else
-                  writeTVar (itrRequestHasBody itr) True
-
       setStatus itr status
-          = writeTVar (itrResponse itr) (Just $ Response {
-                                                    resVersion = HttpVersion 1 1
-                                                  , resStatus  = status
-                                                  , resHeaders = []
-                                                  })
+          = writeItr itr itrResponse $ Just (Response {
+                                               resVersion = HttpVersion 1 1
+                                             , resStatus  = status
+                                             , resHeaders = []
+                                             })
 
       preprocessHeader itr (name, value)
           = case map toLower name of
 
               "expect"
                   -> if value `noCaseEq` "100-continue" then
-                         writeTVar (itrExpectedContinue itr) True
+                         writeItr itr itrExpectedContinue True
                      else
                          setStatus itr ExpectationFailed
 
               "transfer-encoding"
                   -> case map toLower value of
                        "identity" -> return ()
-                       "chunked"  -> writeTVar (itrRequestIsChunked itr) True
+                       "chunked"  -> writeItr itr itrRequestIsChunked True
                        _          -> setStatus itr NotImplemented
 
               "content-length"
                   -> if all isDigit value then
-                         writeTVar (itrRequestBodyLength itr) (Just $ read value)
+                         do let len = read value
+                            writeItr itr itrReqChunkLength    $ Just len
+                            writeItr itr itrReqChunkRemaining $ Just len
                      else
                          setStatus itr BadRequest
 
               "connection"
                   -> case map toLower value of
-                       "close"      -> writeTVar (itrWillClose itr) True
+                       "close"      -> writeItr itr itrWillClose True
                        _            -> return ()
 
               _ -> return ()
\ No newline at end of file