From 0b4db5681e3b0b27357a87316822ea3671f8c174 Mon Sep 17 00:00:00 2001 From: pho Date: Thu, 3 May 2007 11:37:03 +0900 Subject: [PATCH] More documentation darcs-hash:20070503023703-62b54-053768ca326bc40dcec21e5614a14a3fb55d19a4.gz --- Network/HTTP/Lucu/Parser.hs | 10 +-- Network/HTTP/Lucu/Resource.hs | 133 +++++++++++++++++++++++--------- Network/HTTP/Lucu/StaticFile.hs | 33 ++++++-- Network/HTTP/Lucu/Utils.hs | 15 +++- 4 files changed, 145 insertions(+), 46 deletions(-) diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index c36655b..4c44f0b 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -9,11 +9,11 @@ -- * On success, the remaining string is returned as well as the -- parser result. -- --- * You can treat reaching EOF (trying to eat one more letter at the --- end of string) a fatal error or a normal failure. If a fatal --- error occurs, the entire parsing process immediately fails --- without trying any backtracks. The default behavior is to treat --- EOF fatal. +-- * You can choose whether to treat reaching EOF (trying to eat one +-- more letter at the end of string) a fatal error or to treat it a +-- normal failure. If a fatal error occurs, the entire parsing +-- process immediately fails without trying any backtracks. The +-- default behavior is to treat EOF fatal. -- -- In general, you don't have to use this module directly. module Network.HTTP.Lucu.Parser diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d87e509..1f26ec4 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. @@ -72,6 +74,7 @@ module Network.HTTP.Lucu.Resource , getRequestURI , getResourcePath , getPathInfo + , getQueryForm , getHeader , getAccept , getContentType @@ -212,9 +215,16 @@ 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 an action like 'getContentType' for +-- so frequently: there should be actions like 'getContentType' for -- every common headers. getHeader :: String -> Resource (Maybe String) getHeader name = do itr <- ask @@ -376,7 +386,7 @@ foundTimeStamp timeStamp driftTo GettingBody --- |Computation of @'foundNoEntity' mStr@ tell the system that the +-- | 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. -- @@ -407,12 +417,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 @@ -470,14 +497,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 @@ -519,10 +557,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 @@ -539,16 +583,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) @@ -556,6 +599,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 @@ -567,16 +612,18 @@ setStatus 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 an action like 'setContentType' +-- 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 deleted or overwritten by +-- \"Transfer-Encoding\") may be silently dropped or overwritten by -- the system not to corrupt the interaction with client at the --- viewpoint of HTTP protocol. For instance, if we are keeping --- connection alive, for an obvious reason it causes a catastrophe to --- send header \"Content-Length: 10\" and actually sending body of 20 --- bytes long. +-- 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 @@ -589,7 +636,9 @@ 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)) @@ -598,7 +647,8 @@ redirect code uri setStatus code setHeader "Location" (uriToString id uri $ "") - +-- | Computation of @'setContentType' mType@ sets the response header +-- \"Content-Type\" to @mType@. setContentType :: MIMEType -> Resource () setContentType mType = setHeader "Content-Type" $ show mType @@ -606,25 +656,32 @@ setContentType mType {- 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 @@ -645,6 +702,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 () diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index e710fc9..b84c9cb 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,3 +1,4 @@ +-- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile , handleStaticFile @@ -26,6 +27,9 @@ import System.Posix.Files import Text.Printf +-- | @'staticFile' fpath@ is a +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file +-- at @fpath@ on the filesystem. staticFile :: FilePath -> ResourceDef staticFile path = ResourceDef { @@ -38,7 +42,15 @@ staticFile path , resDelete = Nothing } - +-- | Computation of @'handleStaticFile' fpath@ serves the file at +-- @fpath@ on the filesystem. The +-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining +-- Request/ state before the computation. It will be in the /Done/ +-- state after the computation. +-- +-- If you just want to place a static file on the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use +-- 'staticFile' instead of this. handleStaticFile :: FilePath -> Resource () handleStaticFile path = do isFile <- liftIO $ doesFileExist path @@ -69,8 +81,7 @@ handleStaticFile path else foundNoEntity Nothing - --- |Computation @'generateETagFromFile' fpath@ generates a strong +-- |Computation of @'generateETagFromFile' fpath@ generates a strong -- entity tag from a file. The file doesn't necessarily have to be a -- regular file; it may be a FIFO or a device file. The tag is made of -- inode ID, size and modification time. @@ -90,7 +101,10 @@ generateETagFromFile path lastmod = fromEnum $ modificationTime stat return $ strongETag $ printf "%x-%x-%x" inode size lastmod - +-- | @'staticDir' dir@ is a +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files +-- in @dir@ and its subdirectories on the filesystem to the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. staticDir :: FilePath -> ResourceDef staticDir path = ResourceDef { @@ -103,7 +117,16 @@ staticDir path , resDelete = Nothing } - +-- | Computation of @'handleStaticDir' dir@ maps all files in @dir@ +-- and its subdirectories on the filesystem to the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The +-- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining +-- Request/ state before the computation. It will be in the /Done/ +-- state after the computation. +-- +-- If you just want to place a static directory tree on the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use +-- 'staticDir' instead of this. handleStaticDir :: FilePath -> Resource () handleStaticDir basePath = do extraPath <- getPathInfo diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index 12f8996..d7ace3f 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -7,6 +7,7 @@ module Network.HTTP.Lucu.Utils , noCaseEq , isWhiteSpace , quoteStr + , parseWWWFormURLEncoded ) where @@ -59,4 +60,16 @@ quoteStr str = foldr (++) "" (["\""] ++ map quote str ++ ["\""]) where quote :: Char -> String quote '"' = "\\\"" - quote c = [c] \ No newline at end of file + quote c = [c] + + +-- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" +-- > ==> [("aaa", "bbb"), ("ccc", "ddd")] +parseWWWFormURLEncoded :: String -> [(String, String)] +parseWWWFormURLEncoded src + | src == "" = [] + | otherwise = do pairStr <- splitBy (\ c -> c == ';' || c == '&') src + let pair = break (== '=') pairStr + return ( unEscapeString $ fst pair + , unEscapeString $ snd pair + ) -- 2.40.0