"driftTo Done" was trying to change the response header, which is impossible.

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 08cc2e937b4696cb4078d425438407b95e11d81a..1d0f44f0f39c7fe9510bfe5f8fde36a140b9cc95 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -60,12 +60,10 @@ requestReader cnf tree h host tQueue
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
           = do itr <- newInteraction cnf host Nothing
-               let res = Response {
-                           resVersion = HttpVersion 1 1
-                         , resStatus  = status
-                         , resHeaders = []
-                         }
-               atomically $ do writeItr itr itrResponse $ Just res
+               atomically $ do updateItr itr itrResponse
+                                             $ \ res -> res {
+                                                          resStatus = status
+                                                        }
                                writeItr itr itrWillClose True
                                writeItr itr itrState     Done
                                writeDefaultPage itr
@@ -78,8 +76,8 @@ requestReader cnf tree h host tQueue
                action
                    <- atomically $
                       do preprocess itr
-                         isErr <- readItrF itr itrResponse (isError . resStatus)
-                         if isErr == Just True then
+                         isErr <- readItr itr itrResponse (isError . resStatus)
+                         if isErr then
                              acceptSemanticallyInvalidRequest itr input
                            else
                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
@@ -100,12 +98,10 @@ requestReader cnf tree h host tQueue
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input
-          = do let res = Response {
-                           resVersion = HttpVersion 1 1
-                         , resStatus  = NotFound
-                         , resHeaders = []
-                         }
-               writeItr itr itrResponse $ Just res
+          = do updateItr itr itrResponse 
+                             $ \res -> res {
+                                         resStatus = NotFound
+                                       }
                writeItr itr itrState Done
                writeDefaultPage itr
                postprocess itr
@@ -225,17 +221,14 @@ requestReader cnf tree h host tQueue
 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr
-          = let res = Response {
-                        resVersion = HttpVersion 1 1
-                      , resStatus  = BadRequest
-                      , resHeaders = []
-                      }
-            in
-              atomically $ do writeItr itr itrResponse $ Just res
-                              writeItr itr itrWillClose True
-                              writeItr itr itrState Done
-                              writeDefaultPage itr
-                              postprocess itr
+          = atomically $ do updateItr itr itrResponse 
+                                          $ \ res -> res {
+                                                       resStatus = BadRequest
+                                                     }
+                            writeItr itr itrWillClose True
+                            writeItr itr itrState Done
+                            writeDefaultPage itr
+                            postprocess itr
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input