Many many changes

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index a7c2e070843c45b4f357687c81cebb083a9d02e7..131cc8ebb3e65f7426a3bf245cc14185a1502795 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    BangPatterns
-  , DoAndIfThenElse
+    DoAndIfThenElse

   , OverloadedStrings
   , OverloadedStrings

+  , RecordWildCards

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


@@ -13,15 +13,15 @@ import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Unicode
 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


@@ -29,126 +29,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

 
 

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

 
 

--}
+         updateResIO itr $ completeUnconditionalHeaders itrConfig

 
 

-postprocess ∷ Interaction → STM ()
-postprocess !itr
-    = do reqM ← readItr itrRequest  id itr
-         res  ← readItr itrResponse id itr
-         let sc = resStatus res
-
-         unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
-             $ abortSTM InternalServerError []
-             $ Just
-             $ A.toText ( "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 ( "The status was "
-                          ⊕ printStatusCode sc
-                          ⊕ " but no Allow header." )
-
-         when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
-             $ abortSTM InternalServerError []
-             $ Just
-             $ A.toText ( "The status code was "
-                          ⊕ printStatusCode sc
-                          ⊕ " but no Location header." )
-
-         when (reqM ≢ Nothing) relyOnRequest
-
-         -- itrResponse の内容は relyOnRequest によって變へられてゐる可
-         -- 能性が高い。
-         do oldRes ← readItr itrResponse id 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 ← readItr itrResponse resStatus itr
-               req    ← readItr itrRequest  fromJust  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 id 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 = readItr itrResponse (getHeader k) 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)
+                  writeHeader itr "Content-Encoding" Nothing
+                  res ← readTVar itrResponse
+                  let page = getDefaultPage itrConfig itrRequest res
+                  putTMVar itrBodyToSend 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