Fixed many bugs...

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 1a00b00b0eab578bca9db5d52e3e6bf4003abf46..39b6b4c16f24ff608c12f1c59780225682915b91 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     DoAndIfThenElse
   , OverloadedStrings
 {-# LANGUAGE
     DoAndIfThenElse
   , OverloadedStrings

+  , RecordWildCards

   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Postprocess
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Postprocess


@@ -8,19 +9,20 @@ module Network.HTTP.Lucu.Postprocess
     , completeUnconditionalHeaders
     )
     where
     , completeUnconditionalHeaders
     )
     where

+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB

 import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Unicode
 import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Unicode

-import Data.Ascii (Ascii, CIAscii)
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)

 import qualified Data.Ascii as A
 import qualified Data.Ascii as A

-import Data.Maybe

 import Data.Monoid.Unicode
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import GHC.Conc (unsafeIOToSTM)
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import Data.Monoid.Unicode
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import GHC.Conc (unsafeIOToSTM)
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config

+import Network.HTTP.Lucu.DefaultPage

 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction


@@ -28,132 +30,119 @@ import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 

-{-
-  
-  * Response が未設定なら、200 OK にする。
-
-  * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
-
-  * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
-
-  * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
-    する。
-
-  * Content-Length があれば、それを削除する。Transfer-Encoding があって
-    も削除する。
-
-  * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
-    chunked に設定する。
-
-  * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
-    出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
-    する。
-
-  * body を持つ事が出來ない時、body 破棄フラグを立てる。
-
-  * Connection: close が設定されてゐる時、切斷フラグを立てる。
-
-  * 切斷フラグが立ってゐる時、Connection: close を設定する。
-
-  * Server が無ければ設定。
+postprocess ∷ Interaction → STM ()
+postprocess itr@(Interaction {..})
+    = do abortOnCertainConditions itr
+         writeDefaultPageIfNeeded itr

 
 

-  * Date が無ければ設定。
+         case itrRequest of
+           Just req → postprocessWithRequest itr req
+           Nothing  → return ()

 
 

--}
+         updateResIO itr $ completeUnconditionalHeaders itrConfig

 
 

-postprocess ∷ Interaction → STM ()
-postprocess itr
-    = do reqM ← readItr itrRequest  itr
-         res  ← readItr itrResponse itr
-         let sc = resStatus res
-
-         unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
-             $ abortSTM InternalServerError []
-             $ Just
-             $ A.toText
-             $ A.fromAsciiBuilder
-             $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
-             ⊕ printStatusCode sc
-
-         when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
-             $ abortSTM InternalServerError []
-             $ Just
-             $ A.toText
-             $ A.fromAsciiBuilder
-             $ A.toAsciiBuilder "The status was "
-             ⊕ printStatusCode sc
-             ⊕ A.toAsciiBuilder " but no Allow header."
-
-         when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
-             $ abortSTM InternalServerError []
-             $ Just
-             $ A.toText
-             $ A.fromAsciiBuilder
-             $ A.toAsciiBuilder "The status code was "
-             ⊕ printStatusCode sc
-             ⊕ A.toAsciiBuilder " but no Location header."
-
-         when (reqM ≢ Nothing) relyOnRequest
-
-         -- itrResponse の内容は relyOnRequest によって變へられてゐる可
-         -- 能性が高い。
-         do oldRes ← readItr itrResponse itr
-            newRes ← unsafeIOToSTM
-                     $ completeUnconditionalHeaders (itrConfig itr) oldRes
-            writeItr itrResponse newRes itr
+abortOnCertainConditions ∷ Interaction → STM ()
+abortOnCertainConditions (Interaction {..})
+    = readTVar itrResponse ≫= go

     where
     where

