X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=131cc8ebb3e65f7426a3bf245cc14185a1502795;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=a7c2e070843c45b4f357687c81cebb083a9d02e7;hpb=db4b61223e0d8b34079d3b190fb3e3644b0b4866;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index a7c2e07..131cc8e 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,7 +1,7 @@ {-# LANGUAGE - BangPatterns - , DoAndIfThenElse + DoAndIfThenElse , OverloadedStrings + , RecordWildCards , 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 Data.Ascii (Ascii, CIAscii) +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 @@ -29,126 +29,119 @@ import Network.HTTP.Lucu.Request 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 - 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