Lucu-0.1: Network/HTTP/Lucu/Postprocess.hs
module Network.HTTP.Lucu.Postprocess
( postprocess
, completeUnconditionalHeaders
)
where
import Control.Concurrent.STM
import Control.Monad
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
{-
* Response が未設定なら、200 OK にする。
* ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
* 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
* 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
する。
* Content-Length があれば、それを削除する。Transfer-Encoding があって
も削除する。
* HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
chunked に設定する。
* body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
する。
* body を持つ事が出來ない時、body 破棄フラグを立てる。
* Connection: close が設定されてゐる時、切斷フラグを立てる。
* 切斷フラグが立ってゐる時、Connection: close を設定する。
* Server が無ければ設定。
* Date が無ければ設定。
-}
postprocess :: Interaction -> STM ()
postprocess itr
= itr `seq`
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)
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) oldRes
writeItr itr itrResponse newRes
where
relyOnRequest :: STM ()
relyOnRequest
= do status <- readItr itr itrResponse resStatus
req <- readItr itr itrRequest fromJust
let reqVer = reqVersion req
canHaveBody = if reqMethod req == HEAD then
False
else
not (isInformational status ||
status == NoContent ||
status == ResetContent ||
status == NotModified )
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
when (reqVer == HttpVersion 1 1)
$ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "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")
conn <- readHeader (C8.pack "Connection")
case conn of
Nothing -> return ()
Just value -> if value `noCaseEq` C8.pack "close" then
writeItr itr itrWillClose True
else
return ()
willClose <- readItr itr itrWillClose id
when willClose
$ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
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
completeUnconditionalHeaders :: Config -> Response -> IO Response
completeUnconditionalHeaders conf res
= conf `seq` res `seq`
return res >>= compServer >>= compDate >>= return
where
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 $ 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