X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=7b64629bf832245669effa0acd8d55c5cc045a9c;hb=11c3854540c46bfcd9e88c2164ed554f3b6550a5;hp=ab594b096b3572eae2d5984a559b515af1ae3816;hpb=f7386c63a35cf243977148de864f64437ba3f593;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index ab594b0..7b64629 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.
@@ -67,13 +69,19 @@ module Network.HTTP.Lucu.Resource
     -- |These actions can be computed regardless of the current state,
     -- and they don't change the state.
     , getConfig
+    , getRemoteAddr
+    , getRemoteAddr'
     , getRequest
     , getMethod
     , getRequestURI
+    , getRequestVersion
     , getResourcePath
     , getPathInfo
+    , getQueryForm
     , getHeader
     , getAccept
+    , getAcceptEncoding
+    , isEncodingAcceptable
     , getContentType
 
     -- ** Finding an entity
@@ -104,9 +112,9 @@ module Network.HTTP.Lucu.Resource
     , setStatus
     , setHeader
     , redirect
-    , setETag
-    , setLastModified
     , setContentType
+    , setLocation
+    , setContentEncoding
 
     -- ** Writing a response body
 
@@ -123,13 +131,14 @@ 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
 import           Data.Maybe
-import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.ContentCoding
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
@@ -142,6 +151,7 @@ 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
 
@@ -154,23 +164,54 @@ type Resource a = ReaderT Interaction IO a
 -- the httpd.
 getConfig :: Resource Config
 getConfig = do itr <- ask
-               return $ itrConfig itr
+               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
+               return $! reqMethod req
 
 -- |Get the URI of the request.
 getRequestURI :: Resource URI
 getRequestURI = do req <- getRequest
-                   return $ reqURI req
+                   return $! reqURI req
+
+-- |Get the HTTP version of the request.
+getRequestVersion :: Resource HttpVersion
+getRequestVersion = do req <- getRequest
+                       return $! reqVersion req
 
 -- |Get the path of this 'Resource' (to be exact,
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
@@ -196,7 +237,7 @@ getRequestURI = do req <- getRequest
 -- >   }
 getResourcePath :: Resource [String]
 getResourcePath = do itr <- ask
-                     return $ fromJust $ itrResourcePath itr
+                     return $! fromJust $! itrResourcePath itr
 
 
 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
@@ -212,61 +253,134 @@ getPathInfo = do rsrcPath <- getResourcePath
                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
                  -- ければこの Resource が撰ばれた筈が無い）ので、
                  -- rsrcPath の長さの分だけ削除すれば良い。
