X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=7157b7d56e9dd14c4dcaa635ce47be599d2d15f6;hp=bc9363d1115de6740032c1d858ac9baab4e65ea3;hb=246d66d6d3130e03834a6c3badc38711a1879aae;hpb=8225cc52ffe4c3d900ae1f79573089be230b80bd diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index bc9363d..7157b7d 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -6,7 +6,6 @@ #-} module Network.HTTP.Lucu.Postprocess ( postprocess - , completeUnconditionalHeaders ) where import Control.Applicative @@ -14,34 +13,29 @@ 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.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 {..}) @@ -50,113 +44,97 @@ abortOnCertainConditions (Interaction {..}) , 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 ∧ + when ( resStatus ≈ MethodNotAllowed ∧ hasHeader "Allow" res ) $ 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 ∧ + when ( resStatus ≉ NotModified ∧ + isRedirection resStatus ∧ hasHeader "Location" res ) $ 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' = 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" + canHaveBody ← resCanHaveBody <$> readTVar niResponse 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 - 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) - $ 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 = 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 #-} -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 -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 #-} -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