1 module Network.HTTP.Lucu.Postprocess
3 , completeUnconditionalHeaders
7 import Control.Concurrent.STM
9 import Data.ByteString.Base (ByteString)
10 import qualified Data.ByteString.Char8 as C8
13 import GHC.Conc (unsafeIOToSTM)
14 import Network.HTTP.Lucu.Abortion
15 import Network.HTTP.Lucu.Config
16 import Network.HTTP.Lucu.Headers
17 import Network.HTTP.Lucu.HttpVersion
18 import Network.HTTP.Lucu.Interaction
19 import Network.HTTP.Lucu.RFC1123DateTime
20 import Network.HTTP.Lucu.Request
21 import Network.HTTP.Lucu.Response
23 import System.IO.Unsafe
27 * Response が未設定なら、200 OK にする。
29 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
31 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
33 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
36 * Content-Length があれば、それを削除する。Transfer-Encoding があって
39 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
42 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
43 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
46 * body を持つ事が出來ない時、body 破棄フラグを立てる。
48 * Connection: close が設定されてゐる時、切斷フラグを立てる。
50 * 切斷フラグが立ってゐる時、Connection: close を設定する。
58 postprocess :: Interaction -> STM ()
61 do reqM <- readItr itr itrRequest id
62 res <- readItr itr itrResponse id
63 let sc = resStatus res
65 when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
66 $ abortSTM InternalServerError []
67 $ Just ("The status code is not good for a final status: "
70 when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
71 $ abortSTM InternalServerError []
72 $ Just ("The status was " ++ show sc ++ " but no Allow header.")
74 when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
75 $ abortSTM InternalServerError []
76 $ Just ("The status code was " ++ show sc ++ " but no Location header.")
78 when (reqM /= Nothing)
81 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
83 do oldRes <- readItr itr itrResponse id
84 newRes <- unsafeIOToSTM
85 $ completeUnconditionalHeaders (itrConfig itr) oldRes
86 writeItr itr itrResponse newRes
88 relyOnRequest :: Interaction -> STM ()
91 do status <- readItr itr itrResponse resStatus
92 req <- readItr itr itrRequest fromJust
94 let reqVer = reqVersion req
95 canHaveBody = if reqMethod req == HEAD then
98 not (isInformational status ||
99 status == NoContent ||
100 status == ResetContent ||
101 status == NotModified )
103 updateRes itr $! deleteHeader (C8.pack "Content-Length")
104 updateRes itr $! deleteHeader (C8.pack "Transfer-Encoding")
106 cType <- readHeader itr (C8.pack "Content-Type")
107 when (cType == Nothing)
108 $ updateRes itr $ setHeader (C8.pack "Content-Type") defaultPageContentType
111 when (reqVer == HttpVersion 1 1)
112 $ do updateRes itr $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
113 writeItr itr itrWillChunkBody True
115 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
116 when (reqMethod req /= HEAD)
117 $ do updateRes itr $! deleteHeader (C8.pack "Content-Type")
118 updateRes itr $! deleteHeader (C8.pack "Etag")
119 updateRes itr $! deleteHeader (C8.pack "Last-Modified")
121 conn <- readHeader itr (C8.pack "Connection")
124 Just value -> if value `noCaseEq` C8.pack "close" then
125 writeItr itr itrWillClose True
129 willClose <- readItr itr itrWillClose id
131 $ updateRes itr $! setHeader (C8.pack "Connection") (C8.pack "close")
133 when (reqMethod req == HEAD || not canHaveBody)
134 $ writeTVar (itrWillDiscardBody itr) True
136 readHeader :: Interaction -> ByteString -> STM (Maybe ByteString)
138 = itr `seq` name `seq`
139 readItr itr itrResponse $ getHeader name
141 updateRes :: Interaction -> (Response -> Response) -> STM ()
142 updateRes itr updator
143 = itr `seq` updator `seq`
144 updateItr itr itrResponse updator
147 completeUnconditionalHeaders :: Config -> Response -> IO Response
148 completeUnconditionalHeaders conf res
149 = conf `seq` res `seq`
150 return res >>= compServer >>= compDate >>= return
153 = case getHeader (C8.pack "Server") res of
154 Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res
158 = case getHeader (C8.pack "Date") res of
159 Nothing -> do date <- getCurrentDate
160 return $ setHeader (C8.pack "Date") date res
164 cache :: IORef (ClockTime, ByteString)
165 cache = unsafePerformIO $
166 newIORef (TOD 0 0, undefined)
167 {-# NOINLINE cache #-}
169 getCurrentDate :: IO ByteString
170 getCurrentDate = do now@(TOD curSec _) <- getClockTime
171 (TOD cachedSec _, cachedStr) <- readIORef cache
173 if curSec == cachedSec then
176 do let dateStr = C8.pack $ formatHTTPDateTime now
177 writeIORef cache (now, dateStr)