-                 return $ drop (length rsrcPath) reqPath
+                 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
-                    return $ H.getHeader name $ fromJust $ itrRequest itr
+getHeader name = name `seq`
+                 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
-                   return []
-                 else
-                   case parseStr mimeTypeListP $ fromJust accept of
-                     (Success xs, _) -> return xs
-                     _               -> return []
+getAccept = do acceptM <- getHeader "Accept"
+               case acceptM of
+                 Nothing 
+                     -> return []
+                 Just accept
+                     -> case parseStr mimeTypeListP accept of
+                          (Success xs, _) -> return xs
+                          _               -> abort BadRequest []
+                                             (Just $ "Unparsable Accept: " ++ accept)
+
+-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
+-- \"Accept-Encoding\". The list is sorted in descending order by
+-- qvalue.
+getAcceptEncoding :: Resource [(String, Maybe Double)]
+getAcceptEncoding
+    = do accEncM <- getHeader "Accept-Encoding"
+         case accEncM of
+           Nothing
+               -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
+               -- ので安全の爲 identity が指定された事にする。HTTP/1.1
+               -- の場合は何でも受け入れて良い事になってゐるので "*" が
+               -- 指定された事にする。
+               -> do ver <- getRequestVersion
+                     case ver of
+                       HttpVersion 1 0 -> return [("identity", Nothing)]
+                       HttpVersion 1 1 -> return [("*"       , Nothing)]
+           Just ""
+               -- identity のみが許される。
+               -> return [("identity", Nothing)]
+           Just accEnc
+               -> case parseStr acceptEncodingListP accEnc of
+                    (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings x
+                    _              -> abort BadRequest []
+                                      (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
+
+-- |Check whether a given content-coding is acceptable.
+isEncodingAcceptable :: String -> Resource Bool
+isEncodingAcceptable coding
+    = do accList <- getAcceptEncoding
+         return (flip any accList $ \ (c, q) ->
+                     (c == "*" || c `noCaseEq` coding) && q /= Just 0)
+
 
 -- |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
-                        return Nothing
-                      else
-                        case parseStr mimeTypeP $ fromJust cType of
-                          (Success t, _) -> return $ Just t
-                          _              -> return Nothing
-
+getContentType
+    = do cTypeM <- getHeader "Content-Type"
+         case cTypeM of
+           Nothing
+               -> return Nothing
+           Just cType
+               -> case parseStr mimeTypeP cType of
+                    (Success t, _) -> return $ Just t
+                    _              -> abort BadRequest []
+                                      (Just $ "Unparsable Content-Type: " ++ cType)
 
 
 {- 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
+    = tag `seq` timeStamp `seq`
+      do driftTo ExaminingRequest
 
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+                  $ 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
+    = tag `seq`
+      do driftTo ExaminingRequest
       
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' "ETag" $ show tag
+                  $ setHeader' "ETag" $! show tag
+         when (method == POST)
+                  $ abort InternalServerError []
+                        (Just "Illegal computation of foundETag for POST request.")
 
          -- If-Match があればそれを見る。
          ifMatch <- getHeader "If-Match"
@@ -279,8 +393,8 @@ foundETag tag
                               -- PreconditionFailed で終了。
                               -> when (not $ any (== tag) tags)
                                  $ abort PreconditionFailed []
-                                       $ Just ("The entity tag doesn't match: " ++ list)
-                          _   -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+                                       $! Just ("The entity tag doesn't match: " ++ list)
+                          _   -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
 
          let statusForNoneMatch = if method == GET || method == HEAD then
                                       NotModified
@@ -291,23 +405,36 @@ foundETag tag
          ifNoneMatch <- getHeader "If-None-Match"
          case ifNoneMatch of
            Nothing   -> return ()
-           Just "*"  -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
+           Just "*"  -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
            Just list -> case parseStr eTagListP list of
                           (Success tags, _)
                               -> when (any (== tag) tags)
-                                 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
-                          _   -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
+                                 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
+                          _   -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
 
          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
+    = timeStamp `seq`
+      do driftTo ExaminingRequest
 
          method <- getMethod
          when (method == GET || method == HEAD)
-                  $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+                  $ 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
@@ -321,7 +448,7 @@ foundTimeStamp timeStamp
                          Just lastTime
                              -> when (timeStamp <= lastTime)
                                 $ abort statusForIfModSince []
-                                      $ Just ("The entity has not been modified since " ++ str)
+                                      $! Just ("The entity has not been modified since " ++ str)
                          Nothing
                              -> return () -- 不正な時刻は無視
            Nothing  -> return ()
@@ -333,21 +460,29 @@ foundTimeStamp timeStamp
                          Just lastTime
                              -> when (timeStamp > lastTime)
                                 $ abort PreconditionFailed []
-                                      $ Just  ("The entity has not been modified since " ++ str)
+                                      $! Just  ("The entity has not been modified since " ++ str)
                          Nothing
                              -> return () -- 不正な時刻は無視
            Nothing  -> return ()
 
          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
+    = msgM `seq`
+      do driftTo ExaminingRequest
 
          method <- getMethod
          when (method /= PUT)
-              $ abort NotFound [] msgM
+                  $ abort NotFound [] msgM
 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- If-Match: 條件も滿たさない。
@@ -360,17 +495,36 @@ 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
+input limit = limit `seq`
+              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
+    = limit `seq`
+      do driftTo GettingBody
          itr     <- ask
-         hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
+         hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
          chunk   <- if hasBody then
                         askForInput itr
                     else
@@ -380,7 +534,8 @@ inputBS limit
     where
       askForInput :: Interaction -> Resource ByteString
       askForInput itr
-          = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+          = itr `seq`
+            do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
                    actualLimit  = if limit <= 0 then
                                       defaultLimit
                                   else
@@ -388,52 +543,66 @@ inputBS limit
                when (actualLimit <= 0)
                         $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
-               liftIO $ atomically
-                          $ do chunkLen <- readItr itr itrReqChunkLength id
-                               writeItr itr itrWillReceiveBody True
-                               if fmap (> actualLimit) chunkLen == Just True then
-                                   -- 受信前から多過ぎる事が分かってゐる
-                                   tooLarge actualLimit
-                                 else
-                                   writeItr itr itrReqBodyWanted $ Just actualLimit
+               liftIO $! atomically
+                          $! do chunkLen <- readItr itr itrReqChunkLength id
+                                writeItr itr itrWillReceiveBody True
+                                if fmap (> actualLimit) chunkLen == Just True then
+                                    -- 受信前から多過ぎる事が分かってゐる
+                                    tooLarge actualLimit
+                                  else
+                                    writeItr itr itrReqBodyWanted $ Just actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
-               chunk <- liftIO $ atomically
-                        $ do chunk       <- readItr itr itrReceivedBody id
-                             chunkIsOver <- readItr itr itrReqChunkIsOver id
-                             if B.length chunk < fromIntegral actualLimit then
-                                 -- 要求された量に滿たなくて、まだ殘り
-                                 -- があるなら再試行。
-                                 unless chunkIsOver
-                                            $ retry
-                               else
-                                 -- 制限値一杯まで讀むやうに指示したの
-                                 -- にまだ殘ってゐるなら、それは多過ぎ
-                                 -- る。
-                                 unless chunkIsOver
-                                            $ tooLarge actualLimit
-                             -- 成功。itr 内にチャンクを置いたままにす
-                             -- るとメモリの無駄になるので除去。
-                             writeItr itr itrReceivedBody B.empty
-                             return chunk
+               chunk <- liftIO $! atomically
+                        $! do chunk       <- readItr itr itrReceivedBody id
+                              chunkIsOver <- readItr itr itrReqChunkIsOver id
+                              if B.length chunk < fromIntegral actualLimit then
+                                  -- 要求された量に滿たなくて、まだ殘り
+                                  -- があるなら再試行。
+                                  unless chunkIsOver
+                                             $ retry
+                                else
+                                  -- 制限値一杯まで讀むやうに指示したの
+                                  -- にまだ殘ってゐるなら、それは多過ぎ
+                                  -- る。
+                                  unless chunkIsOver
+                                             $ tooLarge actualLimit
+                              -- 成功。itr 内にチャンクを置いたままにす
+                              -- るとメモリの無駄になるので除去。
+                              writeItr itr itrReceivedBody B.empty
+                              return chunk
                driftTo DecidingHeader
                return chunk
 
       tooLarge :: Int -> STM ()
-      tooLarge lim = abortSTM RequestEntityTooLarge []
-                     $ Just ("Request body must be smaller than "
-                             ++ show lim ++ " bytes.")
+      tooLarge lim = lim `seq`
+                     abortSTM RequestEntityTooLarge []
+                     $! 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
+inputChunk limit = limit `seq`
+                   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
+    = limit `seq`
+      do driftTo GettingBody
          itr <- ask
          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
          chunk   <- if hasBody then
@@ -445,7 +614,8 @@ inputChunkBS limit
     where
       askForInput :: Interaction -> Resource ByteString
       askForInput itr
-          = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+          = itr `seq`
+            do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
                    actualLimit  = if limit < 0 then
                                       defaultLimit
                                   else
@@ -453,11 +623,11 @@ inputChunkBS limit
                when (actualLimit <= 0)
                         $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
-               liftIO $ atomically
-                          $ do writeItr itr itrReqBodyWanted $ Just actualLimit
-                               writeItr itr itrWillReceiveBody True
+               liftIO $! atomically
+                          $! do writeItr itr itrReqBodyWanted $! Just actualLimit
+                                writeItr itr itrWillReceiveBody True
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
-               chunk <- liftIO $ atomically
+               chunk <- liftIO $! atomically
                         $ do chunk <- readItr itr itrReceivedBody id
                              -- 要求された量に滿たなくて、まだ殘りがあ
                              -- るなら再試行。
@@ -472,13 +642,20 @@ 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
+    = limit `seq` 
+      do cTypeM <- getContentType
          case cTypeM of
            Nothing
                -> abort BadRequest [] (Just "Missing Content-Type")
@@ -487,21 +664,20 @@ inputForm limit
            Just (MIMEType "multipart" "form-data" _)
                -> readMultipartFormData
            Just cType
-               -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
+               -> 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
-                                  )
+               return $ parseWWWFormURLEncoded src
+
       readMultipartFormData -- FIXME: 未對應
           = abort UnsupportedMediaType []
-            (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
-
+            (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)
 
@@ -509,77 +685,118 @@ 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
+    = code `seq`
+      do driftTo DecidingHeader
          itr <- ask
-         liftIO $ atomically $ updateItr itr itrResponse
-                    $ \ res -> res {
-                                 resStatus = code
-                               }
-
-
+         liftIO $! atomically $! updateItr itr itrResponse
+                    $! \ 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 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
+    = name `seq` value `seq`
+      driftTo DecidingHeader >> setHeader' name value
          
 
-setHeader' :: String -> String -> Resource()
+setHeader' :: String -> String -> Resource ()
 setHeader' name value
-    = do itr <- ask
+    = name `seq` value `seq`
+      do itr <- ask
          liftIO $ atomically
                     $ 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))
+    = code `seq` uri `seq`
+      do when (code == NotModified || not (isRedirection code))
                   $ abort InternalServerError []
-                        $ Just ("Attempted to redirect with status " ++ show code)
+                        $! 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
+{-# INLINE redirect #-}
 
 
+-- | Computation of @'setContentType' mType@ sets the response header
+-- \"Content-Type\" to @mType@.
 setContentType :: MIMEType -> Resource ()
 setContentType mType
-    = setHeader "Content-Type" $ show 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 $ ""
+
+-- |Computation of @'setContentEncoding' codings@ sets the response
+-- header \"Content-Encoding\" to @codings@.
+setContentEncoding :: [String] -> Resource ()
+setContentEncoding codings
+    = do ver <- getRequestVersion
+         let tr = case ver of
+                    HttpVersion 1 0 -> unnormalizeCoding
+                    HttpVersion 1 1 -> id
+         setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
 
 
 {- 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
-
+output str = outputBS $! B.pack str
+{-# INLINE output #-}
 
+-- | This is mostly the same as 'output' but is more efficient.
 outputBS :: ByteString -> Resource ()
 outputBS str = do outputChunkBS str
                   driftTo Done
+{-# INLINE outputBS #-}
 
-
+-- | 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 の時、ヘッダを書く爲にチャンクの大きさを
-   測るから、その時に起こるであらう事は言ふまでも無い。 -}
+outputChunk str = outputChunkBS $! B.pack str
+{-# INLINE outputChunk #-}
 
+-- | This is mostly the same as 'outputChunk' but is more efficient.
 outputChunkBS :: ByteString -> Resource ()
 outputChunkBS str
-    = do driftTo DecidingBody
+    = str `seq`
+      do driftTo DecidingBody
          itr <- ask
          
          let limit = cnfMaxOutputChunkLength $ itrConfig itr
@@ -597,6 +814,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 ()
@@ -634,7 +857,8 @@ outputChunkBS str
 
 driftTo :: InteractionState -> Resource ()
 driftTo newState
-    = do itr <- ask
+    = newState `seq`
+      do itr <- ask
          liftIO $ atomically $ do oldState <- readItr itr itrState id
                                   if newState < oldState then
                                       throwStateError oldState newState