2 module Network.HTTP.Lucu.Preprocess
7 import Control.Concurrent.STM
11 import Network.HTTP.Lucu.Config
12 import Network.HTTP.Lucu.Headers
13 import Network.HTTP.Lucu.HttpVersion
14 import Network.HTTP.Lucu.Interaction
15 import Network.HTTP.Lucu.Request
16 import Network.HTTP.Lucu.Response
17 import Network.HTTP.Lucu.Utils
24 [1] HTTP/1.0 ならば Config を使って補完
25 [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
27 * Expect: に問題があった場合は 417 Expectation Failed に設定。
28 100-continue 以外のものは全部 417 に。
30 * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
31 体的には、identity でも chunked でもなければ 501 Not Implemented に
34 * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
37 * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
38 Version Not Supported を返す。
40 * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
41 411 Length Required にする。
43 * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
46 * willDiscardBody その他の變數を設定する。
50 import GHC.Conc (unsafeIOToSTM)
52 preprocess :: Interaction -> STM ()
55 do req <- readItr itr itrRequest fromJust
57 let reqVer = reqVersion req
59 if reqVer /= HttpVersion 1 0 &&
60 reqVer /= HttpVersion 1 1 then
62 do setStatus HttpVersionNotSupported
63 writeItr itr itrWillClose True
66 -- HTTP/1.0 では Keep-Alive できない
67 do when (reqVer == HttpVersion 1 0)
68 $ writeItr itr itrWillClose True
75 HEAD -> writeItr itr itrWillDiscardBody True
76 POST -> writeItr itr itrRequestHasBody True
77 PUT -> writeItr itr itrRequestHasBody True
78 _ -> setStatus NotImplemented
80 mapM_ (preprocessHeader itr) (reqHeaders req)
82 setStatus :: StatusCode -> STM ()
85 updateItr itr itrResponse
90 completeAuthority :: Request -> STM ()
93 when (uriAuthority (reqURI req) == Nothing)
94 $ if reqVersion req == HttpVersion 1 0 then
95 -- HTTP/1.0 なので Config から補完
96 do let conf = itrConfig itr
97 host = cnfServerHost conf
98 port = case cnfServerPort conf of
99 PortNumber n -> Just $ fromIntegral n
104 Just n -> Just $ ":" ++ show n
107 Just str -> updateAuthority host str
108 -- FIXME: このエラーの原因は、listen してゐるソ
109 -- ケットが INET でない故にポート番號が分からな
110 -- い事だが、その事をどうにかして通知した方が良
112 Nothing -> setStatus InternalServerError
114 do case getHeader "Host" req of
115 Just str -> let (host, portStr) = parseHost str
116 in updateAuthority host portStr
117 Nothing -> setStatus BadRequest
120 parseHost :: String -> (String, String)
121 parseHost = break (== ':')
124 updateAuthority :: String -> String -> STM ()
125 updateAuthority host portStr
126 = host `seq` portStr `seq`
127 updateItr itr itrRequest
128 $! \ (Just req) -> Just req {
129 reqURI = let uri = reqURI req
131 uriAuthority = Just URIAuth {
140 preprocessHeader :: Interaction -> (String, String) -> STM ()
141 preprocessHeader itr (name, value)
142 = itr `seq` name `seq` value `seq`
143 case map toLower name of
146 -> if value `noCaseEq'` "100-continue" then
147 writeItr itr itrExpectedContinue True
149 setStatus ExpectationFailed
152 -> case map toLower value of
153 "identity" -> return ()
154 "chunked" -> writeItr itr itrRequestIsChunked True
155 _ -> setStatus NotImplemented
158 -> if all isDigit value then
159 do let len = read value
160 writeItr itr itrReqChunkLength $ Just len
161 writeItr itr itrReqChunkRemaining $ Just len
166 -> case map toLower value of
167 "close" -> writeItr itr itrWillClose True