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

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 24a07f18bb7d74af7e9ba7ac6468738633dfc0cf..124b66bd2ba3e4c4a4ac9aef92c4f9c76e0957ef 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -41,9 +41,9 @@ import           System.Time
   * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server
     Error にする。但し identity だけは許す。
 
-  * body を持つ事が出來る時、Content-Type が無ければ
-    application/octet-stream にする。出來ない時、HEAD でなければ
-    Content-Type, Etag, Last-Modified を削除する。
+  * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
+    出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
+    する。
 
   * body を持つ事が出來ない時、body 破棄フラグを立てる。
 
@@ -59,41 +59,32 @@ import           System.Time
 
 postprocess :: Interaction -> STM ()
 postprocess itr
-    = do resM <- readItr itr itrResponse id
-
-         case resM of
-           Nothing  -> writeItr itr itrResponse
-                       $ Just $ Response {
-                               resVersion = HttpVersion 1 1
-                             , resStatus  = Ok
-                             , resHeaders = []
-                             }
-           Just res -> do let sc = resStatus res
-
-                          when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
-                                   $ abortSTM InternalServerError []
-                                         $ Just ("The status code is not good for a final status: "
-                                                 ++ show sc)
-
-                          when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
-                                   $ abortSTM InternalServerError []
-                                         $ Just ("The status was " ++ show sc ++ " but no Allow header.")
-
-                          when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
-                                   $ abortSTM InternalServerError []
-                                         $ Just ("The status code was " ++ show sc ++ " but no Location header.")
+    = do res <- readItr itr itrResponse id
+         let sc = resStatus res
+
+         when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
+                  $ abortSTM InternalServerError []
+                        $ Just ("The status code is not good for a final status: "
+                                ++ show sc)
+
+         when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
+                  $ abortSTM InternalServerError []
+                        $ Just ("The status was " ++ show sc ++ " but no Allow header.")
+
+         when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
+                  $ abortSTM InternalServerError []
+                        $ Just ("The status code was " ++ show sc ++ " but no Location header.")
 
          when (itrRequest itr /= Nothing)
               $ relyOnRequest itr
 
-         do oldRes <- readItr itr itrResponse id
-            newRes <- unsafeIOToSTM
-                      $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes)
-            writeItr itr itrResponse $ Just newRes
+         do newRes <- unsafeIOToSTM
+                      $ completeUnconditionalHeaders (itrConfig itr) res
+            writeItr itr itrResponse newRes
     where
       relyOnRequest :: Interaction -> STM ()
       relyOnRequest itr
-          = do status <- readItr itr itrResponse (resStatus . fromJust)
+          = do status <- readItr itr itrResponse resStatus
 
                let req         = fromJust $ itrRequest itr
                    reqVer      = reqVersion req
@@ -109,7 +100,7 @@ postprocess itr
 
                cType <- readHeader itr "Content-Type"
                when (cType == Nothing)
-                        $ updateRes itr $ setHeader "Content-Type" "application/octet-stream"
+                        $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
 
                if canHaveBody then
                    do teM <- readHeader itr "Transfer-Encoding"
@@ -157,14 +148,11 @@ postprocess itr
 
       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
+          = readItr itr itrResponse $ getHeader name
 
       updateRes :: Interaction -> (Response -> Response) -> STM ()
       updateRes itr updator 
-          = updateItrF itr itrResponse updator
+          = updateItr itr itrResponse updator
 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response