Many improvements

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 4f63f28bb2a7293e907e08df9f1fc2a845b5f419..12cad2040039a95fd30426076ebfc45534a4c3b0 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -15,6 +15,7 @@ import qualified Data.Sequence as S
 import           Data.Sequence (Seq, (<|), ViewR(..))
 import           Network
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Parser
@@ -63,9 +64,10 @@ requestReader cnf tree h host tQueue
                          , resStatus  = BadRequest
                          , resHeaders = []
                          }
-               atomically $ do writeTVar (itrResponse  itr) $ Just res
-                               writeTVar (itrWillClose itr) True
-                               writeTVar (itrState     itr) Done
+               atomically $ do writeItr itr itrResponse $ Just res
+                               writeItr itr itrWillClose True
+                               writeItr itr itrState     Done
+                               writeDefaultPage itr
                                postprocess itr
                                enqueue itr
 
@@ -75,8 +77,8 @@ requestReader cnf tree h host tQueue
                action
                    <- atomically $
                       do preprocess itr
-                         res <- readTVar (itrResponse itr)
-                         if fmap isError (fmap resStatus res) == Just True then
+                         isErr <- readItrF itr itrResponse (isError . resStatus)
+                         if isErr == Just True then
                              acceptSemanticallyInvalidRequest itr input'
                            else
                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
@@ -89,7 +91,8 @@ requestReader cnf tree h host tQueue
 
       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
       acceptSemanticallyInvalidRequest itr input
-          = do writeTVar (itrState itr) Done
+          = do writeItr itr itrState Done
+               writeDefaultPage itr
                postprocess itr
                enqueue itr
                return $ acceptRequest input
@@ -101,18 +104,19 @@ requestReader cnf tree h host tQueue
                          , resStatus  = NotFound
                          , resHeaders = []
                          }
-               writeTVar (itrResponse  itr) $ Just res
-               writeTVar (itrState     itr) Done
+               writeItr itr itrResponse $ Just res
+               writeItr itr itrState Done
+               writeDefaultPage itr
                postprocess itr
                enqueue itr
                return $ acceptRequest input
 
       acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
       acceptRequestForExistentResource itr input rsrcDef
-          = do requestHasBody <- readTVar (itrRequestHasBody itr)
-               writeTVar (itrState itr) (if requestHasBody
-                                         then ExaminingHeader
-                                         else DecidingHeader)
+          = do requestHasBody <- readItr itr itrRequestHasBody id
+               writeItr itr itrState (if requestHasBody
+                                      then ExaminingHeader
+                                      else DecidingHeader)
                enqueue itr
                return $ do runResource rsrcDef itr
                            if requestHasBody then