- mapM_ (preprocessHeader itr) (reqHeaders req)
- where
- 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
- _ -> Nothing
- portStr
- = case port of
- Just 80 -> Just ""
- Just n -> Just $ ":" ++ show n
- Nothing -> Nothing
- case portStr of
- Just str -> updateAuthority host str
- -- FIXME: このエラーの原因は、listen してゐるソ
- -- ケットが INET でない故にポート番號が分からな
- -- い事だが、その事をどうにかして通知した方が良
- -- いと思ふ。stderr?
- Nothing -> setStatus InternalServerError
- else
- do case getHeader "Host" req of
- Just str -> let (host, portStr) = parseHost str
- in updateAuthority host portStr
- Nothing -> setStatus BadRequest
-
-
- parseHost :: String -> (String, String)
- parseHost = break (== ':')
-
-
- updateAuthority :: String -> String -> 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 = host
- , uriPort = portStr
- }
- }
- }
-
-
- preprocessHeader :: Interaction -> (String, String) -> STM ()
- preprocessHeader itr (name, value)
- = itr `seq` name `seq` value `seq`
- case map toLower name of
-
- "expect"
- -> if value `noCaseEq'` "100-continue" then
- writeItr itr itrExpectedContinue True
- else
- setStatus ExpectationFailed
-
- "transfer-encoding"
- -> case map toLower value of
- "identity" -> return ()
- "chunked" -> writeItr itr itrRequestIsChunked True
- _ -> setStatus NotImplemented
-
- "content-length"
- -> if all isDigit value then
- do let len = read value
- writeItr itr itrReqChunkLength $ Just len
- writeItr itr itrReqChunkRemaining $ Just len
- else
- setStatus BadRequest
-
- "connection"
- -> case map toLower value of
- "close" -> writeItr itr itrWillClose True
- _ -> return ()
-
- _ -> return ()
\ No newline at end of file
+ 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
+
+parseHost ∷ Ascii → (Text, Ascii)
+parseHost = C8.break (≡ ':')
+
+updateAuthority ∷ Text → Ascii → STM ()
+updateAuthority host portStr
+ = do Just req ← readTVar itrRequest
+ let uri = reqURI req
+ uri' = uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = T.unpack host
+ , uriPort = A.toString portStr
+ }
+ }
+ req' = req { reqURI = uri' }
+ writeTVar itrRequest $ Just req'
+
+preprocessHeader ∷ Interaction → Request → STM ()
+preprocessHeader (Interaction {..}) req
+ = do case getCIHeader "Expect" req of
+ Nothing → return ()
+ Just value → if value ≡ "100-continue" then
+ writeTVar itrExpectedContinue True
+ else
+ setStatus ExpectationFailed
+
+ case getCIHeader "Transfer-Encoding" req of
+ Nothing → return ()
+ Just value → unless (value ≡ "identity")
+ $ if value ≡ "chunked" then
+ writeTVar itrRequestIsChunked True
+ else
+ setStatus NotImplemented
+
+ case getHeader "Content-Length" req of
+ Nothing → return ()
+ Just value → if C8.all isDigit value then
+ do let Just (len, _) = C8.readInt value
+ writeTVar itrReqChunkLength $ Just len
+ writeTVar itrReqChunkRemaining $ Just len
+ else
+ setStatus BadRequest
+
+ case getCIHeader "Connection" req of
+ Nothing → return ()
+ Just value → when (value ≡ "close")
+ $ writeTVar itrWillClose True