1 module Network.HTTP.Lucu.Preprocess
2 ( preprocess -- Interaction -> STM ()
6 import Control.Concurrent.STM
10 import Network.HTTP.Lucu.Headers
11 import Network.HTTP.Lucu.HttpVersion
12 import Network.HTTP.Lucu.Interaction
13 import Network.HTTP.Lucu.Request
14 import Network.HTTP.Lucu.Response
15 import Network.HTTP.Lucu.Utils
20 * Expect: に問題があった場合は 417 Expectation Failed に設定。
21 100-continue 以外のものは全部 417 に。
23 * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
24 体的には、identity でも chunked でもなければ 501 Not Implemented に
27 * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
28 場合には 400 Bad Request にする。
30 * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
33 * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
34 Version Not Supported を返す。
36 * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
37 411 Length Required にする。
39 * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
42 * willDiscardBody その他の變數を設定する。
46 import GHC.Conc (unsafeIOToSTM)
48 preprocess :: Interaction -> STM ()
50 = do let req = fromJust $ itrRequest itr
51 reqVer = reqVersion req
53 if reqVer /= HttpVersion 1 0 &&
54 reqVer /= HttpVersion 1 1 then
56 do setStatus itr HttpVersionNotSupported
57 writeTVar (itrWillClose itr) True
60 do if reqVer == HttpVersion 1 0 then
61 -- HTTP/1.0 では Keep-Alive できない
62 writeTVar (itrWillClose itr) True
64 -- URI または Host: ヘッダのどちらかにホストが無ければ
66 when (uriAuthority (reqURI req) == Nothing &&
67 getHeader req "Host" == Nothing)
68 $ setStatus itr BadRequest
72 HEAD -> writeTVar (itrWillDiscardBody itr) True
73 POST -> ensureHavingBody itr
74 PUT -> ensureHavingBody itr
75 _ -> setStatus itr NotImplemented
77 mapM_ (preprocessHeader itr) (reqHeaders req)
80 = let req = fromJust $ itrRequest itr
82 if getHeader req "Content-Length" == Nothing &&
83 getHeader req "Transfer-Encoding" == Nothing then
85 setStatus itr LengthRequired
87 writeTVar (itrRequestHasBody itr) True
90 = writeTVar (itrResponse itr) (Just $ Response {
91 resVersion = HttpVersion 1 1
96 preprocessHeader itr (name, value)
97 = case map toLower name of
100 -> if value `noCaseEq` "100-continue" then
101 writeTVar (itrExpectedContinue itr) True
103 setStatus itr ExpectationFailed
106 -> case map toLower value of
107 "identity" -> return ()
108 "chunked" -> writeTVar (itrRequestIsChunked itr) True
109 _ -> setStatus itr NotImplemented
112 -> if all isDigit value then
113 writeTVar (itrRequestBodyLength itr) (Just $ read value)
115 setStatus itr BadRequest
118 -> case map toLower value of
119 "close" -> writeTVar (itrWillClose itr) True