X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=af8c16917e154dd12e0661b671659a5c462b7b71;hb=5b255535f2c7d2a6d4622ad164b31e63746b906e;hp=318599f40c7347bc54ac2c13a64d5de92f9516a0;hpb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 318599f..af8c169 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,3 +1,5 @@ +-- #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. @@ -17,8 +19,8 @@ -- 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/. +-- '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 @@ -36,35 +38,63 @@ -- 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, ... +-- 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. -- --- [/Deciding Body/] +-- [/Done/] Everything is over. A 'Resource' can do nothing for the +-- HTTP interaction anymore. -- --- [/Done/] +-- 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 + ( + -- * Monad + Resource --- 一方通行であること、その理由 + -- * Actions --- FIXME: 續きを書く - -module Network.HTTP.Lucu.Resource - ( Resource + -- ** Getting request header + -- |These actions can be computed regardless of the current state, + -- and they don't change the state. , getConfig + , getRemoteAddr + , getRemoteAddr' , 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 @@ -72,13 +102,20 @@ module Network.HTTP.Lucu.Resource , inputForm , defaultLimit + -- ** Setting response headers + + -- |Computation of these actions changes the state to /Deciding + -- Header/. , setStatus , setHeader , redirect - , setETag - , setLastModified , setContentType + , setLocation + -- ** Writing a response body + + -- |Computation of these actions changes the state to /Deciding + -- Body/. , output , outputChunk , outputBS @@ -90,6 +127,7 @@ module Network.HTTP.Lucu.Resource import Control.Concurrent.STM import Control.Monad.Reader +import Data.Bits import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Data.List @@ -109,38 +147,93 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils +import Network.Socket 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 SockAddr of the remote host. If you want a string +-- representation instead of SockAddr, use 'getRemoteAddr''. +getRemoteAddr :: Resource SockAddr +getRemoteAddr = do itr <- ask + return $ itrRemoteAddr itr + + +-- |Get the string representation of the address of remote host. If +-- you want a SockAddr instead of String, use 'getRemoteAddr'. +getRemoteAddr' :: Resource String +getRemoteAddr' = do addr <- getRemoteAddr + case addr of + -- Network.Socket は IPv6 を考慮してゐないやうだ… + (SockAddrInet _ v4addr) + -> let b1 = (v4addr `shiftR` 24) .&. 0xFF + b2 = (v4addr `shiftR` 16) .&. 0xFF + b3 = (v4addr `shiftR` 8) .&. 0xFF + b4 = v4addr .&. 0xFF + in + return $ concat $ intersperse "." $ map show [b1, b2, b3, b4] + (SockAddrUnix path) + -> return path + + +-- |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 @@ -153,12 +246,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 @@ -168,7 +272,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 @@ -182,6 +287,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 @@ -189,11 +308,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 @@ -201,6 +329,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" @@ -234,7 +365,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 @@ -242,6 +382,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 @@ -274,14 +417,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: 條件も滿たさない。 @@ -294,12 +444,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 @@ -357,14 +524,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 @@ -406,10 +584,16 @@ inputChunkBS limit $ driftTo DecidingHeader return chunk - --- application/x-www-form-urlencoded または multipart/form-data をパー --- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の --- タイプであったら UnsupportedMediaType で終了する。 +-- | 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 @@ -426,16 +610,15 @@ inputForm limit where readWWWFormURLEncoded = do src <- input limit - return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src - let pair = break (== '=') pairStr - return ( unEscapeString $ fst pair - , unEscapeString $ snd pair - ) + 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) @@ -443,6 +626,8 @@ 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 @@ -452,7 +637,20 @@ setStatus code 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 @@ -465,52 +663,58 @@ setHeader' name value $ 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 @@ -531,6 +735,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 ()