+-- #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.
-- 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
-- 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
, 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
, inputForm
, defaultLimit
+ -- ** Setting response headers
+
+ -- |Computation of these actions changes the state to /Deciding
+ -- Header/.
, setStatus
, setHeader
, redirect
- , setETag
- , setLastModified
, setContentType
+ -- ** Writing a response body
+
+ -- |Computation of these actions changes the state to /Deciding
+ -- Body/.
, output
, outputChunk
, outputBS
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
-
+-- |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
-- 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
-
+-- |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
(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
{- 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
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
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"
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
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
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 or DELETE request, 'foundNoEntity'
+-- always aborts with status \"404 Not Found\". It is an error to
+-- compute 'foundNoEntity' if this is a POST request.
foundNoEntity :: Maybe String -> Resource ()
foundNoEntity msgM
= do driftTo ExaminingRequest
method <- getMethod
+ when (method == POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundNoEntity for POST request.")
when (method /= PUT)
- $ abort NotFound [] msgM
+ $ abort NotFound [] msgM
-- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
-- If-Match: 條件も滿たさない。
{- 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
$ 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
$ 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
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)
{- 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
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
$ 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))
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
-
-
+-- | Computation of @'setContentType' mType@ sets the response header
+-- \"Content-Type\" to @mType@.
setContentType :: MIMEType -> Resource ()
setContentType mType
= setHeader "Content-Type" $ show 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
$ 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 ()
projects / Lucu.git / blobdiff