1 module Network.HTTP.Lucu.Postprocess
3 , completeUnconditionalHeaders
7 import Control.Concurrent.STM
11 import GHC.Conc (unsafeIOToSTM)
12 import Network.HTTP.Lucu.Abortion
13 import Network.HTTP.Lucu.Config
14 import Network.HTTP.Lucu.Headers
15 import Network.HTTP.Lucu.HttpVersion
16 import Network.HTTP.Lucu.Interaction
17 import Network.HTTP.Lucu.RFC1123DateTime
18 import Network.HTTP.Lucu.Request
19 import Network.HTTP.Lucu.Response
24 * Response が未設定なら、200 OK にする。
26 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
28 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
30 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
33 * Content-Length があれば、それを削除する。Transfer-Encoding があって
36 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
39 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
40 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
43 * body を持つ事が出來ない時、body 破棄フラグを立てる。
45 * Connection: close が設定されてゐる時、切斷フラグを立てる。
47 * 切斷フラグが立ってゐる時、Connection: close を設定する。
55 postprocess :: Interaction -> STM ()
58 do reqM <- readItr itr itrRequest id
59 res <- readItr itr itrResponse id
60 let sc = resStatus res
62 when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
63 $ abortSTM InternalServerError []
64 $ Just ("The status code is not good for a final status: "
67 when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing)
68 $ abortSTM InternalServerError []
69 $ Just ("The status was " ++ show sc ++ " but no Allow header.")
71 when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing)
72 $ abortSTM InternalServerError []
73 $ Just ("The status code was " ++ show sc ++ " but no Location header.")
75 when (reqM /= Nothing)
78 -- itrResponse の内容は relyOnRequest によって變へられてゐる可
80 do oldRes <- readItr itr itrResponse id
81 newRes <- unsafeIOToSTM
82 $ completeUnconditionalHeaders (itrConfig itr) oldRes
83 writeItr itr itrResponse newRes
85 relyOnRequest :: Interaction -> STM ()
88 do status <- readItr itr itrResponse resStatus
89 req <- readItr itr itrRequest fromJust
91 let reqVer = reqVersion req
92 canHaveBody = if reqMethod req == HEAD then
95 not (isInformational status ||
96 status == NoContent ||
97 status == ResetContent ||
98 status == NotModified )
100 updateRes itr $! deleteHeader "Content-Length"
101 updateRes itr $! deleteHeader "Transfer-Encoding"
103 cType <- readHeader itr "Content-Type"
104 when (cType == Nothing)
105 $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
108 when (reqVer == HttpVersion 1 1)
109 $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked"
110 writeItr itr itrWillChunkBody True
112 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
113 when (reqMethod req /= HEAD)
114 $ do updateRes itr $! deleteHeader "Content-Type"
115 updateRes itr $! deleteHeader "Etag"
116 updateRes itr $! deleteHeader "Last-Modified"
118 conn <- readHeader itr "Connection"
119 case fmap (map toLower) conn of
120 Just "close" -> writeItr itr itrWillClose True
123 willClose <- readItr itr itrWillClose id
125 $ updateRes itr $! setHeader "Connection" "close"
127 when (reqMethod req == HEAD || not canHaveBody)
128 $ writeTVar (itrWillDiscardBody itr) True
130 readHeader :: Interaction -> String -> STM (Maybe String)
132 = itr `seq` name `seq`
133 readItr itr itrResponse $ getHeader name
135 updateRes :: Interaction -> (Response -> Response) -> STM ()
136 updateRes itr updator
137 = itr `seq` updator `seq`
138 updateItr itr itrResponse updator
141 completeUnconditionalHeaders :: Config -> Response -> IO Response
142 completeUnconditionalHeaders conf res
143 = conf `seq` res `seq`
144 return res >>= compServer >>= compDate >>= return
147 = case getHeader "Server" res of
148 Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
152 = case getHeader "Date" res of
153 Nothing -> do time <- getClockTime
154 return $ addHeader "Date" (formatHTTPDateTime time) res