Code reorganisation

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 39b6b4c16f24ff608c12f1c59780225682915b91..ddda849169e4a428e8469412c530675b102b7289 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -6,44 +6,37 @@
   #-}
 module Network.HTTP.Lucu.Postprocess
     ( postprocess
   #-}
 module Network.HTTP.Lucu.Postprocess
     ( postprocess

-    , completeUnconditionalHeaders

     )
     where
     )
     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 Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)

-import qualified Data.Ascii as A
+import Data.Convertible.Base
+import Data.Maybe

 import Data.Monoid.Unicode
 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 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.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response

+import Network.HTTP.Lucu.Response.StatusCode

 import Prelude.Unicode
 
 import Prelude.Unicode
 

-postprocess ∷ Interaction → STM ()
-postprocess itr@(Interaction {..})
-    = do abortOnCertainConditions itr
-         writeDefaultPageIfNeeded itr
+postprocess ∷ NormalInteraction → STM ()
+postprocess ni@(NI {..})
+    = do void $ tryPutTMVar niSendContinue False
+         abortOnCertainConditions ni
+         postprocessWithRequest ni
+         completeUnconditionalHeaders ni

 
 

-         case itrRequest of
-           Just req → postprocessWithRequest itr req
-           Nothing  → return ()
-
-         updateResIO itr $ completeUnconditionalHeaders itrConfig
-
-abortOnCertainConditions ∷ Interaction → STM ()
-abortOnCertainConditions (Interaction {..})
-    = readTVar itrResponse ≫= go
+abortOnCertainConditions ∷ NormalInteraction → STM ()
+abortOnCertainConditions (NI {..})
+    = readTVar niResponse ≫= go

     where
       go ∷ Response → STM ()
       go res@(Response {..})
     where
       go ∷ Response → STM ()
       go res@(Response {..})


@@ -52,111 +45,97 @@ abortOnCertainConditions (Interaction {..})
                                                , isError
                                                ])
                    $ abort'
                                                , isError
                                                ])
                    $ abort'

-                   $ A.toAsciiBuilder "Inappropriate status code for a response: "
-                   ⊕ printStatusCode resStatus
+                   $ cs ("Inappropriate status code for a response: " ∷ Ascii)
+                   ⊕ cs resStatus

 
 

-               when ( resStatus ≡ MethodNotAllowed ∧
-                      hasHeader "Allow" res        )
+               when ( resStatus ≡ cs MethodNotAllowed ∧
+                      (¬) (hasHeader "Allow" res)     )

                    $ abort'
                    $ abort'

-                   $ A.toAsciiBuilder "The status was "
-                   ⊕ printStatusCode resStatus
-                   ⊕ A.toAsciiBuilder " but no \"Allow\" header."
+                   $ cs ("The status was " ∷ Ascii)
+                   ⊕ cs resStatus
+                   ⊕ cs (" but no \"Allow\" header." ∷ Ascii)

 
 

-               when ( resStatus ≢ NotModified  ∧
-                      isRedirection resStatus ∧
-                      hasHeader "Location" res )
+               when ( resStatus ≢ cs NotModified     ∧
+                      isRedirection resStatus        ∧
+                      (¬) (hasHeader "Location" res) )

                    $ abort'
                    $ abort'

-                   $ A.toAsciiBuilder "The status code was "
-                   ⊕ printStatusCode resStatus
-                   ⊕ A.toAsciiBuilder " but no Location header."
+                   $ cs ("The status code was " ∷ Ascii)
+                   ⊕ cs resStatus
+                   ⊕ cs (" but no Location header." ∷ Ascii)

 
       abort' ∷ AsciiBuilder → STM ()
 
       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
+      abort' = throwSTM
+               ∘ mkAbortion' InternalServerError
+               ∘ cs

 
 

-         updateRes itr
+postprocessWithRequest ∷ NormalInteraction → STM ()
+postprocessWithRequest ni@(NI {..})
+    = do updateRes ni

              $ deleteHeader "Content-Length"
              ∘ deleteHeader "Transfer-Encoding"
 
              $ deleteHeader "Content-Length"
              ∘ deleteHeader "Transfer-Encoding"
 

+         canHaveBody ← resCanHaveBody <$> readTVar niResponse

          if canHaveBody then
          if canHaveBody then

-             do when (reqVersion ≡ HttpVersion 1 1)
-                    $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
-                         writeTVar itrWillChunkBody True
-                writeDefaultPageIfNeeded itr
+             do when niWillChunkBody
+                    $ writeHeader ni "Transfer-Encoding" (Just "chunked")
+                when (reqMethod niRequest ≢ HEAD)
+                    $ writeDefaultPageIfNeeded ni

          else
          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
+             -- These headers make sense for HEAD requests even when
+             -- there won't be a response entity body.
+             when (reqMethod niRequest ≢ HEAD)
+                 $ updateRes ni
+                 $ deleteHeader "Content-Type"
+                 ∘ deleteHeader "Etag"
+                 ∘ deleteHeader "Last-Modified"
+
+         hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
+         willClose    ← readTVar niWillClose

          when (hasConnClose ∧ (¬) willClose)
          when (hasConnClose ∧ (¬) willClose)

-             $ writeTVar itrWillClose True
+             $ writeTVar niWillClose True

          when ((¬) hasConnClose ∧ willClose)
          when ((¬) hasConnClose ∧ willClose)

-             $ writeHeader itr "Connection" (Just "close")
+             $ writeHeader ni "Connection" (Just "close")

 
 

-writeDefaultPageIfNeeded ∷ Interaction → STM ()
-writeDefaultPageIfNeeded itr@(Interaction {..})
-    = do resHasCType ← readTVar itrResponseHasCType
+writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
+writeDefaultPageIfNeeded ni@(NI {..})
+    = do resHasCType ← readTVar niResponseHasCType

          unless resHasCType
          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 ()
+             $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
+                  writeHeader ni "Content-Encoding" Nothing
+                  res ← readTVar niResponse
+                  let body = defaultPageForResponse niConfig (Just niRequest) res
+                  putTMVar niBodyToSend body
+
+completeUnconditionalHeaders ∷ NormalInteraction → STM ()
+completeUnconditionalHeaders ni@(NI {..})
+    = do srv ← readHeader ni "Server"
+         when (isNothing srv) $
+             writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
+
+         date ← readHeader ni "Date"
+         when (isNothing date) $
+             do date' ← unsafeIOToSTM getCurrentDate
+                writeHeader ni "Date" $ Just date'
+
+writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()

 {-# INLINE writeHeader #-}
 {-# INLINE writeHeader #-}

-writeHeader itr k v
+writeHeader ni k v

     = case v of
     = case v of

-        Just v' → updateRes itr $ setHeader    k v'
-        Nothing → updateRes itr $ deleteHeader k
+        Just v' → updateRes ni $ setHeader    k v'
+        Nothing → updateRes ni $ deleteHeader k

 
 

-readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
+readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
+{-# INLINE readHeader #-}
+readHeader (NI {..}) k
+    = getHeader k <$> readTVar niResponse
+
+readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)

 {-# INLINE readCIHeader #-}
 {-# INLINE readCIHeader #-}

-readCIHeader (Interaction {..}) k
-    = getCIHeader k <$> readTVar itrResponse
+readCIHeader (NI {..}) k
+    = getCIHeader k <$> readTVar niResponse

 
 

-updateRes ∷ Interaction → (Response → Response) → STM ()
+updateRes ∷ NormalInteraction → (Response → Response) → STM ()

 {-# INLINE updateRes #-}
 {-# 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
-      where
-        compServer res'
-            = case getHeader "Server" res' of
-                Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
-                Just _  → return res'
-
-        compDate res'
-            = case getHeader "Date" res' of
-                Nothing → do date ← getCurrentDate
-                             return $ setHeader "Date" date res'
-                Just _  → return res'
-
-getCurrentDate ∷ IO Ascii
-getCurrentDate = HTTP.toAscii <$> getCurrentTime
+updateRes (NI {..}) f
+    = do old ← readTVar niResponse
+         writeTVar niResponse $ f old