X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=7c1ceb0f027ee03d7aacbdb565cb81b16944a237;hb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;hp=7b1b26a0dd08ea9423f3f895395d0e6a45c2c145;hpb=854f6d1709d468f7e1bf0db2dcd2d30de6bd5f5e;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 7b1b26a..7c1ceb0 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,41 +1,125 @@ +-- #prune + +-- |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 takes 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 header. When it transits to the next state, the +-- system checks the validness of response header and then write +-- them to the socket. +-- +-- [/Deciding Body/] In this state, a 'Resource' asks the system to +-- write some response body to the socket. When it transits to the +-- next state without writing any response body, the system +-- completes it depending on the status code. +-- +-- [/Done/] Everything is over. A 'Resource' can do nothing for the +-- HTTP interaction anymore. +-- +-- Note that the state transition is one-way: for instance, it is an +-- error to try to read a request body after writing some +-- response. This limitation is for efficiency. We don't want to read +-- the entire request before starting 'Resource', nor we don't want to +-- postpone writing the entire response till the end of 'Resource' +-- computation. + 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 - , 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 () + ( + -- * Monad + Resource + + -- * Actions + + -- ** Getting request header + + -- |These actions can be computed regardless of the current state, + -- and they don't change the state. + , getConfig + , getRequest + , getMethod + , getRequestURI + , getResourcePath + , getPathInfo + , getQueryForm + , getHeader + , getAccept + , getContentType + + -- ** Finding an entity + + -- |These actions can be computed only in the /Examining Request/ + -- state. After the computation, the 'Resource' transits to + -- /Getting Body/ state. + , foundEntity + , foundETag + , foundTimeStamp + , foundNoEntity + + -- ** Getting a request body + + -- |Computation of these actions changes the state to /Getting + -- Body/. + , input + , inputChunk + , inputBS + , inputChunkBS + , inputForm + , defaultLimit + + -- ** Setting response headers + + -- |Computation of these actions changes the state to /Deciding + -- Header/. + , setStatus + , setHeader + , redirect + , setContentType + , setLocation + + -- ** Writing a response body + + -- |Computation of these actions changes the state to /Deciding + -- Body/. + , output + , outputChunk + , outputBS + , outputChunkBS + + , driftTo ) where @@ -63,35 +147,64 @@ import Network.HTTP.Lucu.Utils import Network.URI import System.Time - +-- |The 'Resource' monad. /Interaction/ is an internal state thus it +-- is not exposed to users. This monad implements 'MonadIO' so it can +-- do any IO actions. type Resource a = ReaderT Interaction IO a - +-- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for +-- the httpd. getConfig :: Resource Config getConfig = do itr <- ask return $ itrConfig itr - +-- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents +-- 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 getMethod = do req <- getRequest return $ reqMethod req - +-- |Get the URI of the request. getRequestURI :: Resource URI getRequestURI = do req <- getRequest return $ reqURI req - +-- |Get the path of this 'Resource' (to be exact, +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this +-- action is the exact path in the tree even if the +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. +-- +-- Example: +-- +-- > main = let tree = mkResTree [ (["foo"], resFoo) ] +-- > in runHttpd defaultConfig tree +-- > +-- > resFoo = ResourceDef { +-- > resIsGreedy = True +-- > , resGet = Just $ do requestURI <- getRequestURI +-- > resourcePath <- getResourcePath +-- > pathInfo <- getPathInfo +-- > -- uriPath requestURI == "/foo/bar/baz" +-- > -- resourcePath == ["foo"] +-- > -- pathInfo == ["bar", "baz"] +-- > ... +-- > , ... +-- > } getResourcePath :: Resource [String] getResourcePath = do itr <- ask return $ fromJust $ itrResourcePath itr +-- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if +-- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not +-- greedy. See 'getResourcePath'. getPathInfo :: Resource [String] getPathInfo = do rsrcPath <- getResourcePath reqURI <- getRequestURI @@ -104,12 +217,23 @@ getPathInfo = do rsrcPath <- getResourcePath -- rsrcPath の長さの分だけ削除すれば良い。 return $ drop (length rsrcPath) reqPath - +-- | Assume the query part of request URI as +-- application\/x-www-form-urlencoded, and parse it. This action +-- doesn't parse the request body. See 'inputForm'. +getQueryForm :: Resource [(String, String)] +getQueryForm = do reqURI <- getRequestURI + return $ parseWWWFormURLEncoded $ uriQuery reqURI + +-- |Get a value of given request header. Comparison of header name is +-- case-insensitive. Note that this action is not intended to be used +-- 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\". getAccept :: Resource [MIMEType] getAccept = do accept <- getHeader "Accept" if accept == Nothing then @@ -119,7 +243,8 @@ getAccept = do accept <- getHeader "Accept" (Success xs, _) -> return xs _ -> return [] - +-- |Get the header \"Content-Type\" as +-- 'Network.HTTP.Lucu.MIMEType.MIMEType'. getContentType :: Resource (Maybe MIMEType) getContentType = do cType <- getHeader "Content-Type" if cType == Nothing then @@ -133,6 +258,20 @@ getContentType = do cType <- getHeader "Content-Type" {- ExaminingRequest 時に使用するアクション群 -} +-- |Tell the system that the 'Resource' found an entity for the +-- request URI. If this is a GET or HEAD request, a found entity means +-- a datum to be replied. If this is a PUT or DELETE request, it means +-- a datum which was stored for the URI up to now. It is an error to +-- compute 'foundEntity' if this is a POST request. +-- +-- Computation of 'foundEntity' performs \"If-Match\" test or +-- \"If-None-Match\" test if possible. When those tests fail, the +-- computation of 'Resource' immediately aborts with status \"412 +-- Precondition Failed\" or \"304 Not Modified\" depending on the +-- situation. +-- +-- If this is a GET or HEAD request, 'foundEntity' automatically puts +-- \"ETag\" and \"Last-Modified\" headers into the response. foundEntity :: ETag -> ClockTime -> Resource () foundEntity tag timeStamp = do driftTo ExaminingRequest @@ -140,11 +279,20 @@ foundEntity tag timeStamp method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + when (method == POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundEntity for POST request.") foundETag tag driftTo GettingBody - +-- |Tell the system that the 'Resource' found an entity for the +-- request URI. The only difference from 'foundEntity' is that +-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into +-- the response. +-- +-- This action is not preferred. You should use 'foundEntity' when +-- possible. foundETag :: ETag -> Resource () foundETag tag = do driftTo ExaminingRequest @@ -152,6 +300,9 @@ foundETag tag method <- getMethod when (method == GET || method == HEAD) $ setHeader' "ETag" $ show tag + when (method == POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundETag for POST request.") -- If-Match があればそれを見る。 ifMatch <- getHeader "If-Match" @@ -185,7 +336,16 @@ foundETag tag driftTo GettingBody - +-- |Tell the system that the 'Resource' found an entity for the +-- request URI. The only difference from 'foundEntity' is that +-- 'foundTimeStamp' performs \"If-Modified-Since\" test or +-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or +-- \"If-None-Match\" test. Be aware that any tests based on last +-- modification time are unsafe because it is possible to mess up such +-- tests by modifying the entity twice in a second. +-- +-- This action is not preferred. You should use 'foundEntity' when +-- possible. foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp = do driftTo ExaminingRequest @@ -193,6 +353,9 @@ foundTimeStamp timeStamp method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + when (method == POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundTimeStamp for POST request.") let statusForIfModSince = if method == GET || method == HEAD then NotModified @@ -225,14 +388,21 @@ foundTimeStamp timeStamp driftTo GettingBody - +-- | Computation of @'foundNoEntity' mStr@ tells the system that the +-- 'Resource' found no entity for the request URI. @mStr@ is an +-- optional error message to be replied to the client. +-- +-- 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, 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 /= PUT) - $ abort NotFound [] msgM + $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 @@ -245,12 +415,29 @@ foundNoEntity msgM {- GettingBody 時に使用するアクション群 -} +-- | Computation of @'input' limit@ attempts to read the request body +-- up to @limit@ bytes, and then make the 'Resource' transit to +-- /Deciding Header/ state. When the actual size of body is larger +-- than @limit@ bytes, computation of 'Resource' immediately aborts +-- with status \"413 Request Entity Too Large\". When the request has +-- no body, 'input' returns an empty string. +-- +-- @limit@ may be less than or equal to zero. In this case, the +-- default limitation value +-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See +-- 'defaultLimit'. +-- +-- Note that 'inputBS' is more efficient than 'input' so you should +-- use it whenever possible. input :: Int -> Resource String input limit = inputBS limit >>= return . B.unpack --- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が --- 零以下なら Config で設定されたデフォルトのボディ長により制限される。 +-- | This is mostly the same as 'input' but is more +-- efficient. 'inputBS' returns a lazy ByteString but it's not really +-- lazy: reading from the socket just happens at the computation of +-- 'inputBS', not at the lazy evaluation of the ByteString. The same +-- goes for 'inputChunkBS'. inputBS :: Int -> Resource ByteString inputBS limit = do driftTo GettingBody @@ -308,14 +495,25 @@ inputBS limit $ Just ("Request body must be smaller than " ++ show lim ++ " bytes.") - +-- | Computation of @'inputChunk' limit@ attempts to read a part of +-- request body up to @limit@ bytes. You can read any large request by +-- repeating computation of this action. When you've read all the +-- request body, 'inputChunk' returns an empty string and then make +-- the 'Resource' transit to /Deciding Header/ state. +-- +-- @limit@ may be less than or equal to zero. In this case, the +-- default limitation value +-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See +-- 'defaultLimit'. +-- +-- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you +-- should use it whenever possible. inputChunk :: Int -> Resource String inputChunk limit = inputChunkBS limit >>= return . B.unpack --- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit --- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され --- る。これ以上ボディが殘ってゐなければ空文字列を返す。 +-- | This is mostly the same as 'inputChunk' but is more +-- efficient. See 'inputBS'. inputChunkBS :: Int -> Resource ByteString inputChunkBS limit = do driftTo GettingBody @@ -357,7 +555,41 @@ inputChunkBS limit $ driftTo DecidingHeader return chunk +-- | Computation of @'inputForm' limit@ attempts to read the request +-- body with 'input' and parse it as +-- application\/x-www-form-urlencoded. If the request header +-- \"Content-Type\" is not application\/x-www-form-urlencoded, +-- 'inputForm' makes 'Resource' abort with status \"415 Unsupported +-- Media Type\". If the request has no \"Content-Type\", it aborts +-- with \"400 Bad Request\". +-- +-- This action should also support multipart\/form-data somehow, but +-- it is not (yet) done. +inputForm :: Int -> Resource [(String, String)] +inputForm limit + = do cTypeM <- getContentType + case cTypeM of + Nothing + -> abort BadRequest [] (Just "Missing Content-Type") + Just (MIMEType "application" "x-www-form-urlencoded" _) + -> readWWWFormURLEncoded + Just (MIMEType "multipart" "form-data" _) + -> readMultipartFormData + Just cType + -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " + ++ show cType) + where + readWWWFormURLEncoded + = do src <- input limit + return $ parseWWWFormURLEncoded src + + readMultipartFormData -- FIXME: 未對應 + = abort UnsupportedMediaType [] + (Just $ "Sorry, inputForm does not currently support multipart/form-data.") +-- | This is just a constant -1. It's better to say @'input' +-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly +-- the same. defaultLimit :: Int defaultLimit = (-1) @@ -365,22 +597,31 @@ defaultLimit = (-1) {- DecidingHeader 時に使用するアクション群 -} +-- | Set the response status code. If you omit to compute this action, +-- the status code will be defaulted to \"200 OK\". setStatus :: StatusCode -> Resource () 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 + } + +-- | Set a value of given resource header. Comparison of header name +-- is case-insensitive. Note that this action is not intended to be +-- used so frequently: there should be actions like 'setContentType' +-- for every common headers. +-- +-- Some important headers (especially \"Content-Length\" and +-- \"Transfer-Encoding\") may be silently dropped or overwritten by +-- the system not to corrupt the interaction with client at the +-- viewpoint of HTTP protocol layer. For instance, if we are keeping +-- the connection alive, without this process it causes a catastrophe +-- to send a header \"Content-Length: 10\" and actually send a body of +-- 20 bytes long. In this case the client shall only accept the first +-- 10 bytes of response body and thinks that the residual 10 bytes is +-- a part of header of the next response. setHeader :: String -> String -> Resource () setHeader name value = driftTo DecidingHeader >> setHeader' name value @@ -389,61 +630,62 @@ 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 +-- | Computation of @'redirect' code uri@ sets the response status to +-- @code@ and \"Location\" header to @uri@. @code@ must satisfy +-- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. redirect :: StatusCode -> URI -> Resource () redirect code uri = do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] $ Just ("Attempted to redirect with status " ++ show code) setStatus code - setHeader "Location" (uriToString id uri $ "") - - -setETag :: ETag -> Resource () -setETag tag - = setHeader "ETag" $ show tag - - -setLastModified :: ClockTime -> Resource () -setLastModified lastmod - = setHeader "Last-Modified" $ formatHTTPDateTime lastmod - + setLocation uri +-- | Computation of @'setContentType' mType@ sets the response header +-- \"Content-Type\" to @mType@. 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 時に使用するアクション群 -} +-- | Computation of @'output' str@ writes @str@ as a response body, +-- and then make the 'Resource' transit to /Done/ state. It is safe to +-- apply 'output' to an infinite string, such as a lazy stream of +-- \/dev\/random. +-- +-- Note that 'outputBS' is more efficient than 'output' so you should +-- use it whenever possible. output :: String -> Resource () output = outputBS . B.pack - +-- | This is mostly the same as 'output' but is more efficient. outputBS :: ByteString -> Resource () outputBS str = do outputChunkBS str driftTo Done - +-- | Computation of @'outputChunk' str@ writes @str@ as a part of +-- response body. You can compute this action multiple times to write +-- a body little at a time. It is safe to apply 'outputChunk' to an +-- infinite string. +-- +-- Note that 'outputChunkBS' is more efficient than 'outputChunk' so +-- you should use it whenever possible. outputChunk :: String -> Resource () outputChunk = outputChunkBS . B.pack - -{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を - B.readFile して作った ByteString をそのまま ResponseWriter に渡した - りすると大變な事が起こる。何故なら ResponseWriter は - Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを - 測るから、その時に起こるであらう事は言ふまでも無い。 -} - +-- | This is mostly the same as 'outputChunk' but is more efficient. outputChunkBS :: ByteString -> Resource () outputChunkBS str = do driftTo DecidingBody @@ -464,6 +706,12 @@ outputChunkBS str $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where + {- チャンクの大きさは Config で制限されてゐる。もし例へば + /dev/zero を B.readFile して作った ByteString をそのまま + ResponseWriter に渡したりすると大變な事が起こる。何故なら + ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く + 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ + までも無い。 -} sendChunks :: ByteString -> Int -> Resource () sendChunks str limit | B.null str = return () @@ -495,8 +743,7 @@ outputChunkBS str [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK - だった場合は、補完の代はりに 204 No Content に變へる。 + る。 -} @@ -533,23 +780,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