X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=806ed1c1c9d07529ec3e84e65b367d69d1d881dd;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=6f76e88811734508c1da16337712f7b7760577f3;hpb=86ea98d8307ddc687696896a91bed9a05cbeb783;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 6f76e88..806ed1c 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,4 +1,7 @@ --- #hide +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Postprocess ( postprocess , completeUnconditionalHeaders @@ -7,19 +10,21 @@ module Network.HTTP.Lucu.Postprocess import Control.Concurrent.STM import Control.Monad -import Data.Char +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Char8 as C8 hiding (ByteString) +import Data.IORef import Data.Maybe +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.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils -import System.Time +import System.IO.Unsafe {- @@ -55,25 +60,25 @@ import System.Time -} postprocess :: Interaction -> STM () -postprocess itr - = do res <- readItr itr itrResponse id +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]) + unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError]) $ abortSTM InternalServerError [] $ Just ("The status code is not good for a final status: " ++ show sc) - when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) + when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing) $ abortSTM InternalServerError [] $ Just ("The status was " ++ show sc ++ " but no Allow header.") - when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) + when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing) $ abortSTM InternalServerError [] $ Just ("The status code was " ++ show sc ++ " but no Location header.") - when (itrRequest itr /= Nothing) - $ relyOnRequest itr + when (reqM /= Nothing) relyOnRequest -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 @@ -82,12 +87,12 @@ postprocess itr $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where - relyOnRequest :: Interaction -> STM () - relyOnRequest itr + relyOnRequest :: STM () + relyOnRequest = do status <- readItr itr itrResponse resStatus + req <- readItr itr itrRequest fromJust - let req = fromJust $ itrRequest itr - reqVer = reqVersion req + let reqVer = reqVersion req canHaveBody = if reqMethod req == HEAD then False else @@ -96,56 +101,80 @@ postprocess itr status == ResetContent || status == NotModified ) - updateRes itr $ deleteHeader "Content-Length" - updateRes itr $ deleteHeader "Transfer-Encoding" + updateRes $! deleteHeader (C8.pack "Content-Length") + updateRes $! deleteHeader (C8.pack "Transfer-Encoding") - cType <- readHeader itr "Content-Type" + cType <- readHeader (C8.pack "Content-Type") when (cType == Nothing) - $ updateRes itr $ setHeader "Content-Type" defaultPageContentType + $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType if canHaveBody then when (reqVer == HttpVersion 1 1) - $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked" + $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "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 (C8.pack "Content-Type") + updateRes $! deleteHeader (C8.pack "Etag") + updateRes $! deleteHeader (C8.pack "Last-Modified") - conn <- readHeader itr "Connection" - case fmap (map toLower) conn of - Just "close" -> writeItr itr itrWillClose True - _ -> return () + conn <- readHeader (C8.pack "Connection") + case conn of + Nothing -> return () + Just value -> when (value `noCaseEq` C8.pack "close") + $ writeItr itr itrWillClose True willClose <- readItr itr itrWillClose id when willClose - $ updateRes itr $ setHeader "Connection" "close" + $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close") when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True - readHeader :: Interaction -> String -> STM (Maybe String) - readHeader itr name + readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) + readHeader !name = readItr itr itrResponse $ getHeader name - updateRes :: Interaction -> (Response -> Response) -> STM () - updateRes itr updator + updateRes :: (Response -> Response) -> STM () + updateRes !updator = updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders conf res - = return res >>= compServer >>= compDate >>= return +completeUnconditionalHeaders !conf !res + = compServer res >>= compDate 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 (C8.pack "Server") res' of + Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res' + Just _ -> return res' + + compDate res' + = case getHeader (C8.pack "Date") res' of + Nothing -> do date <- getCurrentDate + return $ setHeader (C8.pack "Date") date res' + Just _ -> return res' + + +cache :: IORef (UTCTime, Strict.ByteString) +cache = unsafePerformIO $ + newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined) +{-# NOINLINE cache #-} + +getCurrentDate :: IO Strict.ByteString +getCurrentDate = do now <- getCurrentTime + (cachedTime, cachedStr) <- readIORef cache + + if now `mostlyEq` cachedTime then + return cachedStr + else + do let dateStr = C8.pack $ HTTP.format now + writeIORef cache (now, dateStr) + return dateStr + where + mostlyEq :: UTCTime -> UTCTime -> Bool + mostlyEq a b + = (utctDay a == utctDay b) + && + (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))