-      relyOnRequest ∷ STM ()
-      relyOnRequest
-          = do status ← resStatus <$> readItr itrResponse itr
-               req    ← fromJust  <$> readItr itrRequest  itr
-
-               let reqVer      = reqVersion req
-                   canHaveBody = if reqMethod req ≡ HEAD then
-                                     False
-                                 else
-                                     not (isInformational status ∨
-                                          status ≡ NoContent     ∨
-                                          status ≡ ResetContent  ∨
-                                          status ≡ NotModified   )
-
-               updateRes $ deleteHeader "Content-Length"
-               updateRes $ deleteHeader "Transfer-Encoding"
-
-               cType ← readHeader "Content-Type"
-               when (cType ≡ Nothing)
-                        $ updateRes $ setHeader "Content-Type" defaultPageContentType
-
-               if canHaveBody then
-                   when (reqVer ≡ HttpVersion 1 1)
-                       $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
-                            writeItr itrWillChunkBody True itr
-               else
-                   -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
-                   when (reqMethod req ≢ HEAD)
-                       $ do updateRes $ deleteHeader "Content-Type"
-                            updateRes $ deleteHeader "Etag"
-                            updateRes $ deleteHeader "Last-Modified"
-
-               conn ← readHeader "Connection"
-               case conn of
-                 Nothing    → return ()
-                 Just value → when (A.toCIAscii value ≡ "close")
-                                  $ writeItr itrWillClose True itr
-
-               willClose ← readItr itrWillClose itr
-               when willClose
-                   $ updateRes $ setHeader "Connection" "close"
-
-               when (reqMethod req ≡ HEAD ∨ not canHaveBody)
-                   $ writeTVar (itrWillDiscardBody itr) True
-
-      readHeader ∷ CIAscii → STM (Maybe Ascii)
-      {-# INLINE readHeader #-}
-      readHeader k = getHeader k <$> readItr itrResponse itr
-
-      updateRes ∷ (Response → Response) → STM ()
-      {-# INLINE updateRes #-}
-      updateRes f = updateItr itrResponse f itr
+      go ∷ Response → STM ()
+      go res@(Response {..})
+          = do unless (any (\ p → p resStatus) [ isSuccessful
+                                               , isRedirection
+                                               , isError
+                                               ])
+                   $ abort'
+                   $ A.toAsciiBuilder "Inappropriate status code for a response: "
+                   ⊕ printStatusCode resStatus
+
+               when ( resStatus ≡ MethodNotAllowed ∧
+                      hasHeader "Allow" res        )
+                   $ abort'
+                   $ A.toAsciiBuilder "The status was "
+                   ⊕ printStatusCode resStatus
+                   ⊕ A.toAsciiBuilder " but no \"Allow\" header."
+
+               when ( resStatus ≢ NotModified  ∧
+                      isRedirection resStatus ∧
+                      hasHeader "Location" res )
+                   $ abort'
+                   $ A.toAsciiBuilder "The status code was "
+                   ⊕ printStatusCode resStatus
+                   ⊕ A.toAsciiBuilder " but no Location header."
+
+      abort' ∷ AsciiBuilder → STM ()
+      abort' = abortSTM InternalServerError []
+               ∘ Just
+               ∘ A.toText
+               ∘ A.fromAsciiBuilder
+
+postprocessWithRequest ∷ Interaction → Request → STM ()
+postprocessWithRequest itr@(Interaction {..}) (Request {..})
+    = do willDiscardBody ← readTVar itrWillDiscardBody
+         canHaveBody     ← if willDiscardBody then
+                               return False
+                           else
+                               resCanHaveBody <$> readTVar itrResponse
+
+         updateRes itr
+             $ deleteHeader "Content-Length"
+             ∘ deleteHeader "Transfer-Encoding"
+
+         if canHaveBody then
+             do when (reqVersion ≡ HttpVersion 1 1)
+                    $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
+                         writeTVar itrWillChunkBody True
+                writeDefaultPageIfNeeded itr
+         else
+             do writeTVar itrWillDiscardBody True
+                -- These headers make sense for HEAD requests even
+                -- when there won't be a response entity body.
+                when (reqMethod ≢ HEAD)
+                    $ updateRes itr
+                    $ deleteHeader "Content-Type"
+                    ∘ deleteHeader "Etag"
+                    ∘ deleteHeader "Last-Modified"
+
+         hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
+         willClose    ← readTVar itrWillClose
+         when (hasConnClose ∧ (¬) willClose)
+             $ writeTVar itrWillClose True
+         when ((¬) hasConnClose ∧ willClose)
+             $ writeHeader itr "Connection" (Just "close")
+
+writeDefaultPageIfNeeded ∷ Interaction → STM ()
+writeDefaultPageIfNeeded itr@(Interaction {..})
+    = do resHasCType ← readTVar itrResponseHasCType
+         unless resHasCType
+             $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
+                  res ← readTVar itrResponse
+                  let page = getDefaultPage itrConfig itrRequest res
+                  putTMVar itrBodyToSend (BB.fromLazyText page)
+
+writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
+{-# INLINE writeHeader #-}
+writeHeader itr k v
+    = case v of
+        Just v' → updateRes itr $ setHeader    k v'
+        Nothing → updateRes itr $ deleteHeader k
+
+readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
+{-# INLINE readCIHeader #-}
+readCIHeader (Interaction {..}) k
+    = getCIHeader k <$> readTVar itrResponse
+
+updateRes ∷ Interaction → (Response → Response) → STM ()
+{-# INLINE updateRes #-}
+updateRes (Interaction {..}) f
+    = do old ← readTVar itrResponse
+         writeTVar itrResponse (f old)
+
+updateResIO ∷ Interaction → (Response → IO Response) → STM ()
+{-# INLINE updateResIO #-}
+updateResIO (Interaction {..}) f
+    = do old ← readTVar itrResponse
+         new ← unsafeIOToSTM $ f old
+         writeTVar itrResponse new

 
 completeUnconditionalHeaders ∷ Config → Response → IO Response
 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
 
 completeUnconditionalHeaders ∷ Config → Response → IO Response
 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer