]> gitweb @ CieloNegro.org - Lucu.git/blobdiff - Network/HTTP/Lucu/Postprocess.hs
StatusCode is now a type class, not an algebraic data type.
[Lucu.git] / Network / HTTP / Lucu / Postprocess.hs
index bc9363d1115de6740032c1d858ac9baab4e65ea3..29c3c5167cb375accbce646038b110a4a0b0b601 100644 (file)
@@ -6,7 +6,6 @@
   #-}
 module Network.HTTP.Lucu.Postprocess
     ( postprocess
-    , completeUnconditionalHeaders
     )
     where
 import Control.Applicative
@@ -15,33 +14,28 @@ import Control.Monad
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 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 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 Prelude.Unicode
 
-postprocess ∷ Interaction → STM ()
-postprocess itr@(Interaction {..})
-    = do abortOnCertainConditions 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 {..})
@@ -53,14 +47,14 @@ abortOnCertainConditions (Interaction {..})
                    $ A.toAsciiBuilder "Inappropriate status code for a response: "
                    ⊕ printStatusCode resStatus
 
-               when ( resStatus ≡ MethodNotAllowed ∧
-                      hasHeader "Allow" res        )
+               when ( toStatusCode resStatus ≡ Just MethodNotAllowed ∧
+                      hasHeader "Allow" res )
                    $ abort'
                    $ A.toAsciiBuilder "The status was "
                    ⊕ printStatusCode resStatus
                    ⊕ A.toAsciiBuilder " but no \"Allow\" header."
 
-               when ( resStatus ≢ NotModified  ∧
+               when ( toStatusCode resStatus ≢ Just NotModified  ∧
                       isRedirection resStatus ∧
                       hasHeader "Location" res )
                    $ abort'
@@ -69,94 +63,84 @@ abortOnCertainConditions (Interaction {..})
                    ⊕ A.toAsciiBuilder " but no Location header."
 
       abort' ∷ AsciiBuilder → STM ()
-      abort' = abortSTM InternalServerError []
-               ∘ Just
+      abort' = throwSTM
+               ∘ mkAbortion' InternalServerError
                ∘ A.toText
                ∘ A.fromAsciiBuilder
 
-postprocessWithRequest ∷ Interaction → Request → STM ()
-postprocessWithRequest itr@(Interaction {..}) (Request {..})
-    = do willDiscardBody ← readTVar itrWillDiscardBody
+postprocessWithRequest ∷ NormalInteraction → STM ()
+postprocessWithRequest ni@(NI {..})
+    = do willDiscardBody ← readTVar niWillDiscardBody
          canHaveBody     ← if willDiscardBody then
                                return False
                            else
-                               resCanHaveBody <$> readTVar itrResponse
+                               resCanHaveBody <$> readTVar niResponse
 
-         updateRes itr
+         updateRes ni
              $ 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
+             do when niWillChunkBody $
+                    writeHeader ni "Transfer-Encoding" (Just "chunked")
+                writeDefaultPageIfNeeded ni
          else
-             do writeTVar itrWillDiscardBody True
+             do writeTVar niWillDiscardBody True
                 -- These headers make sense for HEAD requests even
                 -- when there won't be a response entity body.
-                when (reqMethod ≢ HEAD)
-                    $ updateRes itr
+                when (reqMethod niRequest ≢ HEAD)
+                    $ updateRes ni
                     $ deleteHeader "Content-Type"
                     ∘ deleteHeader "Etag"
                     ∘ deleteHeader "Last-Modified"
 
-         hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
-         willClose    ← readTVar itrWillClose
+         hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
+         willClose    ← readTVar niWillClose
          when (hasConnClose ∧ (¬) willClose)
-             $ writeTVar itrWillClose True
+             $ writeTVar niWillClose True
          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
-             $ 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 ()
+             $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
+                  writeHeader ni "Content-Encoding" Nothing
+                  res ← readTVar niResponse
+                  let body = getDefaultPage 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 #-}
-writeHeader itr k v
+writeHeader ni k v
     = 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
+
+readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
+{-# INLINE readHeader #-}
+readHeader (NI {..}) k
+    = getHeader k <$> readTVar niResponse
 
-readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
+readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
 {-# 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 #-}
-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
-
--- FIXME: Narrow the use of IO monad!
-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