X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=989ad164707ca9afb99f94f55dcc69fe2840e658;hp=806ed1c1c9d07529ec3e84e65b367d69d1d881dd;hb=8510a37;hpb=dfc778742934b8f2ac6a6709741c79ecd40c5ff1 diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 806ed1c..989ad16 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns + , OverloadedStrings , UnicodeSyntax #-} module Network.HTTP.Lucu.Postprocess @@ -7,9 +8,12 @@ module Network.HTTP.Lucu.Postprocess , completeUnconditionalHeaders ) where - +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 @@ -24,6 +28,7 @@ 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 {- @@ -59,22 +64,22 @@ import System.IO.Unsafe -} -postprocess :: Interaction -> STM () +postprocess ∷ Interaction → STM () postprocess !itr - = do reqM <- readItr itr itrRequest id - res <- readItr itr itrResponse id + = do reqM ← readItr itr itrRequest id + res ← readItr itr itrResponse id let sc = resStatus res - unless (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 (C8.pack "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 (C8.pack "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.") @@ -82,99 +87,75 @@ postprocess !itr -- 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 :: STM () + relyOnRequest ∷ STM () relyOnRequest - = do status <- readItr itr itrResponse resStatus - req <- readItr itr itrRequest fromJust + = 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 $! deleteHeader (C8.pack "Content-Length") - updateRes $! deleteHeader (C8.pack "Transfer-Encoding") + updateRes $ deleteHeader "Content-Length" + updateRes $ deleteHeader "Transfer-Encoding" - cType <- readHeader (C8.pack "Content-Type") - when (cType == Nothing) - $ updateRes $ setHeader (C8.pack "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 $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") + 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 $! deleteHeader (C8.pack "Content-Type") - updateRes $! deleteHeader (C8.pack "Etag") - updateRes $! deleteHeader (C8.pack "Last-Modified") + $ do updateRes $ deleteHeader "Content-Type" + updateRes $ deleteHeader "Etag" + updateRes $ deleteHeader "Last-Modified" - conn <- readHeader (C8.pack "Connection") + conn ← readHeader "Connection" case conn of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") + 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 $! setHeader (C8.pack "Connection") (C8.pack "close") + $ updateRes $ setHeader "Connection" "close" - when (reqMethod req == HEAD || not canHaveBody) + when (reqMethod req ≡ HEAD ∨ not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True - readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) - readHeader !name - = readItr itr itrResponse $ getHeader name - - updateRes :: (Response -> Response) -> STM () - updateRes !updator - = updateItr itr itrResponse updator + readHeader ∷ CIAscii → STM (Maybe Ascii) + readHeader = readItr itr itrResponse ∘ getHeader + updateRes ∷ (Response → Response) → STM () + updateRes = updateItr itr itrResponse -completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders !conf !res - = compServer res >>= compDate +completeUnconditionalHeaders ∷ Config → Response → IO Response +completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer where compServer res' - = case getHeader (C8.pack "Server") res' of - Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res' - Just _ -> return res' + = case getHeader "Server" res' of + Nothing → return $ setHeader "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)) + = case getHeader "Date" res' of + Nothing → do date ← getCurrentDate + return $ setHeader "Date" date res' + Just _ → return res' + +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.format <$> getCurrentTime