2 module Network.HTTP.Lucu.Preprocess
7 import Control.Concurrent.STM
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
21 * Expect: に問題があった場合は 417 Expectation Failed に設定。
22 100-continue 以外のものは全部 417 に。
24 * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
25 体的には、identity でも chunked でもなければ 501 Not Implemented に
28 * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
29 場合には 400 Bad Request にする。
31 * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
34 * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
35 Version Not Supported を返す。
37 * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
38 411 Length Required にする。
40 * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
43 * willDiscardBody その他の變數を設定する。
47 import GHC.Conc (unsafeIOToSTM)
49 preprocess :: Interaction -> STM ()
51 = do let req = fromJust $ itrRequest itr
52 reqVer = reqVersion req
54 if reqVer /= HttpVersion 1 0 &&
55 reqVer /= HttpVersion 1 1 then
57 do setStatus itr HttpVersionNotSupported
58 writeItr itr itrWillClose True
61 do if reqVer == HttpVersion 1 0 then
62 -- HTTP/1.0 では Keep-Alive できない
63 writeItr itr itrWillClose True
65 -- URI または Host: ヘッダのどちらかにホストが無ければ
67 when (uriAuthority (reqURI req) == Nothing &&
68 getHeader "Host" req == Nothing)
69 $ setStatus itr BadRequest
73 HEAD -> writeItr itr itrWillDiscardBody True
74 POST -> writeItr itr itrRequestHasBody True
75 PUT -> writeItr itr itrRequestHasBody True
76 _ -> setStatus itr NotImplemented
78 mapM_ (preprocessHeader itr) (reqHeaders req)
81 = updateItr itr itrResponse
86 preprocessHeader itr (name, value)
87 = case map toLower name of
90 -> if value `noCaseEq` "100-continue" then
91 writeItr itr itrExpectedContinue True
93 setStatus itr ExpectationFailed
96 -> case map toLower value of
97 "identity" -> return ()
98 "chunked" -> writeItr itr itrRequestIsChunked True
99 _ -> setStatus itr NotImplemented
102 -> if all isDigit value then
103 do let len = read value
104 writeItr itr itrReqChunkLength $ Just len
105 writeItr itr itrReqChunkRemaining $ Just len
107 setStatus itr BadRequest
110 -> case map toLower value of
111 "close" -> writeItr itr itrWillClose True