Many improvements

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index b7b910f3142ed54caa0078e2a78a35105ec9fe36..929413cd0ce86a19ce389067f98a8e61265aaa0b 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -51,7 +51,7 @@ import           System.Time
 
 postprocess :: Interaction -> STM ()
 postprocess itr
-    = do res <- readTVar (itrResponse itr)
+    = do res <- readItr itr itrResponse id
 
          when (res == Nothing)
               $ setStatus itr InternalServerError
@@ -59,59 +59,62 @@ postprocess itr
          when (itrRequest itr /= Nothing)
               $ relyOnRequest itr
 
-         do oldRes <- readTVar (itrResponse itr)
+         do oldRes <- readItr itr itrResponse id
             newRes <- unsafeIOToSTM $ completeUnconditionalHeaders $ fromJust oldRes
-            setRes itr newRes
+            writeItr itr itrResponse $ Just newRes
     where
       relyOnRequest itr
-          = do resM <- readTVar (itrResponse itr)
+          = do status <- readItr itr itrResponse (resStatus . fromJust)
 
                let req         = fromJust $ itrRequest itr
                    reqVer      = reqVersion req
-                   res         = fromJust resM
-                   status      = resStatus res
                    canHaveBody = if reqMethod req == HEAD then
                                      False
                                  else
-                                     isInformational status ||
-                                     status == NoContent    ||
-                                     status == ResetContent ||
-                                     status == NotModified
+                                     not (isInformational status ||
+                                          status == NoContent    ||
+                                          status == ResetContent ||
+                                          status == NotModified    )
 
-               setRes itr (deleteHeader res "Content-Length")
+               updateRes itr $ deleteHeader "Content-Length"
 
                if canHaveBody then
-                   do if reqVer == HttpVersion 1 1 then
-
-                          case getHeader res "Transfer-Encoding" of
-                            Nothing -> setRes itr (setHeader res "Transfer-Encoding" "chunked")
-                            Just te -> let teList = [trim isWhiteSpace x
-                                                         | x <- splitBy (== ',') (map toLower te)]
-                                       in
-                                         when (teList == [] || last teList /= "chunked")
-                                                  $ setStatus itr InternalServerError
+                   do teM <- readHeader itr "Transfer-Encoding"
+                      if reqVer == HttpVersion 1 1 then
+
+                          do case teM of
+                               Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+                               Just te -> let teList = [trim isWhiteSpace x
+                                                            | x <- splitBy (== ',') (map toLower te)]
+                                          in
+                                            when (teList == [] || last teList /= "chunked")
+                                                     $ setStatus itr InternalServerError
+
+                             writeItr itr itrWillChunkBody True
                         else
-                          case getHeader res "Transfer-Encoding" of
+                          case fmap (map toLower) teM of
                             Nothing         -> return ()
                             Just "identity" -> return ()
                             _               -> setStatus itr InternalServerError
-                
-                      when (getHeader res "Content-Type" == Nothing)
-                               $ setRes itr (setHeader res "Content-Type" "application/octet-stream")
+
+                      cType <- readHeader itr "Content-Type"
+                      when (cType == Nothing)
+                               $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
                  else
                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
-                   do setRes itr (deleteHeader res "Transfer-Encoding")
+                   do updateRes itr $ deleteHeader "Transfer-Encoding"
                       when (reqMethod req /= HEAD)
-                               $ setRes itr (deleteHeader res "Content-Type")
+                               $ updateRes itr $ deleteHeader "Content-Type"
 
-               if fmap (map toLower) (getHeader res "Connection") == Just "close" then
-                   writeTVar (itrWillClose itr) True
-                 else
-                   setRes itr (setHeader res "Connection" "close")
+               conn <- readHeader itr "Connection"
+               case fmap (map toLower) conn of
+                 Just "close" -> writeItr itr itrWillClose True
+                 _            -> updateRes itr $ setHeader "Connection" "close"
 
                when (reqMethod req == HEAD || not canHaveBody)
                         $ writeTVar (itrWillDiscardBody itr) True
 
+      setStatus :: Interaction -> StatusCode -> STM ()
       setStatus itr status
           = writeTVar (itrResponse itr) (Just $ Response {
                                                     resVersion = HttpVersion 1 1
@@ -119,8 +122,16 @@ postprocess itr
                                                   , resHeaders = []
                                                   })
 
-      setRes itr res
-          = writeTVar (itrResponse itr) (Just res)
+      readHeader :: Interaction -> String -> STM (Maybe String)
+      readHeader itr name
+          = do valueMM <- readItrF itr itrResponse $ getHeader name
+               case valueMM of
+                 Just (Just val) -> return $ Just val
+                 _               -> return Nothing
+
+      updateRes :: Interaction -> (Response -> Response) -> STM ()
+      updateRes itr updator 
+          = updateItrF itr itrResponse updator
 
 
 completeUnconditionalHeaders :: Response -> IO Response
@@ -128,12 +139,12 @@ completeUnconditionalHeaders res
     = return res >>= compServer >>= compDate >>= return
       where
         compServer res
-            = case getHeader res "Server" of
-                Nothing -> return $ addHeader res "Server" "Lucu/1.0"
+            = case getHeader "Server" res of
+                Nothing -> return $ addHeader "Server" "Lucu/1.0" res
                 Just _  -> return res
 
         compDate res
-            = case getHeader res "Date" of
+            = case getHeader "Date" res of
                 Nothing -> do time <- getClockTime
-                              return $ addHeader res "Date" $ formatHTTPDateTime time
+                              return $ addHeader "Date" (formatHTTPDateTime time) res
                 Just _  -> return res
\ No newline at end of file