+ completeAuthority :: Request -> STM ()
+ completeAuthority req
+ = 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
+ = updateItr itr itrRequest
+ $ \ (Just req) -> Just req {
+ reqURI = let uri = reqURI req
+ in uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = host
+ , uriPort = portStr
+ }
+ }
+ }
+
+