X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=ca416b9f4dc24b96cf5f206554c7d4a8bf212100;hb=5477896;hp=d3659cc78905f89082d70824b5e0f621ab316fb9;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index d3659cc..ca416b9 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,26 +1,36 @@ +{-# LANGUAGE + BangPatterns + , OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Postprocess ( postprocess , completeUnconditionalHeaders ) where - -import Control.Concurrent.STM -import Control.Monad +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.Time -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.IO.Unsafe +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 {- @@ -55,23 +65,23 @@ import System.IO.Unsafe -} -postprocess :: Interaction -> STM () -postprocess itr - = itr `seq` - 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 (C8.pack "Allow") res == Nothing) + when (sc ≡ MethodNotAllowed ∧ getHeader "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.") @@ -79,105 +89,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 -> if value `noCaseEq` C8.pack "close" then - writeItr itr itrWillClose True - else - return () + 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 - = name `seq` - readItr itr itrResponse $ getHeader name - - updateRes :: (Response -> Response) -> STM () - updateRes updator - = updator `seq` - 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 - = conf `seq` res `seq` - return res >>= compServer >>= compDate >>= return +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 $ formatHTTPDateTime now - writeIORef cache (now, dateStr) - return dateStr - where - mostlyEq :: UTCTime -> UTCTime -> Bool - mostlyEq a b - = if utctDay a == utctDay b then - fromEnum (utctDayTime a) == fromEnum (utctDayTime b) - else - False + = case getHeader "Date" res' of + Nothing → do date ← getCurrentDate + return $ setHeader "Date" date res' + Just _ → return res' + +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.format <$> getCurrentTime