1 module Network.HTTP.Lucu.Preprocess
6 import Control.Concurrent.STM
8 import qualified Data.ByteString as Strict (ByteString)
9 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
12 import Network.HTTP.Lucu.Config
13 import Network.HTTP.Lucu.Headers
14 import Network.HTTP.Lucu.HttpVersion
15 import Network.HTTP.Lucu.Interaction
16 import Network.HTTP.Lucu.Request
17 import Network.HTTP.Lucu.Response
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
76 _ -> setStatus NotImplemented
80 setStatus :: StatusCode -> STM ()
82 = updateItr itr itrResponse
87 completeAuthority :: Request -> STM ()
88 completeAuthority !req
89 = when (uriAuthority (reqURI req) == Nothing)
90 $ if reqVersion req == HttpVersion 1 0 then
91 -- HTTP/1.0 なので Config から補完
92 do let conf = itrConfig itr
93 host = cnfServerHost conf
94 port = itrLocalPort itr
99 updateAuthority host (C8.pack portStr)
101 case getHeader (C8.pack "Host") req of
102 Just str -> let (host, portStr) = parseHost str
103 in updateAuthority host portStr
104 Nothing -> setStatus BadRequest
107 parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
108 parseHost = C8.break (== ':')
111 updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
112 updateAuthority host portStr
113 = host `seq` portStr `seq`
114 updateItr itr itrRequest
115 $! \ (Just req) -> Just req {
116 reqURI = let uri = reqURI req
118 uriAuthority = Just URIAuth {
120 , uriRegName = C8.unpack host
121 , uriPort = C8.unpack portStr
127 preprocessHeader :: Request -> STM ()
130 do case getHeader (C8.pack "Expect") req of
132 Just value -> if value `noCaseEq` C8.pack "100-continue" then
133 writeItr itr itrExpectedContinue True
135 setStatus ExpectationFailed
137 case getHeader (C8.pack "Transfer-Encoding") req of
139 Just value -> unless (value `noCaseEq` C8.pack "identity")
140 $ if value `noCaseEq` C8.pack "chunked" then
141 writeItr itr itrRequestIsChunked True
143 setStatus NotImplemented
145 case getHeader (C8.pack "Content-Length") req of
147 Just value -> if C8.all isDigit value then
148 do let Just (len, _) = C8.readInt value
149 writeItr itr itrReqChunkLength $ Just len
150 writeItr itr itrReqChunkRemaining $ Just len
154 case getHeader (C8.pack "Connection") req of
156 Just value -> when (value `noCaseEq` C8.pack "close")
157 $ writeItr itr itrWillClose True