X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=806ed1c1c9d07529ec3e84e65b367d69d1d881dd;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=062a3bf6203c303195684999a4198cb510338700;hpb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 062a3bf..806ed1c 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Postprocess ( postprocess , completeUnconditionalHeaders @@ -6,18 +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 System.Time +import System.IO.Unsafe {- @@ -53,27 +60,25 @@ import System.Time -} postprocess :: Interaction -> STM () -postprocess itr - = itr `seq` - do reqM <- readItr itr itrRequest 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 (reqM /= Nothing) - $ relyOnRequest itr + when (reqM /= Nothing) relyOnRequest -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 @@ -82,10 +87,9 @@ postprocess itr $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where - relyOnRequest :: Interaction -> STM () - relyOnRequest itr - = itr `seq` - do status <- readItr itr itrResponse resStatus + relyOnRequest :: STM () + relyOnRequest + = do status <- readItr itr itrResponse resStatus req <- readItr itr itrRequest fromJust let reqVer = reqVersion req @@ -97,59 +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 - = itr `seq` name `seq` - readItr itr itrResponse $ getHeader name + readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) + readHeader !name + = readItr itr itrResponse $ getHeader name - updateRes :: Interaction -> (Response -> Response) -> STM () - updateRes itr updator - = itr `seq` updator `seq` - updateItr itr itrResponse updator + updateRes :: (Response -> Response) -> STM () + updateRes !updator + = updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders conf res - = conf `seq` res `seq` - 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))