From 34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b Mon Sep 17 00:00:00 2001 From: pho Date: Sun, 22 Apr 2007 18:17:48 +0900 Subject: [PATCH] "driftTo Done" was trying to change the response header, which is impossible. darcs-hash:20070422091748-62b54-caaca72b979f9876147038603e0188ad1dab9ed5.gz --- Network/HTTP/Lucu/Abortion.hs | 31 ++---- Network/HTTP/Lucu/DefaultPage.hs | 29 ++--- Network/HTTP/Lucu/Interaction.hs | 30 +++-- Network/HTTP/Lucu/Postprocess.hs | 62 +++++------ Network/HTTP/Lucu/Preprocess.hs | 9 +- Network/HTTP/Lucu/RequestReader.hs | 43 +++----- Network/HTTP/Lucu/Resource.hs | 164 ++++++++++++++++------------ Network/HTTP/Lucu/Resource/Tree.hs | 5 +- Network/HTTP/Lucu/ResponseWriter.hs | 2 +- 9 files changed, 183 insertions(+), 192 deletions(-) diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 953fc59..b9e4b11 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,9 +1,9 @@ module Network.HTTP.Lucu.Abortion ( Abortion(..) - , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a - , abortSTM -- StatusCode -> [ (String, String) ] -> Maybe String -> STM a - , abortA -- ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c - , abortPage -- Config -> Maybe Request -> Maybe Response -> Abortion -> String + , abort + , abortSTM + , abortA + , abortPage ) where @@ -54,10 +54,9 @@ abortA -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な --- ければならない。しかもその時は resM から Response を捏造までする必要 --- がある。 -abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String -abortPage conf reqM resM abo +-- ければならない。 +abortPage :: Config -> Maybe Request -> Response -> Abortion -> String +abortPage conf reqM res abo = case aboMessage abo of Just msg -> let [html] = unsafePerformIO @@ -68,15 +67,9 @@ abortPage conf reqM resM abo in html Nothing - -> let res' = case resM of - Just res -> res { resStatus = aboStatus abo } - Nothing -> Response { - resVersion = HttpVersion 1 1 - , resStatus = aboStatus abo - , resHeaders = [] - } - res = foldl (.) id [setHeader name value - | (name, value) <- aboHeaders abo] - $ res' + -> let res' = res { resStatus = aboStatus abo } + res'' = foldl (.) id [setHeader name value + | (name, value) <- aboHeaders abo] + $ res' in - getDefaultPage conf reqM res + getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 988329d..a31e754 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -45,26 +45,15 @@ writeDefaultPage :: Interaction -> STM () writeDefaultPage itr = do wroteHeader <- readTVar (itrWroteHeader itr) - -- ヘッダが出力濟だったら意味が無い。 - when wroteHeader - $ fail "writeDefaultPage: the header has already been written" - - resM <- readTVar (itrResponse itr) - - -- Response が不明ならばページ書込も不可 - when (resM == Nothing) - $ fail "writeDefaultPage: response was Nothing" - - let reqM = itrRequest itr - res = fromJust resM - conf = itrConfig itr - page = B.pack $ getDefaultPage conf reqM res - - writeTVar (itrResponse itr) - $ Just $ setHeader "Content-Type" "application/xhtml+xml" res - - writeTVar (itrBodyToSend itr) - $ page + -- Content-Type が正しくなければ補完できない。 + res <- readTVar (itrResponse itr) + when (getHeader "Content-Type" res == Just defaultPageContentType) + $ do let reqM = itrRequest itr + conf = itrConfig itr + page = B.pack $ getDefaultPage conf reqM res + + writeTVar (itrBodyToSend itr) + $ page mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 0dd9259..6045d97 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -3,14 +3,15 @@ module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue - , newInteractionQueue -- IO InteractionQueue - , newInteraction -- Config -> HostName -> Maybe Request -> IO Interaction - - , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM () - , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b - , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) - , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () - , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () + , newInteractionQueue + , newInteraction + , defaultPageContentType + + , writeItr + , readItr + , readItrF + , updateItr + , updateItrF ) where @@ -21,6 +22,7 @@ import qualified Data.Sequence as S import Data.Sequence (Seq) import Network import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response @@ -29,7 +31,7 @@ data Interaction = Interaction { , itrRemoteHost :: HostName , itrResourcePath :: Maybe [String] , itrRequest :: Maybe Request - , itrResponse :: TVar (Maybe Response) + , itrResponse :: TVar Response -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重 @@ -76,9 +78,17 @@ newInteractionQueue :: IO InteractionQueue newInteractionQueue = newTVarIO S.empty +defaultPageContentType :: String +defaultPageContentType = "application/xhtml+xml" + + newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction newInteraction conf host req - = do responce <- newTVarIO Nothing + = do responce <- newTVarIO $ Response { + resVersion = HttpVersion 1 1 + , resStatus = Ok + , resHeaders = [("Content-Type", defaultPageContentType)] + } requestHasBody <- newTVarIO False requestIsChunked <- newTVarIO False diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 24a07f1..124b66b 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -41,9 +41,9 @@ import System.Time * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server Error にする。但し identity だけは許す。 - * body を持つ事が出來る時、Content-Type が無ければ - application/octet-stream にする。出來ない時、HEAD でなければ - Content-Type, Etag, Last-Modified を削除する。 + * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。 + 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除 + する。 * body を持つ事が出來ない時、body 破棄フラグを立てる。 @@ -59,41 +59,32 @@ import System.Time postprocess :: Interaction -> STM () postprocess itr - = do resM <- readItr itr itrResponse id - - case resM of - Nothing -> writeItr itr itrResponse - $ Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = [] - } - Just res -> do let sc = resStatus res - - when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) - $ abortSTM InternalServerError [] - $ Just ("The status code is not good for a final status: " - ++ show sc) - - when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) - $ abortSTM InternalServerError [] - $ Just ("The status was " ++ show sc ++ " but no Allow header.") - - when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) - $ abortSTM InternalServerError [] - $ Just ("The status code was " ++ show sc ++ " but no Location header.") + = do res <- readItr itr itrResponse id + let sc = resStatus res + + when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) + $ abortSTM InternalServerError [] + $ Just ("The status code is not good for a final status: " + ++ show sc) + + when (sc == MethodNotAllowed && getHeader "Allow" res == Nothing) + $ abortSTM InternalServerError [] + $ Just ("The status was " ++ show sc ++ " but no Allow header.") + + when (sc /= NotModified && isRedirection sc && getHeader "Location" res == Nothing) + $ abortSTM InternalServerError [] + $ Just ("The status code was " ++ show sc ++ " but no Location header.") when (itrRequest itr /= Nothing) $ relyOnRequest itr - do oldRes <- readItr itr itrResponse id - newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) (fromJust oldRes) - writeItr itr itrResponse $ Just newRes + do newRes <- unsafeIOToSTM + $ completeUnconditionalHeaders (itrConfig itr) res + writeItr itr itrResponse newRes where relyOnRequest :: Interaction -> STM () relyOnRequest itr - = do status <- readItr itr itrResponse (resStatus . fromJust) + = do status <- readItr itr itrResponse resStatus let req = fromJust $ itrRequest itr reqVer = reqVersion req @@ -109,7 +100,7 @@ postprocess itr cType <- readHeader itr "Content-Type" when (cType == Nothing) - $ updateRes itr $ setHeader "Content-Type" "application/octet-stream" + $ updateRes itr $ setHeader "Content-Type" defaultPageContentType if canHaveBody then do teM <- readHeader itr "Transfer-Encoding" @@ -157,14 +148,11 @@ postprocess itr readHeader :: Interaction -> String -> STM (Maybe String) readHeader itr name - = do valueMM <- readItrF itr itrResponse $ getHeader name - case valueMM of - Just (Just val) -> return $ Just val - _ -> return Nothing + = readItr itr itrResponse $ getHeader name updateRes :: Interaction -> (Response -> Response) -> STM () updateRes itr updator - = updateItrF itr itrResponse updator + = updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 74d6653..802338c 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -78,11 +78,10 @@ preprocess itr mapM_ (preprocessHeader itr) (reqHeaders req) where setStatus itr status - = writeItr itr itrResponse $ Just (Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - }) + = updateItr itr itrResponse + $ \ res -> res { + resStatus = status + } preprocessHeader itr (name, value) = case map toLower name of diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 08cc2e9..1d0f44f 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -60,12 +60,10 @@ requestReader cnf tree h host tQueue acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status = do itr <- newInteraction cnf host Nothing - let res = Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - } - atomically $ do writeItr itr itrResponse $ Just res + atomically $ do updateItr itr itrResponse + $ \ res -> res { + resStatus = status + } writeItr itr itrWillClose True writeItr itr itrState Done writeDefaultPage itr @@ -78,8 +76,8 @@ requestReader cnf tree h host tQueue action <- atomically $ do preprocess itr - isErr <- readItrF itr itrResponse (isError . resStatus) - if isErr == Just True then + isErr <- readItr itr itrResponse (isError . resStatus) + if isErr then acceptSemanticallyInvalidRequest itr input else case findResource tree $ (reqURI . fromJust . itrRequest) itr of @@ -100,12 +98,10 @@ requestReader cnf tree h host tQueue acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr input - = do let res = Response { - resVersion = HttpVersion 1 1 - , resStatus = NotFound - , resHeaders = [] - } - writeItr itr itrResponse $ Just res + = do updateItr itr itrResponse + $ \res -> res { + resStatus = NotFound + } writeItr itr itrState Done writeDefaultPage itr postprocess itr @@ -225,17 +221,14 @@ requestReader cnf tree h host tQueue chunkWasMalformed :: Interaction -> IO () chunkWasMalformed itr - = let res = Response { - resVersion = HttpVersion 1 1 - , resStatus = BadRequest - , resHeaders = [] - } - in - atomically $ do writeItr itr itrResponse $ Just res - writeItr itr itrWillClose True - writeItr itr itrState Done - writeDefaultPage itr - postprocess itr + = atomically $ do updateItr itr itrResponse + $ \ res -> res { + resStatus = BadRequest + } + writeItr itr itrWillClose True + writeItr itr itrState Done + writeDefaultPage itr + postprocess itr observeNonChunkedRequest :: Interaction -> ByteString -> IO () observeNonChunkedRequest itr input diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d01fd1c..318599f 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,42 +1,90 @@ +-- |This is the Resource Monad; monadic actions to define the behavior +-- of each resources. The 'Resource' Monad is a kind of IO Monad thus +-- it implements MonadIO class. It is also a state machine. +-- +-- Request Processing Flow: +-- +-- 1. A client issues an HTTP request. +-- +-- 2. If the URI of it matches to any resource, the corresponding +-- 'Resource' Monad starts running on a newly spawned thread. +-- +-- 3. The 'Resource' Monad looks at the request header, find (or not +-- find) an entity, receive the request body (if any), decide the +-- response header, and decide the response body. This process +-- will be discussed later. +-- +-- 4. The 'Resource' Monad and its thread stops running. The client +-- may or may not be sending us the next request at this point. +-- +-- 'Resource' Monad is composed of the following states. The initial +-- state is /Examining Request/ and the final state is /Done/. +-- +-- [/Examining Request/] In this state, a 'Resource' looks at the +-- request header and thinks about an entity for it. If there is a +-- suitable entity, the 'Resource' tells the system an entity tag +-- and its last modification time ('foundEntity'). If it found no +-- entity, it tells the system so ('foundNoEntity'). In case it is +-- impossible to decide the existence of entity, which is a typical +-- case for POST requests, 'Resource' does nothing in this state. +-- +-- [/Getting Body/] A 'Resource' asks the system to receive a +-- request body from client. Before actually reading from the +-- socket, the system sends \"100 Continue\" to the client if need +-- be. When a 'Resource' transits to the next state without +-- receiving all or part of request body, the system still reads it +-- and just throws it away. +-- +-- [/Deciding Header/] A 'Resource' makes a decision of status code +-- and response headers. When it transits to the next state, ... +-- +-- [/Deciding Body/] +-- +-- [/Done/] + + +-- 一方通行であること、その理由 + +-- FIXME: 續きを書く + module Network.HTTP.Lucu.Resource ( Resource - , getConfig -- Resource Config - , getRequest -- Resource Request - , getMethod -- Resource Method - , getRequestURI -- Resource URI - , getResourcePath -- Resource [String] - , getPathInfo -- Resource [String] - - , getHeader -- String -> Resource (Maybe String) - , getAccept -- Resource [MIMEType] - , getContentType -- Resource (Maybe MIMEType) - - , foundEntity -- ETag -> ClockTime -> Resource () - , foundETag -- ETag -> Resource () - , foundTimeStamp -- ClockTime -> Resource () - , foundNoEntity -- Maybe String -> Resource () - - , input -- Int -> Resource String - , inputChunk -- Int -> Resource String - , inputBS -- Int -> Resource ByteString - , inputChunkBS -- Int -> Resource ByteString - , inputForm -- Int -> Resource [(String, String)] - , defaultLimit -- Int - - , setStatus -- StatusCode -> Resource () - , setHeader -- String -> String -> Resource () - , redirect -- StatusCode -> URI -> Resource () - , setETag -- ETag -> Resource () - , setLastModified -- ClockTime -> Resource () - , setContentType -- MIMEType -> Resource () - - , output -- String -> Resource () - , outputChunk -- String -> Resource () - , outputBS -- ByteString -> Resource () - , outputChunkBS -- ByteString -> Resource () - - , driftTo -- InteractionState -> Resource () + , getConfig + , getRequest + , getMethod + , getRequestURI + , getResourcePath + , getPathInfo + , getHeader + , getAccept + , getContentType + + , foundEntity + , foundETag + , foundTimeStamp + , foundNoEntity + + , input + , inputChunk + , inputBS + , inputChunkBS + , inputForm + , defaultLimit + + , setStatus + , setHeader + , redirect + , setETag + , setLastModified + , setContentType + + , output + , outputChunk + , outputBS + , outputChunkBS + + , driftTo ) where @@ -400,15 +448,9 @@ setStatus code = do driftTo DecidingHeader itr <- ask liftIO $ atomically $ updateItr itr itrResponse - $ \ resM -> case resM of - Nothing -> Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = code - , resHeaders = [] - } - Just res -> Just $ res { - resStatus = code - } + $ \ res -> res { + resStatus = code + } setHeader :: String -> String -> Resource () @@ -419,14 +461,9 @@ setHeader name value setHeader' :: String -> String -> Resource() setHeader' name value = do itr <- ask - liftIO $ atomically $ updateItr itr itrResponse - $ \ resM -> case resM of - Nothing -> Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = [ (name, value) ] - } - Just res -> Just $ H.setHeader name value res + liftIO $ atomically + $ updateItr itr itrResponse + $ H.setHeader name value redirect :: StatusCode -> URI -> Resource () @@ -525,8 +562,7 @@ outputChunkBS str [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK - だった場合は、補完の代はりに 204 No Content に變へる。 + る。 -} @@ -563,23 +599,7 @@ driftTo newState drift itr _ Done = do bodyIsNull <- readItr itr itrBodyIsNull id when bodyIsNull - $ do status <- readStatus itr - if status == Ok then - do updateItrF itr itrResponse - $ \ res -> res { resStatus = NoContent } - updateItrF itr itrResponse - $ H.deleteHeader "Content-Type" - updateItrF itr itrResponse - $ H.deleteHeader "ETag" - updateItrF itr itrResponse - $ H.deleteHeader "Last-Modified" - else - writeDefaultPage itr - + $ writeDefaultPage itr drift _ _ _ = return () - - - readStatus :: Interaction -> STM StatusCode - readStatus itr = readItr itr itrResponse (resStatus . fromJust) \ No newline at end of file diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 9cd8d0b..be51282 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -173,15 +173,14 @@ runResource def itr -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 state <- atomically $ readItr itr itrState id - resM <- atomically $ readItr itr itrResponse id + res <- atomically $ readItr itr itrResponse id if state <= DecidingHeader then flip runReaderT itr $ do setStatus $ aboStatus abo -- FIXME: 同じ名前で複數の値があった時は、こ -- れではまずいと思ふ。 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setContentType ("application" "xhtml+xml") - output $ abortPage conf reqM resM abo + output $ abortPage conf reqM res abo else hPutStrLn stderr $ show abo diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7130974..6ccc286 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -116,7 +116,7 @@ responseWriter cnf h tQueue readerTID writeHeader itr = do res <- atomically $ do writeItr itr itrWroteHeader True readItr itr itrResponse id - hPutResponse h (fromJust res) + hPutResponse h res hFlush h awaitSomethingToWrite -- 2.40.0