X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=d87e509b89d479ffcd39b97d58e0c01724bcb337;hb=86ea98d8307ddc687696896a91bed9a05cbeb783;hp=7b1b26a0dd08ea9423f3f895395d0e6a45c2c145;hpb=854f6d1709d468f7e1bf0db2dcd2d30de6bd5f5e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 7b1b26a..d87e509 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,41 +1,121 @@
+-- |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
+    , 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
+
+    -- ** Writing a response body
+
+    -- |Computation of these actions changes the state to /Deciding
+    -- Body/.
+    , output
+    , outputChunk
+    , outputBS
+    , outputChunkBS
+
+    , driftTo
     )
     where
 
@@ -63,35 +143,63 @@ 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
 
-
+-- |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 +212,16 @@ getPathInfo = do rsrcPath <- getResourcePath
                  -- rsrcPath の長さの分だけ削除すれば良い。
                  return $ drop (length rsrcPath) reqPath
 
-
+-- |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
+-- 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
@@ -119,7 +231,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 +246,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 +267,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 +288,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 +324,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 +341,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 +376,25 @@ foundTimeStamp timeStamp
 
          driftTo GettingBody
 
-
+-- |Computation of @'foundNoEntity' mStr@ tell 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: 條件も滿たさない。
@@ -358,6 +520,35 @@ inputChunkBS limit
                return chunk
 
 
+-- application/x-www-form-urlencoded または multipart/form-data をパー
+-- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
+-- タイプであったら UnsupportedMediaType で終了する。
+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 $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
+                           let pair = break (== '=') pairStr
+                           return ( unEscapeString $ fst pair
+                                  , unEscapeString $ snd pair
+                                  )
+      readMultipartFormData -- FIXME: 未對應
+          = abort UnsupportedMediaType []
+            (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
+
+
 defaultLimit :: Int
 defaultLimit = (-1)
 
@@ -370,17 +561,22 @@ 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 an action like 'setContentType'
+-- for every common headers.
+--
+-- Some important headers (especially \"Content-Length\" and
+-- \"Transfer-Encoding\") may be silently deleted 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.
 setHeader :: String -> String -> Resource ()
 setHeader name value
     = driftTo DecidingHeader >> setHeader' name value
@@ -389,14 +585,9 @@ 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
 
 
 redirect :: StatusCode -> URI -> Resource ()
@@ -408,16 +599,6 @@ redirect code uri
          setHeader "Location" (uriToString id uri $ "")
 
 
-setETag :: ETag -> Resource ()
-setETag tag
-    = setHeader "ETag" $ show tag
-
-
-setLastModified :: ClockTime -> Resource ()
-setLastModified lastmod
-    = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
-
-
 setContentType :: MIMEType -> Resource ()
 setContentType mType
     = setHeader "Content-Type" $ show mType
@@ -495,8 +676,7 @@ outputChunkBS str
   [Done に遷移する時]
 
   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
-  る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK
-  だった場合は、補完の代はりに 204 No Content に變へる。
+  る。
 
 -}
 
@@ -533,23 +713,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