From 46f1b85674e45e823f5b6c7a1f87b1faf8172b85 Mon Sep 17 00:00:00 2001 From: pho Date: Sat, 19 May 2007 14:32:00 +0900 Subject: [PATCH] getRequestURI should always return an absolute URI darcs-hash:20070519053200-62b54-442a69c9a5c5d1263decaf52ec6656d1b94b77e8.gz --- Network/HTTP/Lucu/DefaultPage.hs | 7 ++- Network/HTTP/Lucu/Interaction.hs | 7 ++- Network/HTTP/Lucu/Postprocess.hs | 9 +-- Network/HTTP/Lucu/Preprocess.hs | 90 +++++++++++++++++++++++------- Network/HTTP/Lucu/RequestReader.hs | 2 +- Network/HTTP/Lucu/Resource.hs | 24 ++++---- Network/HTTP/Lucu/Resource/Tree.hs | 24 ++++---- 7 files changed, 111 insertions(+), 52 deletions(-) diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index a31e754..bb4ba28 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -46,10 +46,11 @@ writeDefaultPage itr = do wroteHeader <- readTVar (itrWroteHeader itr) -- Content-Type が正しくなければ補完できない。 - res <- readTVar (itrResponse itr) + res <- readItr itr itrResponse id when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do let reqM = itrRequest itr - conf = itrConfig itr + $ do reqM <- readItr itr itrRequest id + + let conf = itrConfig itr page = B.pack $ getDefaultPage conf reqM res writeTVar (itrBodyToSend itr) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 6045d97..88cded5 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -30,7 +30,7 @@ data Interaction = Interaction { itrConfig :: Config , itrRemoteHost :: HostName , itrResourcePath :: Maybe [String] - , itrRequest :: Maybe Request + , itrRequest :: TVar (Maybe Request) , itrResponse :: TVar Response -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす @@ -84,7 +84,8 @@ defaultPageContentType = "application/xhtml+xml" newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction newInteraction conf host req - = do responce <- newTVarIO $ Response { + = do request <- newTVarIO $ req + responce <- newTVarIO $ Response { resVersion = HttpVersion 1 1 , resStatus = Ok , resHeaders = [("Content-Type", defaultPageContentType)] @@ -118,7 +119,7 @@ newInteraction conf host req itrConfig = conf , itrRemoteHost = host , itrResourcePath = Nothing - , itrRequest = req + , itrRequest = request , itrResponse = responce , itrRequestHasBody = requestHasBody diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 6f76e88..071ab56 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -56,7 +56,8 @@ import System.Time postprocess :: Interaction -> STM () postprocess itr - = do res <- readItr itr itrResponse id + = do reqM <- readItr itr itrRequest id + res <- readItr itr itrResponse id let sc = resStatus res when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) @@ -72,7 +73,7 @@ postprocess itr $ abortSTM InternalServerError [] $ Just ("The status code was " ++ show sc ++ " but no Location header.") - when (itrRequest itr /= Nothing) + when (reqM /= Nothing) $ relyOnRequest itr -- itrResponse の内容は relyOnRequest によって變へられてゐる可 @@ -85,9 +86,9 @@ postprocess itr relyOnRequest :: Interaction -> STM () relyOnRequest itr = do status <- readItr itr itrResponse resStatus + req <- readItr itr itrRequest fromJust - let req = fromJust $ itrRequest itr - reqVer = reqVersion req + let reqVer = reqVersion req canHaveBody = if reqMethod req == HEAD then False else diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 802338c..c1f1a8b 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -8,16 +8,22 @@ import Control.Concurrent.STM import Control.Monad import Data.Char import Data.Maybe +import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils +import Network import Network.URI {- + * URI にホスト名が存在しない時、 + [1] HTTP/1.0 ならば Config を使って補完 + [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。 + * Expect: に問題があった場合は 417 Expectation Failed に設定。 100-continue 以外のものは全部 417 に。 @@ -25,9 +31,6 @@ import Network.URI 体的には、identity でも chunked でもなければ 501 Not Implemented に する。 - * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い - 場合には 400 Bad Request にする。 - * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501 Not Implemented にする。 @@ -48,41 +51,88 @@ import GHC.Conc (unsafeIOToSTM) preprocess :: Interaction -> STM () preprocess itr - = do let req = fromJust $ itrRequest itr - reqVer = reqVersion req + = do req <- readItr itr itrRequest fromJust + + let reqVer = reqVersion req if reqVer /= HttpVersion 1 0 && reqVer /= HttpVersion 1 1 then - do setStatus itr HttpVersionNotSupported + do setStatus HttpVersionNotSupported writeItr itr itrWillClose True else - do if reqVer == HttpVersion 1 0 then - -- HTTP/1.0 では Keep-Alive できない - writeItr itr itrWillClose True - else - -- URI または Host: ヘッダのどちらかにホストが無ければ - -- ならない。 - when (uriAuthority (reqURI req) == Nothing && - getHeader "Host" req == Nothing) - $ setStatus itr BadRequest + -- HTTP/1.0 では Keep-Alive できない + do when (reqVer == HttpVersion 1 0) + $ writeItr itr itrWillClose True + + -- ホスト部の補完 + completeAuthority req case reqMethod req of GET -> return () HEAD -> writeItr itr itrWillDiscardBody True POST -> writeItr itr itrRequestHasBody True PUT -> writeItr itr itrRequestHasBody True - _ -> setStatus itr NotImplemented + _ -> setStatus NotImplemented mapM_ (preprocessHeader itr) (reqHeaders req) where - setStatus itr status + setStatus :: StatusCode -> STM () + setStatus status = updateItr itr itrResponse $ \ res -> res { resStatus = status } + 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 + } + } + } + + preprocessHeader itr (name, value) = case map toLower name of @@ -90,13 +140,13 @@ preprocess itr -> if value `noCaseEq` "100-continue" then writeItr itr itrExpectedContinue True else - setStatus itr ExpectationFailed + setStatus ExpectationFailed "transfer-encoding" -> case map toLower value of "identity" -> return () "chunked" -> writeItr itr itrRequestIsChunked True - _ -> setStatus itr NotImplemented + _ -> setStatus NotImplemented "content-length" -> if all isDigit value then @@ -104,7 +154,7 @@ preprocess itr writeItr itr itrReqChunkLength $ Just len writeItr itr itrReqChunkRemaining $ Just len else - setStatus itr BadRequest + setStatus BadRequest "connection" -> case map toLower value of diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 1d0f44f..800484c 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -80,7 +80,7 @@ requestReader cnf tree h host tQueue if isErr then acceptSemanticallyInvalidRequest itr input else - case findResource tree $ (reqURI . fromJust . itrRequest) itr of + case findResource tree $ reqURI req of Nothing -- Resource が無かった -> acceptRequestForNonexistentResource itr input diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 1f26ec4..7c1ceb0 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -108,6 +108,7 @@ module Network.HTTP.Lucu.Resource , setHeader , redirect , setContentType + , setLocation -- ** Writing a response body @@ -161,7 +162,8 @@ getConfig = do itr <- ask -- the request header. In general you don't have to use this action. getRequest :: Resource Request getRequest = do itr <- ask - return $ fromJust $ itrRequest itr + req <- liftIO $ atomically $ readItr itr itrRequest fromJust + return req -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. getMethod :: Resource Method @@ -227,8 +229,8 @@ getQueryForm = do reqURI <- getRequestURI -- so frequently: there should be actions like 'getContentType' for -- every common headers. getHeader :: String -> Resource (Maybe String) -getHeader name = do itr <- ask - return $ H.getHeader name $ fromJust $ itrRequest itr +getHeader name = do req <- getRequest + return $ H.getHeader name req -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on -- header \"Accept\". @@ -392,17 +394,13 @@ foundTimeStamp timeStamp -- -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\" -- test and aborts with status \"412 Precondition Failed\" when it --- failed. If this is a GET, HEAD or DELETE request, 'foundNoEntity' --- always aborts with status \"404 Not Found\". It is an error to --- compute 'foundNoEntity' if this is a POST request. +-- failed. If this is a GET, HEAD, POST or DELETE request, +-- 'foundNoEntity' always aborts with status \"404 Not Found\". foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM = do driftTo ExaminingRequest method <- getMethod - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundNoEntity for POST request.") when (method /= PUT) $ abort NotFound [] msgM @@ -645,7 +643,7 @@ redirect code uri $ abort InternalServerError [] $ Just ("Attempted to redirect with status " ++ show code) setStatus code - setHeader "Location" (uriToString id uri $ "") + setLocation uri -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. @@ -653,6 +651,12 @@ setContentType :: MIMEType -> Resource () setContentType mType = setHeader "Content-Type" $ show mType +-- | Computation of @'setLocation' uri@ sets the response header +-- \"Location\" to @uri@. +setLocation :: URI -> Resource () +setLocation uri + = setHeader "Location" $ uriToString id uri $ "" + {- DecidingBody 時に使用するアクション群 -} diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 4ed161f..d468d2b 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -168,7 +168,8 @@ findResource (ResNode rootDefM subtree) uri runResource :: ResourceDef -> Interaction -> IO ThreadId runResource def itr = fork - $ catch ( runReaderT ( do fromMaybe notAllowed rsrc + $ catch ( runReaderT ( do req <- getRequest + fromMaybe notAllowed $ rsrc req driftTo Done ) itr ) @@ -179,15 +180,16 @@ runResource def itr then forkOS else forkIO - rsrc :: Maybe (Resource ()) - rsrc = case reqMethod $ fromJust $ itrRequest itr of - GET -> resGet def - HEAD -> case resHead def of - Just r -> Just r - Nothing -> resGet def - POST -> resPost def - PUT -> resPut def - DELETE -> resDelete def + rsrc :: Request -> Maybe (Resource ()) + rsrc req + = case reqMethod req of + GET -> resGet def + HEAD -> case resHead def of + Just r -> Just r + Nothing -> resGet def + POST -> resPost def + PUT -> resPut def + DELETE -> resDelete def notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed @@ -218,11 +220,11 @@ runResource def itr $ Just $ show exc _ -> Abortion InternalServerError [] $ Just $ show exc conf = itrConfig itr - reqM = itrRequest itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 state <- atomically $ readItr itr itrState id + reqM <- atomically $ readItr itr itrRequest id res <- atomically $ readItr itr itrResponse id if state <= DecidingHeader then flip runReaderT itr -- 2.40.0