X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=49c95e809be046489bed306c83db6f77eab12baf;hb=c6847797963abde98faf6aa6425c9bebc0e5dfb5;hp=071ab56b1ea3f7e5f8770e803268f166c24c2c4d;hpb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 071ab56..49c95e8 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,25 +1,37 @@ --- #hide +{-# LANGUAGE + BangPatterns + , DoAndIfThenElse + , OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Postprocess ( postprocess , completeUnconditionalHeaders ) where - -import Control.Concurrent.STM -import Control.Monad -import Data.Char -import Data.Maybe -import GHC.Conc (unsafeIOToSTM) -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.RFC1123DateTime -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils -import System.Time +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Char8 as C8 hiding (ByteString) +import Data.IORef +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.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import System.IO.Unsafe {- @@ -54,99 +66,107 @@ import System.Time -} -postprocess :: Interaction -> STM () -postprocess itr - = do reqM <- readItr itr itrRequest id - res <- readItr itr itrResponse id +postprocess ∷ Interaction → STM () +postprocess !itr + = do reqM ← readItr itr itrRequest id + res ← readItr itr itrResponse id let sc = resStatus res - when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) - $ abortSTM InternalServerError [] - $ Just ("The status code is not good for a final status: " - ++ show sc) + 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 ("The status was " ++ show sc ++ " but no Allow header.") + 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 ("The status code was " ++ show sc ++ " but no Location 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 itr + when (reqM /= Nothing) relyOnRequest -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 - do oldRes <- readItr itr itrResponse id - newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) oldRes + do oldRes ← readItr itr itrResponse id + newRes ← unsafeIOToSTM + $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where - relyOnRequest :: Interaction -> STM () - relyOnRequest itr - = do status <- readItr itr itrResponse resStatus - req <- readItr itr itrRequest fromJust + relyOnRequest ∷ STM () + relyOnRequest + = do status ← readItr itr itrResponse resStatus + req ← readItr itr itrRequest fromJust let reqVer = reqVersion req - canHaveBody = if reqMethod req == HEAD then + canHaveBody = if reqMethod req ≡ HEAD then False else - not (isInformational status || - status == NoContent || - status == ResetContent || - status == NotModified ) + not (isInformational status ∨ + status ≡ NoContent ∨ + status ≡ ResetContent ∨ + status ≡ NotModified ) - updateRes itr $ deleteHeader "Content-Length" - updateRes itr $ deleteHeader "Transfer-Encoding" + updateRes $ deleteHeader "Content-Length" + updateRes $ deleteHeader "Transfer-Encoding" - cType <- readHeader itr "Content-Type" - when (cType == Nothing) - $ updateRes itr $ setHeader "Content-Type" defaultPageContentType + cType ← readHeader "Content-Type" + when (cType ≡ Nothing) + $ updateRes $ setHeader "Content-Type" defaultPageContentType if canHaveBody then - when (reqVer == HttpVersion 1 1) - $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked" - writeItr itr itrWillChunkBody True - else + when (reqVer ≡ HttpVersion 1 1) + $ do updateRes $ setHeader "Transfer-Encoding" "chunked" + writeItr itr itrWillChunkBody True + else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す when (reqMethod req /= HEAD) - $ do updateRes itr $ deleteHeader "Content-Type" - updateRes itr $ deleteHeader "Etag" - updateRes itr $ deleteHeader "Last-Modified" + $ do updateRes $ deleteHeader "Content-Type" + updateRes $ deleteHeader "Etag" + updateRes $ deleteHeader "Last-Modified" - conn <- readHeader itr "Connection" - case fmap (map toLower) conn of - Just "close" -> writeItr itr itrWillClose True - _ -> return () + conn ← readHeader "Connection" + case conn of + Nothing → return () + Just value → when (A.toCIAscii value ≡ "close") + $ writeItr itr itrWillClose True - willClose <- readItr itr itrWillClose id + willClose ← readItr itr itrWillClose id when willClose - $ updateRes itr $ setHeader "Connection" "close" - - when (reqMethod req == HEAD || not canHaveBody) - $ writeTVar (itrWillDiscardBody itr) True + $ updateRes $ setHeader "Connection" "close" - readHeader :: Interaction -> String -> STM (Maybe String) - readHeader itr name - = readItr itr itrResponse $ getHeader name + when (reqMethod req ≡ HEAD ∨ not canHaveBody) + $ writeTVar (itrWillDiscardBody itr) True - updateRes :: Interaction -> (Response -> Response) -> STM () - updateRes itr updator - = updateItr itr itrResponse updator + readHeader ∷ CIAscii → STM (Maybe Ascii) + {-# INLINE readHeader #-} + readHeader = readItr itr itrResponse ∘ getHeader + updateRes ∷ (Response → Response) → STM () + {-# INLINE updateRes #-} + updateRes = updateItr itr itrResponse -completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders conf res - = return res >>= compServer >>= compDate >>= return +completeUnconditionalHeaders ∷ Config → Response → IO Response +completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer where - compServer res - = case getHeader "Server" res of - Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res - Just _ -> return res - - compDate res - = case getHeader "Date" res of - Nothing -> do time <- getClockTime - return $ addHeader "Date" (formatHTTPDateTime time) res - Just _ -> return res \ No newline at end of file + 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.format <$> getCurrentTime