X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=806ed1c1c9d07529ec3e84e65b367d69d1d881dd;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=7d7e147f93be84797d739ca976991a4954ea5929;hpb=e624f0db8c4610b36da9e4463a656e0cb8a104dd;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 7d7e147..806ed1c 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,24 +1,30 @@ +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Postprocess - ( postprocess -- Interaction -> STM () - , completeUnconditionalHeaders -- Config -> Response -> IO Response + ( postprocess + , completeUnconditionalHeaders ) where 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 {- @@ -31,18 +37,15 @@ import System.Time * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に する。 - * Content-Length があれば、それを削除する。 + * Content-Length があれば、それを削除する。Transfer-Encoding があって + も削除する。 - * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の - 最後の要素が chunked でなければ 500 Internal Error にする。 - Transfer-Encoding が未設定であれば、chunked に設定する。 + * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を + chunked に設定する。 - * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server - Error にする。但し identity だけは許す。 - - * body を持つ事が出來る時、Content-Type が無ければ - application/octet-stream にする。出來ない時、HEAD でなければ - Content-Type, Etag, Last-Modified を削除する。 + * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。 + 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除 + する。 * body を持つ事が出來ない時、body 破棄フラグを立てる。 @@ -57,45 +60,39 @@ import System.Time -} postprocess :: Interaction -> STM () -postprocess itr - = do resM <- readItr itr itrResponse id - - case resM of - Nothing -> writeItr itr itrResponse - $ Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = [] - } - Just res -> do let sc = resStatus res - - when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) - $ abortSTM InternalServerError [] - ("The status code is not good for a final status: " - ++ show sc) - - when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) - $ abortSTM InternalServerError [] - ("The status was " ++ show sc ++ " but no Allow header.") - - when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) - $ abortSTM InternalServerError [] - ("The status code was " ++ show sc ++ " but no Location header.") - - when (itrRequest itr /= Nothing) - $ relyOnRequest itr +postprocess !itr + = do reqM <- readItr itr itrRequest id + res <- readItr itr itrResponse id + let sc = resStatus res + + 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 (C8.pack "Allow") res == Nothing) + $ abortSTM InternalServerError [] + $ Just ("The status was " ++ show sc ++ " but no Allow header.") + 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 + + -- itrResponse の内容は relyOnRequest によって變へられてゐる可 + -- 能性が高い。 do oldRes <- readItr itr itrResponse id newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes) - writeItr itr itrResponse $ Just newRes + $ completeUnconditionalHeaders (itrConfig itr) oldRes + writeItr itr itrResponse newRes where - relyOnRequest :: Interaction -> STM () - relyOnRequest itr - = do status <- readItr itr itrResponse (resStatus . fromJust) + 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 @@ -104,79 +101,80 @@ postprocess itr status == ResetContent || status == NotModified ) - updateRes itr $ deleteHeader "Content-Length" + updateRes $! deleteHeader (C8.pack "Content-Length") + updateRes $! deleteHeader (C8.pack "Transfer-Encoding") + + cType <- readHeader (C8.pack "Content-Type") + when (cType == Nothing) + $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType if canHaveBody then - do teM <- readHeader itr "Transfer-Encoding" - if reqVer == HttpVersion 1 1 then - - do case teM of - Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked" - Just te -> let teList = [trim isWhiteSpace x - | x <- splitBy (== ',') (map toLower te)] - in - when (teList == [] || last teList /= "chunked") - $ abortSTM InternalServerError [] - ("Transfer-Encoding must end with `chunked' " - ++ "because this is an HTTP/1.1 request: " - ++ te) - - writeItr itr itrWillChunkBody True - else - case fmap (map toLower) teM of - Nothing -> return () - Just "identity" -> return () - Just te -> abortSTM InternalServerError [] - ("Transfer-Encoding must be `identity' because " - ++ "this is an HTTP/1.0 request: " - ++ te) - - cType <- readHeader itr "Content-Type" - when (cType == Nothing) - $ updateRes itr $ setHeader "Content-Type" "application/octet-stream" + when (reqVer == HttpVersion 1 1) + $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") + writeItr itr itrWillChunkBody True else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - do updateRes itr $ deleteHeader "Transfer-Encoding" - when (reqMethod req /= HEAD) - $ do updateRes itr $ deleteHeader "Content-Type" - updateRes itr $ deleteHeader "Etag" - updateRes itr $ deleteHeader "Last-Modified" + when (reqMethod req /= HEAD) + $ 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 - = do valueMM <- readItrF itr itrResponse $ getHeader name - case valueMM of - Just (Just val) -> return $ Just val - _ -> return Nothing + readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) + readHeader !name + = readItr itr itrResponse $ getHeader name - updateRes :: Interaction -> (Response -> Response) -> STM () - updateRes itr updator - = updateItrF itr itrResponse 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))