2 module Network.HTTP.Lucu.Postprocess
4 , completeUnconditionalHeaders
8 import Control.Concurrent.STM
12 import GHC.Conc (unsafeIOToSTM)
13 import Network.HTTP.Lucu.Abortion
14 import Network.HTTP.Lucu.Config
15 import Network.HTTP.Lucu.Headers
16 import Network.HTTP.Lucu.HttpVersion
17 import Network.HTTP.Lucu.Interaction
18 import Network.HTTP.Lucu.RFC1123DateTime
19 import Network.HTTP.Lucu.Request
20 import Network.HTTP.Lucu.Response
21 import Network.HTTP.Lucu.Utils
26 * Response が未設定なら、200 OK にする。
28 * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。
30 * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。
32 * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に
35 * Content-Length があれば、それを削除する。Transfer-Encoding があって
38 * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を
41 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。
42 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除
45 * body を持つ事が出來ない時、body 破棄フラグを立てる。
47 * Connection: close が設定されてゐる時、切斷フラグを立てる。
49 * 切斷フラグが立ってゐる時、Connection: close を設定する。
57 postprocess :: Interaction -> STM ()
59 = do 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 (itrRequest itr /= 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 ()
87 = do status <- readItr itr itrResponse resStatus
89 let req = fromJust $ itrRequest itr
90 reqVer = reqVersion req
91 canHaveBody = if reqMethod req == HEAD then
94 not (isInformational status ||
95 status == NoContent ||
96 status == ResetContent ||
97 status == NotModified )
99 updateRes itr $ deleteHeader "Content-Length"
100 updateRes itr $ deleteHeader "Transfer-Encoding"
102 cType <- readHeader itr "Content-Type"
103 when (cType == Nothing)
104 $ updateRes itr $ setHeader "Content-Type" defaultPageContentType
107 when (reqVer == HttpVersion 1 1)
108 $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked"
109 writeItr itr itrWillChunkBody True
111 -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
112 when (reqMethod req /= HEAD)
113 $ do updateRes itr $ deleteHeader "Content-Type"
114 updateRes itr $ deleteHeader "Etag"
115 updateRes itr $ deleteHeader "Last-Modified"
117 conn <- readHeader itr "Connection"
118 case fmap (map toLower) conn of
119 Just "close" -> writeItr itr itrWillClose True
122 willClose <- readItr itr itrWillClose id
124 $ updateRes itr $ setHeader "Connection" "close"
126 when (reqMethod req == HEAD || not canHaveBody)
127 $ writeTVar (itrWillDiscardBody itr) True
129 readHeader :: Interaction -> String -> STM (Maybe String)
131 = readItr itr itrResponse $ getHeader name
133 updateRes :: Interaction -> (Response -> Response) -> STM ()
134 updateRes itr updator
135 = updateItr itr itrResponse updator
138 completeUnconditionalHeaders :: Config -> Response -> IO Response
139 completeUnconditionalHeaders conf res
140 = return res >>= compServer >>= compDate >>= return
143 = case getHeader "Server" res of
144 Nothing -> return $ addHeader "Server" (cnfServerSoftware conf) res
148 = case getHeader "Date" res of
149 Nothing -> do time <- getClockTime
150 return $ addHeader "Date" (formatHTTPDateTime time) res