1 module Network.HTTP.Lucu.Preprocess
6 import Control.Concurrent.STM
8 import Data.ByteString.Base (ByteString)
9 import qualified Data.ByteString.Char8 as C8
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
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 preprocess :: Interaction -> STM ()
53 do req <- readItr itr itrRequest fromJust
55 let reqVer = reqVersion req
57 if reqVer /= HttpVersion 1 0 &&
58 reqVer /= HttpVersion 1 1 then
60 do setStatus HttpVersionNotSupported
61 writeItr itr itrWillClose True
64 -- HTTP/1.0 では Keep-Alive できない
65 do when (reqVer == HttpVersion 1 0)
66 $ writeItr itr itrWillClose True
73 HEAD -> writeItr itr itrWillDiscardBody True
74 POST -> writeItr itr itrRequestHasBody True
75 PUT -> writeItr itr itrRequestHasBody True
76 _ -> setStatus NotImplemented
78 preprocessHeader itr req
80 setStatus :: StatusCode -> STM ()
83 updateItr itr itrResponse
88 completeAuthority :: Request -> STM ()
91 when (uriAuthority (reqURI req) == Nothing)
92 $ if reqVersion req == HttpVersion 1 0 then
93 -- HTTP/1.0 なので Config から補完
94 do let conf = itrConfig itr
95 host = cnfServerHost conf
96 port = case cnfServerPort conf of
97 PortNumber n -> Just $ fromIntegral n
102 Just n -> Just $ ":" ++ show n
105 Just str -> updateAuthority host (C8.pack str)
106 -- FIXME: このエラーの原因は、listen してゐるソ
107 -- ケットが INET でない故にポート番號が分からな
108 -- い事だが、その事をどうにかして通知した方が良
110 Nothing -> setStatus InternalServerError
112 do case getHeader (C8.pack "Host") req of
113 Just str -> let (host, portStr) = parseHost str
114 in updateAuthority host portStr
115 Nothing -> setStatus BadRequest
118 parseHost :: ByteString -> (ByteString, ByteString)
119 parseHost = C8.break (== ':')
122 updateAuthority :: ByteString -> ByteString -> STM ()
123 updateAuthority host portStr
124 = host `seq` portStr `seq`
125 updateItr itr itrRequest
126 $! \ (Just req) -> Just req {
127 reqURI = let uri = reqURI req
129 uriAuthority = Just URIAuth {
131 , uriRegName = C8.unpack host
132 , uriPort = C8.unpack portStr
138 preprocessHeader :: Interaction -> Request -> STM ()
139 preprocessHeader itr req
140 = itr `seq` req `seq`
141 do case getHeader (C8.pack "Expect") req of
143 Just value -> if value `noCaseEq` C8.pack "100-continue" then
144 writeItr itr itrExpectedContinue True
146 setStatus ExpectationFailed
148 case getHeader (C8.pack "Transfer-Encoding") req of
150 Just value -> if value `noCaseEq` C8.pack "identity" then
153 if value `noCaseEq` C8.pack "chunked" then
154 writeItr itr itrRequestIsChunked True
156 setStatus NotImplemented
158 case getHeader (C8.pack "Content-Length") req of
160 Just value -> if C8.all isDigit value then
161 do let Just (len, _) = C8.readInt value
162 writeItr itr itrReqChunkLength $ Just len
163 writeItr itr itrReqChunkRemaining $ Just len
167 case getHeader (C8.pack "Connection") req of
169 Just value -> if value `noCaseEq` C8.pack "close" then
170 writeItr itr itrWillClose True