1 module Network.HTTP.Lucu.Preprocess
6 import Control.Concurrent.STM
10 import Network.HTTP.Lucu.Config
11 import Network.HTTP.Lucu.Headers
12 import Network.HTTP.Lucu.HttpVersion
13 import Network.HTTP.Lucu.Interaction
14 import Network.HTTP.Lucu.Request
15 import Network.HTTP.Lucu.Response
16 import Network.HTTP.Lucu.Utils
23 [1] HTTP/1.0 ならば Config を使って補完
24 [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
26 * Expect: に問題があった場合は 417 Expectation Failed に設定。
27 100-continue 以外のものは全部 417 に。
29 * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
30 体的には、identity でも chunked でもなければ 501 Not Implemented に
33 * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
36 * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
37 Version Not Supported を返す。
39 * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
40 411 Length Required にする。
42 * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
45 * willDiscardBody その他の變數を設定する。
49 preprocess :: Interaction -> STM ()
52 do req <- readItr itr itrRequest fromJust
54 let reqVer = reqVersion req
56 if reqVer /= HttpVersion 1 0 &&
57 reqVer /= HttpVersion 1 1 then
59 do setStatus HttpVersionNotSupported
60 writeItr itr itrWillClose True
63 -- HTTP/1.0 では Keep-Alive できない
64 do when (reqVer == HttpVersion 1 0)
65 $ writeItr itr itrWillClose True
72 HEAD -> writeItr itr itrWillDiscardBody True
73 POST -> writeItr itr itrRequestHasBody True
74 PUT -> writeItr itr itrRequestHasBody True
75 _ -> setStatus NotImplemented
77 mapM_ (preprocessHeader itr) (reqHeaders req)
79 setStatus :: StatusCode -> STM ()
82 updateItr itr itrResponse
87 completeAuthority :: Request -> STM ()
90 when (uriAuthority (reqURI req) == Nothing)
91 $ if reqVersion req == HttpVersion 1 0 then
92 -- HTTP/1.0 なので Config から補完
93 do let conf = itrConfig itr
94 host = cnfServerHost conf
95 port = case cnfServerPort conf of
96 PortNumber n -> Just $ fromIntegral n
101 Just n -> Just $ ":" ++ show n
104 Just str -> updateAuthority host str
105 -- FIXME: このエラーの原因は、listen してゐるソ
106 -- ケットが INET でない故にポート番號が分からな
107 -- い事だが、その事をどうにかして通知した方が良
109 Nothing -> setStatus InternalServerError
111 do case getHeader "Host" req of
112 Just str -> let (host, portStr) = parseHost str
113 in updateAuthority host portStr
114 Nothing -> setStatus BadRequest
117 parseHost :: String -> (String, String)
118 parseHost = break (== ':')
121 updateAuthority :: String -> String -> STM ()
122 updateAuthority host portStr
123 = host `seq` portStr `seq`
124 updateItr itr itrRequest
125 $! \ (Just req) -> Just req {
126 reqURI = let uri = reqURI req
128 uriAuthority = Just URIAuth {
137 preprocessHeader :: Interaction -> (String, String) -> STM ()
138 preprocessHeader itr (name, value)
139 = itr `seq` name `seq` value `seq`
140 case map toLower name of
143 -> if value `noCaseEq'` "100-continue" then
144 writeItr itr itrExpectedContinue True
146 setStatus ExpectationFailed
149 -> case map toLower value of
150 "identity" -> return ()
151 "chunked" -> writeItr itr itrRequestIsChunked True
152 _ -> setStatus NotImplemented
155 -> if all isDigit value then
156 do let len = read value
157 writeItr itr itrReqChunkLength $ Just len
158 writeItr itr itrReqChunkRemaining $ Just len
163 -> case map toLower value of
164 "close" -> writeItr itr itrWillClose True