- setStatus :: StatusCode -> STM ()
- setStatus status
- = status `seq`
- updateItr itr itrResponse
- $! \ res -> res {
- resStatus = status
- }
-
- completeAuthority :: Request -> STM ()
- completeAuthority req
- = req `seq`
- when (uriAuthority (reqURI req) == Nothing)
- $ if reqVersion req == HttpVersion 1 0 then
- -- HTTP/1.0 なので Config から補完
- do let conf = itrConfig itr
- host = cnfServerHost conf
- port = case cnfServerPort conf of
- PortNumber n -> Just (fromIntegral n :: Int)
- _ -> Nothing
- portStr
- = case port of
- Just 80 -> Just ""
- Just n -> Just $ ":" ++ show n
- Nothing -> Nothing
- case portStr of
- Just str -> updateAuthority host (C8.pack str)
- -- FIXME: このエラーの原因は、listen してゐるソ
- -- ケットが INET でない故にポート番號が分からな
- -- い事だが、その事をどうにかして通知した方が良
- -- いと思ふ。stderr?
- Nothing -> setStatus InternalServerError
- else
- do case getHeader (C8.pack "Host") req of
- Just str -> let (host, portStr) = parseHost str
- in updateAuthority host portStr
- Nothing -> setStatus BadRequest
-
-
- parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
- parseHost = C8.break (== ':')
-
-
- updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
- updateAuthority host portStr
- = host `seq` portStr `seq`
- updateItr itr itrRequest
- $! \ (Just req) -> Just req {
- reqURI = let uri = reqURI req
- in uri {
- uriAuthority = Just URIAuth {
- uriUserInfo = ""
- , uriRegName = C8.unpack host
- , uriPort = C8.unpack portStr
- }
- }
- }
-
-
- preprocessHeader :: Request -> STM ()
- preprocessHeader req
- = req `seq`
- do case getHeader (C8.pack "Expect") req of
- Nothing -> return ()
- Just value -> if value `noCaseEq` C8.pack "100-continue" then
- writeItr itr itrExpectedContinue True
- else
- setStatus ExpectationFailed
-
- case getHeader (C8.pack "Transfer-Encoding") req of
- Nothing -> return ()
- Just value -> if value `noCaseEq` C8.pack "identity" then
- return ()
- else
- if value `noCaseEq` C8.pack "chunked" then
- writeItr itr itrRequestIsChunked True
- else
- setStatus NotImplemented
-
- case getHeader (C8.pack "Content-Length") req of
- Nothing -> return ()
- Just value -> if C8.all isDigit value then
- do let Just (len, _) = C8.readInt value
- writeItr itr itrReqChunkLength $ Just len
- writeItr itr itrReqChunkRemaining $ Just len
- else
- setStatus BadRequest
-
- case getHeader (C8.pack "Connection") req of
- Nothing -> return ()
- Just value -> if value `noCaseEq` C8.pack "close" then
- writeItr itr itrWillClose True
- else
- return ()
+ 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)
+
+parseHost ∷ Ascii → (Text, Ascii)
+parseHost hp
+ = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
+ -- FIXME: should decode punycode here.
+ hText = T.decodeUtf8 h
+ pAscii = A.unsafeFromByteString p
+ in
+ (hText, pAscii)
+
+updateAuthority ∷ Text → Ascii → Request → Request
+updateAuthority host port req
+ = let uri = reqURI req
+ uri' = uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = T.unpack host
+ , uriPort = A.toString port
+ }
+ }
+ in
+ req { reqURI = uri' }
+
+examineHeaders ∷ State AugmentedRequest ()
+examineHeaders
+ = do req ← gets (fromJust ∘ arRequest)
+
+ case getCIHeader "Expect" req of
+ Nothing → return ()
+ Just v
+ | v ≡ "100-continue"
+ → modify $ \ar → ar { arExpectedContinue = Just True }
+ | otherwise
+ → setStatus ExpectationFailed
+
+ case getCIHeader "Transfer-Encoding" req of
+ Nothing → return ()
+ Just v
+ | v ≡ "identity"
+ → return ()
+ | v ≡ "chunked"
+ → setBodyLength $ Just Chunked
+ | otherwise
+ → setStatus NotImplemented
+
+ case A.toByteString <$> getHeader "Content-Length" req of
+ Nothing → return ()
+ Just value → case C8.readInt value of
+ Just (len, garbage)
+ | C8.null garbage ∧ len ≥ 0
+ → setBodyLength $ Just $ Fixed len
+ _ → setStatus BadRequest
+
+ case getCIHeader "Connection" req of
+ Just v
+ | v ≡ "close"
+ → setWillClose True
+ _ → return ()
+
+examineBodyLength ∷ State AugmentedRequest ()
+examineBodyLength
+ = do req ← gets (fromJust ∘ arRequest)
+ len ← gets arReqBodyLength
+ if reqHasBody req then
+ -- POST and PUT requests must have an entity body.
+ when (isNothing len)
+ $ setStatus LengthRequired
+ else
+ -- Other requests must NOT have an entity body.
+ when (isJust len)
+ $ setStatus BadRequest