-{-
- TODO: Tanslate this memo into English. It doesn't make sense to
- non-Japanese speakers.
-
- * URI にホスト名が存在しない時、
- [1] HTTP/1.0 ならば Config を使って補完
- [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。
-
- * Expect: に問題があった場合は 417 Expectation Failed に設定。
- 100-continue 以外のものは全部 417 に。
-
- * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
- 体的には、identity でも chunked でもなければ 501 Not Implemented に
- する。
-
- * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
- Not Implemented にする。
-
- * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
- Version Not Supported を返す。
-
- * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
- 411 Length Required にする。
-
- * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
- Request にする。
-
- * willDiscardBody その他の變數を設定する。
--}
-
-preprocess ∷ Interaction → STM ()
-preprocess itr@(Interaction {..})
- = do req ← fromJust <$> readTVar itrRequest
-
- let reqVer = reqVersion req
-
- if reqVer ≢ HttpVersion 1 0 ∧
- reqVer ≢ HttpVersion 1 1 then
-
- do setStatus itr HttpVersionNotSupported
- writeTVar itrWillClose True
-
- else
- -- HTTP/1.0 では Keep-Alive できない
- do when (reqVer ≡ HttpVersion 1 0)
- $ writeTVar itrWillClose True
-
- -- ホスト部の補完
- completeAuthority itr req
-
- case reqMethod req of
- GET → return ()
- HEAD → writeTVar itrWillDiscardBody True
- POST → writeTVar itrRequestHasBody True
- PUT → writeTVar itrRequestHasBody True
- DELETE → return ()
- _ → setStatus itr NotImplemented
-
- preprocessHeader itr req
-
-setStatus ∷ Interaction → StatusCode → STM ()
-setStatus (Interaction {..}) sc
- = do res ← readTVar itrResponse
- let res' = res {
- resStatus = sc
- }
- writeTVar itrResponse res'
-
-completeAuthority ∷ Interaction → Request → STM ()
-completeAuthority itr@(Interaction {..}) req
- = when (isNothing $ uriAuthority $ reqURI req)
- $ if reqVersion req == HttpVersion 1 0 then
- -- HTTP/1.0 なので Config から補完
- do let host = cnfServerHost itrConfig
- portStr = case itrLocalPort of
- 80 → ""
- n → ':' : show n
- updateAuthority host $ A.unsafeFromString portStr
- else
- case getHeader "Host" req of
- Just str → let (host, portStr) = parseHost str
- in
- updateAuthority host portStr
- Nothing → setStatus itr BadRequest
+data AugmentedRequest
+ = AugmentedRequest {
+ arRequest ∷ !(Maybe Request)
+ , arInitialStatus ∷ !StatusCode
+ , arWillClose ∷ !Bool
+ , arWillDiscardBody ∷ !Bool
+ , arExpectedContinue ∷ !(Maybe Bool)
+ , arReqBodyLength ∷ !(Maybe RequestBodyLength)
+ }
+
+data RequestBodyLength
+ = Fixed !Int
+ | Chunked
+
+preprocess ∷ Text
+ → PortNumber
+ → Either StatusCode Request
+ → AugmentedRequest
+preprocess localHost localPort request
+ = case request of
+ Right req
+ → preprocess' localHost localPort req
+ Left sc
+ → unparsable sc
+
+unparsable ∷ StatusCode → AugmentedRequest
+unparsable sc
+ = AugmentedRequest {
+ arRequest = Nothing
+ , arInitialStatus = sc
+ , arWillClose = True
+ , arWillDiscardBody = False
+ , arExpectedContinue = Nothing
+ , arReqBodyLength = Nothing
+ }
+
+preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess' localHost localPort req@(Request {..})
+ = execState go initialAR
+ where
+ initialAR ∷ AugmentedRequest
+ initialAR = AugmentedRequest {
+ arRequest = Just req
+ , arInitialStatus = Ok
+ , arWillClose = False
+ , arWillDiscardBody = False
+ , arExpectedContinue = Just False
+ , arReqBodyLength = Nothing
+ }
+
+ go ∷ State AugmentedRequest ()
+ go = do examineHttpVersion
+ examineMethod
+ examineAuthority localHost localPort
+ examineHeaders
+ examineBodyLength
+
+setRequest ∷ Request → State AugmentedRequest ()
+setRequest req
+ = modify $ \ar → ar { arRequest = Just req }
+
+setStatus ∷ StatusCode → State AugmentedRequest ()
+setStatus sc
+ = modify $ \ar → ar { arInitialStatus = sc }
+
+setWillClose ∷ Bool → State AugmentedRequest ()
+setWillClose b
+ = modify $ \ar → ar { arWillClose = b }
+
+setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength len
+ = modify $ \ar → ar { arReqBodyLength = len }
+
+examineHttpVersion ∷ State AugmentedRequest ()
+examineHttpVersion
+ = do req ← gets (fromJust ∘ arRequest)
+ case reqVersion req of
+ -- HTTP/1.0 requests can't Keep-Alive.
+ HttpVersion 1 0
+ → setWillClose True
+ HttpVersion 1 1
+ → return ()
+ _ → do setStatus HttpVersionNotSupported
+ setWillClose True
+
+examineMethod ∷ State AugmentedRequest ()
+examineMethod
+ = do req ← gets (fromJust ∘ arRequest)
+ case reqMethod req of
+ GET → return ()
+ HEAD → modify $ \ar → ar { arWillDiscardBody = True }
+ POST → return ()
+ PUT → return ()
+ DELETE → return ()
+ _ → setStatus NotImplemented
+
+examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
+examineAuthority localHost localPort
+ = do req ← gets (fromJust ∘ arRequest)
+ when (isNothing $ uriAuthority $ reqURI req) $
+ case reqVersion req of
+ -- HTTP/1.0 requests have no Host header so complete it
+ -- with the configuration value.
+ HttpVersion 1 0
+ → let host = localHost
+ port = case localPort of
+ 80 → ""
+ n → A.unsafeFromString $ ':':show n
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ -- HTTP/1.1 requests MUST have a Host header.
+ HttpVersion 1 1
+ → case getHeader "Host" req of
+ Just str
+ → let (host, port)
+ = parseHost str
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ Nothing
+ → setStatus BadRequest
+ -- Should never reach here...
+ ver → fail ("internal error: unknown version: " ⧺ show ver)