getRemoteAddr and getRemoteAddr'

[Lucu.git] / Network / HTTP / Lucu / Resource.hs

-- #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.
-- 
-- 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
    (
    -- * Monad
    Resource

    -- * Actions

    -- ** Getting request header

    -- |These actions can be computed regardless of the current state,
    -- and they don't change the state.
    , getConfig
    , getRemoteAddr
    , getRemoteAddr'
    , 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
    , inputChunkBS
    , inputForm
    , defaultLimit

    -- ** Setting response headers
    
    -- |Computation of these actions changes the state to /Deciding
    -- Header/.
    , setStatus
    , setHeader
    , redirect
    , setContentType
    , setLocation

    -- ** Writing a response body

    -- |Computation of these actions changes the state to /Deciding
    -- Body/.
    , output
    , outputChunk
    , outputBS
    , outputChunkBS

    , driftTo
    )
    where

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.DefaultPage
import           Network.HTTP.Lucu.ETag
import qualified Network.HTTP.Lucu.Headers as H
import           Network.HTTP.Lucu.HttpVersion
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Parser
import           Network.HTTP.Lucu.Postprocess
import           Network.HTTP.Lucu.RFC1123DateTime
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

-- |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 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
                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

-- |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
                 let reqPathStr = uriPath reqURI
                     reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
                 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
                 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
                 -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
                 -- ければこの Resource が撰ばれた筈が無い）ので、
                 -- 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 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 []

-- |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



{- 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"
         case ifMatch of
           Nothing   -> return ()
           Just "*"  -> return ()
           Just list -> case parseStr eTagListP list of
                          (Success tags, _)
                              -- tags の中に一致するものが無ければ
                              -- PreconditionFailed で終了。
                              -> when (not $ any (== tag) tags)
                                 $ abort PreconditionFailed []
                                       $ 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
                                  else
                                      PreconditionFailed

         -- If-None-Match があればそれを見る。
         ifNoneMatch <- getHeader "If-None-Match"
         case ifNoneMatch of
           Nothing   -> return ()
           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)

         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
                                   else
                                       PreconditionFailed

         -- If-Modified-Since があればそれを見る。
         ifModSince <- getHeader "If-Modified-Since"
         case ifModSince of
           Just str -> case parseHTTPDateTime str of
                         Just lastTime
                             -> when (timeStamp <= lastTime)
                                $ abort statusForIfModSince []
                                      $ Just ("The entity has not been modified since " ++ str)
                         Nothing
                             -> return () -- 不正な時刻は無視
           Nothing  -> return ()

         -- If-Unmodified-Since があればそれを見る。
         ifUnmodSince <- getHeader "If-Unmodified-Since"
         case ifUnmodSince of
           Just str -> case parseHTTPDateTime str of
                         Just lastTime
                             -> when (timeStamp > lastTime)
                                $ abort PreconditionFailed []
                                      $ 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

         method <- getMethod
         when (method /= PUT)
                  $ abort NotFound [] msgM

         -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
         -- If-Match: 條件も滿たさない。
         ifMatch <- getHeader "If-Match"
         when (ifMatch /= Nothing)
                  $ abort PreconditionFailed [] msgM

         driftTo GettingBody


{- 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


-- | 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
         itr     <- ask
         hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
         chunk   <- if hasBody then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
                           return B.empty
         return chunk
    where
      askForInput :: Interaction -> Resource ByteString
      askForInput itr
          = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
                   actualLimit  = if limit <= 0 then
                                      defaultLimit
                                  else
                                      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
               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
               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.")
         
-- | 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


-- | This is mostly the same as 'inputChunk' but is more
-- efficient. See 'inputBS'.
inputChunkBS :: Int -> Resource ByteString
inputChunkBS limit
    = do driftTo GettingBody
         itr <- ask
         hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
         chunk   <- if hasBody then
                        askForInput itr
                    else
                        do driftTo DecidingHeader
                           return B.empty
         return chunk
    where
      askForInput :: Interaction -> Resource ByteString
      askForInput itr
          = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
                   actualLimit  = if limit < 0 then
                                      defaultLimit
                                  else
                                      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
               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
               chunk <- liftIO $ atomically
                        $ do chunk <- readItr itr itrReceivedBody id
                             -- 要求された量に滿たなくて、まだ殘りがあ
                             -- るなら再試行。
                             when (B.length chunk < fromIntegral actualLimit)
                                      $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
                                           unless chunkIsOver
                                                      $ retry
                             -- 成功
                             writeItr itr itrReceivedBody B.empty
                             return chunk
               when (B.null chunk)
                        $ driftTo DecidingHeader
               return chunk

-- | 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
         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 $ 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
         itr <- ask
         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
         

setHeader' :: String -> String -> Resource()
setHeader' name value
    = 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))
                  $ abort InternalServerError []
                        $ Just ("Attempted to redirect with status " ++ show code)
         setStatus code
         setLocation uri

-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType :: MIMEType -> Resource ()
setContentType 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 $ ""


{- 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

-- | This is mostly the same as 'outputChunk' but is more efficient.
outputChunkBS :: ByteString -> Resource ()
outputChunkBS str
    = do driftTo DecidingBody
         itr <- ask
         
         let limit = cnfMaxOutputChunkLength $ itrConfig itr
         when (limit <= 0)
                  $ fail ("cnfMaxOutputChunkLength must be positive: "
                          ++ show limit)

         discardBody <- liftIO $ atomically $
                        readItr itr itrWillDiscardBody id

         unless (discardBody)
                    $ sendChunks str limit

         unless (B.null 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 ()
          | otherwise  = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
                            itr <- ask
                            liftIO $ atomically $ 
                                   do buf <- readItr itr itrBodyToSend id
                                      if B.null buf then
                                          -- バッファが消化された
                                          writeItr itr itrBodyToSend chunk
                                        else
                                          -- 消化されるのを待つ
                                          retry
                            -- 殘りのチャンクについて繰り返す
                            sendChunks remaining limit

{-

  [GettingBody からそれ以降の状態に遷移する時]
  
  body を讀み終へてゐなければ、殘りの body を讀み捨てる。


  [DecidingHeader からそれ以降の状態に遷移する時]

  postprocess する。


  [Done に遷移する時]

  bodyIsNull が False ならば何もしない。True だった場合は出力補完す
  る。

-}

driftTo :: InteractionState -> Resource ()
driftTo newState
    = do itr <- ask
         liftIO $ atomically $ do oldState <- readItr itr itrState id
                                  if newState < oldState then
                                      throwStateError oldState newState
                                    else
                                      do let a = [oldState .. newState]
                                             b = tail a
                                             c = zip a b
                                         mapM_ (uncurry $ drift itr) c
                                         writeItr itr itrState newState
    where
      throwStateError :: Monad m => InteractionState -> InteractionState -> m a

      throwStateError Done DecidingBody
          = fail "It makes no sense to output something after finishing to output."

      throwStateError old new
          = fail ("state error: " ++ show old ++ " ==> " ++ show new)


      drift :: Interaction -> InteractionState -> InteractionState -> STM ()

      drift itr GettingBody _
          = writeItr itr itrReqBodyWasteAll True

      drift itr DecidingHeader _
          = postprocess itr

      drift itr _ Done
          = do bodyIsNull <- readItr itr itrBodyIsNull id
               when bodyIsNull
                        $ writeDefaultPage itr

      drift _ _ _
          = return ()