X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=29c3c5167cb375accbce646038b110a4a0b0b601;hp=bc9363d1115de6740032c1d858ac9baab4e65ea3;hb=51eda5b;hpb=8225cc52ffe4c3d900ae1f79573089be230b80bd diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index bc9363d..29c3c51 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 @@ -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