+-- |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
= 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 ()
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 ()
[Done に遷移する時]
bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK
- だった場合は、補完の代はりに 204 No Content に變へる。
+ る。
-}
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
projects / Lucu.git / blobdiff