7 module Network.HTTP.Lucu.Preprocess
11 import Control.Applicative
12 import Control.Concurrent.STM
14 import Data.Ascii (Ascii)
15 import qualified Data.Ascii as A
16 import Data.ByteString (ByteString)
17 import qualified Data.ByteString.Char8 as C8
20 import Data.Text (Text)
21 import qualified Data.Text as T
22 import Network.HTTP.Lucu.Config
23 import Network.HTTP.Lucu.Headers
24 import Network.HTTP.Lucu.HttpVersion
25 import Network.HTTP.Lucu.Interaction
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Response
29 import Prelude.Unicode
32 TODO: Tanslate this memo into English. It doesn't make sense to
33 non-Japanese speakers.
36 [1] HTTP/1.0 ならば Config を使って補完
37 [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
39 * Expect: に問題があった場合は 417 Expectation Failed に設定。
40 100-continue 以外のものは全部 417 に。
42 * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
43 体的には、identity でも chunked でもなければ 501 Not Implemented に
46 * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
49 * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
50 Version Not Supported を返す。
52 * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
53 411 Length Required にする。
55 * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
58 * willDiscardBody その他の變數を設定する。
61 preprocess ∷ Interaction → STM ()
62 preprocess itr@(Interaction {..})
63 = do req ← fromJust <$> readTVar itrRequest
65 let reqVer = reqVersion req
67 if reqVer ≢ HttpVersion 1 0 ∧
68 reqVer ≢ HttpVersion 1 1 then
70 do setStatus itr HttpVersionNotSupported
71 writeTVar itrWillClose True
74 -- HTTP/1.0 では Keep-Alive できない
75 do when (reqVer ≡ HttpVersion 1 0)
76 $ writeTVar itrWillClose True
79 completeAuthority itr req
83 HEAD → writeTVar itrWillDiscardBody True
84 POST → writeTVar itrRequestHasBody True
85 PUT → writeTVar itrRequestHasBody True
87 _ → setStatus itr NotImplemented
89 preprocessHeader itr req
91 setStatus ∷ Interaction → StatusCode → STM ()
92 setStatus (Interaction {..}) sc
93 = do res ← readTVar itrResponse
97 writeTVar itrResponse res'
99 completeAuthority ∷ Interaction → Request → STM ()
100 completeAuthority itr@(Interaction {..}) req
101 = when (isNothing $ uriAuthority $ reqURI req)
102 $ if reqVersion req == HttpVersion 1 0 then
103 -- HTTP/1.0 なので Config から補完
104 do let host = cnfServerHost itrConfig
105 portStr = case itrLocalPort of
108 updateAuthority host $ A.unsafeFromString portStr
110 case getHeader "Host" req of
111 Just str → let (host, portStr) = parseHost str
113 updateAuthority host portStr
114 Nothing → setStatus itr BadRequest
116 parseHost ∷ Ascii → (Text, Ascii)
117 parseHost = C8.break (≡ ':')
119 updateAuthority ∷ Text → Ascii → STM ()
120 updateAuthority host portStr
121 = do Just req ← readTVar itrRequest
124 uriAuthority = Just URIAuth {
126 , uriRegName = T.unpack host
127 , uriPort = A.toString portStr
130 req' = req { reqURI = uri' }
131 writeTVar itrRequest $ Just req'
133 preprocessHeader ∷ Interaction → Request → STM ()
134 preprocessHeader (Interaction {..}) req
135 = do case getCIHeader "Expect" req of
137 Just value → if value ≡ "100-continue" then
138 writeTVar itrExpectedContinue True
140 setStatus ExpectationFailed
142 case getCIHeader "Transfer-Encoding" req of
144 Just value → unless (value ≡ "identity")
145 $ if value ≡ "chunked" then
146 writeTVar itrRequestIsChunked True
148 setStatus NotImplemented
150 case getHeader "Content-Length" req of
152 Just value → if C8.all isDigit value then
153 do let Just (len, _) = C8.readInt value
154 writeTVar itrReqChunkLength $ Just len
155 writeTVar itrReqChunkRemaining $ Just len
159 case getCIHeader "Connection" req of
161 Just value → when (value ≡ "close")
162 $ writeTVar itrWillClose True