X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=318599f40c7347bc54ac2c13a64d5de92f9516a0;hb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;hp=d01fd1c8d3ee27d7f7591b89ceaad28c0cb6430f;hpb=30fcb38426696db8b80d322196cc594431e30407;p=Lucu.git 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