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

{-# LANGUAGE
    GeneralizedNewtypeDeriving
  , DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
{-# OPTIONS_HADDOCK prune #-}

-- |This is the Resource Monad; monadic actions to define the behavior
-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
-- Monad thus it implements 'Control.Monad.Trans.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
    (
    -- * Types
      Resource
    , FormData(..)
    , runRes -- private

    -- * Actions

    -- ** Getting request header

    -- |These actions can be computed regardless of the current state,
    -- and they don't change the state.
    , getConfig
    , getRemoteAddr
    , getRemoteAddr'
    , getRemoteHost
    , getRemoteCertificate
    , getRequest
    , getMethod
    , getRequestURI
    , getRequestVersion
    , getResourcePath
    , getPathInfo
    , getQueryForm
    , getHeader
    , getAccept
    , getAcceptEncoding
    , isEncodingAcceptable
    , getContentType
    , getAuthorization

    -- ** 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
    , inputForm
    , defaultLimit

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

    -- ** Writing a response body

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

    , driftTo -- private
    )
    where
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.Attoparsec.Char8 as P
import qualified Data.Attoparsec.Lazy  as LP
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.Foldable (toList)
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import qualified Data.Time.HTTP as HTTP
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Authorization
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
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.MultipartForm
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
import Network.URI hiding (path)
import OpenSSL.X509
import Prelude.Unicode

-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
-- any 'IO' actions.
newtype Resource a
    = Resource {
        unRes ∷ ReaderT Interaction IO a
      }
    deriving (Applicative, Functor, Monad, MonadIO)

runRes ∷ Resource a → Interaction → IO a
runRes r itr
    = runReaderT (unRes r) itr

getInteraction ∷ Resource Interaction
getInteraction = Resource ask

-- |Get the 'Config' value which is used for the httpd.
getConfig ∷ Resource Config
getConfig = itrConfig <$> getInteraction

-- |Get the 'SockAddr' of the remote host. If you want a string
-- representation instead of 'SockAddr', use 'getRemoteAddr''.
getRemoteAddr ∷ Resource SockAddr
getRemoteAddr = itrRemoteAddr <$> getInteraction

-- |Get the string representation of the address of remote host. If
-- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
getRemoteAddr' ∷ Resource HostName
getRemoteAddr'
    = do sa          ← getRemoteAddr
         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
         return a

-- |Resolve an address to the remote host.
getRemoteHost ∷ Resource (Maybe HostName)
getRemoteHost
    = do sa ← getRemoteAddr
         fst <$> (liftIO $ getNameInfo [] True False sa)

-- | Return the X.509 certificate of the client, or 'Nothing' if:
--
--   * This request didn't came through an SSL stream.
--
--   * The client didn't send us its certificate.
--
--   * The 'OpenSSL.Session.VerificationMode' of
--   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
--   'OpenSSL.Session.VerifyPeer'.
getRemoteCertificate ∷ Resource (Maybe X509)
getRemoteCertificate = itrRemoteCert <$> getInteraction

-- |Get the 'Request' value which represents the request header. In
-- general you don't have to use this action.
getRequest ∷ Resource Request
getRequest = (fromJust ∘ itrRequest) <$> getInteraction

-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
getMethod = reqMethod <$> getRequest

-- |Get the URI of the request.
getRequestURI ∷ Resource URI
getRequestURI = reqURI <$> getRequest

-- |Get the HTTP version of the request.
getRequestVersion ∷ Resource HttpVersion
getRequestVersion = reqVersion <$> getRequest

-- |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 [Text]
getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction

-- |This is an analogy of CGI PATH_INFO. The result is
-- URI-unescaped. It is always @[]@ if the
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
-- 'getResourcePath'.
--
-- Note that the returned path is URI-decoded and then UTF-8 decoded.
getPathInfo ∷ Resource [Text]
getPathInfo = do rsrcPath ← getResourcePath
                 reqPath  ← splitPathInfo <$> getRequestURI
                 -- 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 to pairs of
-- @(name, formData)@. This action doesn't parse the request body. See
-- 'inputForm'. Field names are decoded in UTF-8.
getQueryForm ∷ Resource [(Text, FormData)]
getQueryForm = parse' <$> getRequestURI
    where
      parse' = map toPairWithFormData ∘
               parseWWWFormURLEncoded ∘
               fromJust ∘
               A.fromChars ∘
               drop 1 ∘
               uriQuery

toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
toPairWithFormData (name, value)
    = let fd = FormData {
                 fdFileName = Nothing
               , fdContent  = Lazy.fromChunks [value]
               }
      in (T.decodeUtf8 name, fd)

-- |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 ∷ CIAscii → Resource (Maybe Ascii)
getHeader name
    = H.getHeader name <$> getRequest

-- |Get a list of 'MIMEType' enumerated on header \"Accept\".
getAccept ∷ Resource [MIMEType]
getAccept
    = do acceptM ← getHeader "Accept"
         case acceptM of
           Nothing
               → return []
           Just accept
               → case P.parseOnly p (A.toByteString accept) of
                    Right xs → return xs
                    Left  _  → abort BadRequest []
                               (Just $ "Unparsable Accept: " ⊕ A.toText accept)
    where
      p = do xs ← mimeTypeListP
             P.endOfInput
             return xs

-- |Get a list of @(contentCoding, qvalue)@ enumerated on header
-- \"Accept-Encoding\". The list is sorted in descending order by
-- qvalue.
getAcceptEncoding ∷ Resource [(CIAscii, 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)]
                      _               → abort InternalServerError []
                                        (Just "getAcceptEncoding: unknown HTTP version")
           Just ae
               → if ae ≡ "" then
                      -- identity のみが許される。
                      return [("identity", Nothing)]
                  else
                      case P.parseOnly p (A.toByteString ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort BadRequest []
                                   (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
    where
      p = do xs ← acceptEncodingListP
             P.endOfInput
             return xs

      toTuple (AcceptEncoding {..})
          = (aeEncoding, aeQValue)

-- |Check whether a given content-coding is acceptable.
isEncodingAcceptable ∷ CIAscii → Resource Bool
isEncodingAcceptable encoding = any f <$> getAcceptEncoding
    where
      f (e, q)
          = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0

-- |Get the header \"Content-Type\" as 'MIMEType'.
getContentType ∷ Resource (Maybe MIMEType)
getContentType
    = do cTypeM ← getHeader "Content-Type"
         case cTypeM of
           Nothing
               → return Nothing
           Just cType
               → case P.parseOnly p (A.toByteString cType) of
                    Right t → return $ Just t
                    Left  _ → abort BadRequest []
                              (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
    where
      p = do t ← mimeTypeP
             P.endOfInput
             return t

-- |Get the header \"Authorization\" as 'AuthCredential'.
getAuthorization ∷ Resource (Maybe AuthCredential)
getAuthorization
    = do authM ← getHeader "Authorization"
         case authM of
           Nothing
               → return Nothing
           Just auth
               → case P.parseOnly p (A.toByteString auth) of
                    Right ac → return $ Just ac
                    Left  _  → return Nothing
    where
      p = do ac ← authCredentialP
             P.endOfInput
             return ac


{- 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 until 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 → UTCTime → Resource ()
foundEntity tag timeStamp
    = do driftTo ExaminingRequest

         method ← getMethod
         when (method ≡ GET ∨ method ≡ HEAD)
             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
         when (method ≡ POST)
             $ abort InternalServerError []
               (Just "Illegal computation of foundEntity for a 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' whenever
-- possible.
foundETag ∷ ETag → Resource ()
foundETag tag
    = do driftTo ExaminingRequest
      
         method ← getMethod
         when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader' "ETag" (printETag 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 value → if value ≡ "*" then
                            return ()
                        else
                            case P.parseOnly p (A.toByteString value) of
                              Right tags
                                 -- tags の中に一致するものが無ければ
                                 -- PreconditionFailed で終了。
                                 → when ((¬) (any (≡ tag) tags))
                                       $ abort PreconditionFailed []
                                         (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
                              Left _
                                   → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)

         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 value → if value ≡ "*" then
                             abort statusForNoneMatch [] (Just "The entity tag matches: *")
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)
                                         $ abort statusForNoneMatch []
                                           (Just $ "The entity tag matches: " ⊕ A.toText value)
                               Left _
                                   → abort BadRequest []
                                     (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)

         driftTo GettingBody
    where
      p = do xs ← eTagListP
             P.endOfInput
             return xs

-- |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' whenever
-- possible.
foundTimeStamp ∷ UTCTime → Resource ()
foundTimeStamp timeStamp
    = do driftTo ExaminingRequest

         method ← getMethod
         when (method ≡ GET ∨ method ≡ HEAD)
             $ setHeader' "Last-Modified" (HTTP.toAscii 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 HTTP.fromAscii str of
                         Right lastTime
                             → when (timeStamp ≤ lastTime)
                               $ abort statusForIfModSince []
                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
                         Left _
                             → return () -- 不正な時刻は無視
           Nothing  → return ()

         -- If-Unmodified-Since があればそれを見る。
         ifUnmodSince ← getHeader "If-Unmodified-Since"
         case ifUnmodSince of
           Just str → case HTTP.fromAscii str of
                         Right lastTime
                             → when (timeStamp > lastTime)
                               $ abort PreconditionFailed []
                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
                         Left _
                             → 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 Text → 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 ('cnfMaxEntityLength') is used. See
-- 'defaultLimit'.
--
-- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
-- reading from the socket just happens at the computation of 'input',
-- not at the evaluation of the 'Lazy.ByteString'. The same goes for
-- 'inputChunk'.
input ∷ Int → Resource Lazy.ByteString
input limit
    = do driftTo GettingBody
         itr     ← getInteraction
         chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
                       askForInput itr
                   else
                       do driftTo DecidingHeader
                          return (∅)
         return chunk
    where
      askForInput ∷ Interaction → Resource Lazy.ByteString
      askForInput (Interaction {..})
          = do let confLimit   = cnfMaxEntityLength itrConfig
                   actualLimit = if limit ≤ 0 then
                                     confLimit
                                 else
                                     limit
               when (actualLimit ≤ 0)
                        $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
               -- Reader にリクエスト
               liftIO $ atomically
                      $ writeTVar itrReqBodyWanted (Just actualLimit)
               -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
               chunk ← liftIO $ atomically
                       $ do chunkLen    ← readTVar itrReceivedBodyLen
                            chunkIsOver ← readTVar itrReqChunkIsOver
                            if chunkLen < actualLimit then
                                -- 要求された量に滿たなくて、まだ殘りが
                                -- あるなら再試行。
                                unless chunkIsOver
                                    $ retry
                            else
                                -- 制限値一杯まで讀むやうに指示したのに
                                -- まだ殘ってゐるなら、それは多過ぎる。
                                unless chunkIsOver
                                    $ tooLarge actualLimit
                            -- 成功。itr 内にチャンクを置いたままにする
                            -- とメモリの無駄になるので除去。
                            chunk ← seqToLBS <$> readTVar itrReceivedBody
                            writeTVar itrReceivedBody    (∅)
                            writeTVar itrReceivedBodyLen 0
                            return chunk

               driftTo DecidingHeader
               return chunk

      tooLarge ∷ Int → STM ()
      tooLarge lim = abortSTM RequestEntityTooLarge []
                     (Just $ "Request body must be smaller than "
                             ⊕ T.pack (show lim) ⊕ " bytes.")

seqToLBS ∷ Seq ByteString → Lazy.ByteString
{-# INLINE seqToLBS #-}
seqToLBS = Lazy.fromChunks ∘ toList
         
-- | 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 ('cnfMaxEntityLength') is used. See
-- 'defaultLimit'.
--
-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
-- should use it whenever possible.
inputChunk ∷ Int → Resource Lazy.ByteString
inputChunk limit
    = do driftTo GettingBody
         itr     ← getInteraction
         chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
                       askForInput itr
                   else
                       do driftTo DecidingHeader
                          return (∅)
         return chunk
    where
      askForInput ∷ Interaction → Resource Lazy.ByteString
      askForInput (Interaction {..})
          = do let confLimit   = cnfMaxEntityLength itrConfig
                   actualLimit = if limit < 0 then
                                     confLimit
                                 else
                                     limit
               when (actualLimit ≤ 0)
                        $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
               -- Reader にリクエスト
               liftIO $ atomically
                      $ writeTVar itrReqBodyWanted (Just actualLimit)
               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
               chunk ← liftIO $ atomically
                       $ do chunkLen ← readTVar itrReceivedBodyLen
                            -- 要求された量に滿たなくて、まだ殘りがある
                            -- なら再試行。
                            when (chunkLen < actualLimit)
                                $ do chunkIsOver ← readTVar itrReqChunkIsOver
                                     unless chunkIsOver
                                         $ retry
                            -- 成功
                            chunk ← seqToLBS <$> readTVar itrReceivedBody
                            writeTVar itrReceivedBody    (∅)
                            writeTVar itrReceivedBodyLen 0
                            return chunk
               when (Lazy.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@ or @multipart\/form-data@. If
-- the request header \"Content-Type\" is neither of them, 'inputForm'
-- makes 'Resource' abort with status \"415 Unsupported Media
-- Type\". If the request has no \"Content-Type\", it aborts with
-- \"400 Bad Request\".
--
-- Field names in @multipart\/form-data@ will be precisely decoded in
-- accordance with RFC 2231. On the other hand,
-- @application\/x-www-form-urlencoded@ says nothing about the
-- encoding of field names, so they'll always be decoded in UTF-8.
inputForm ∷ Int → Resource [(Text, FormData)]
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" params)
               → readMultipartFormData params
           Just cType
               → abort UnsupportedMediaType []
                 $ Just
                 $ A.toText
                 $ A.fromAsciiBuilder
                 $ A.toAsciiBuilder "Unsupported media type: "
                 ⊕ printMIMEType cType
    where
      readWWWFormURLEncoded
          = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
            <$>
            (bsToAscii =≪ input limit)

      bsToAscii bs
          = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
              Just a  → return a
              Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")

      readMultipartFormData params
          = do case M.lookup "boundary" params of
                 Nothing
                     → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
                 Just boundary
                     → do src ← input limit
                          b   ← case A.fromText boundary of
                                   Just b  → return b
                                   Nothing → abort BadRequest []
                                             (Just $ "Malformed boundary: " ⊕ boundary)
                          case LP.parse (p b) src of
                            LP.Done _ formList
                                → return formList
                            _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
          where
            p b = do xs ← multipartFormP b
                     P.endOfInput
                     return xs

-- | 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 sc
    = do driftTo DecidingHeader
         itr ← getInteraction
         liftIO
             $ atomically
             $ setResponseStatus itr sc

-- | 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 ∷ CIAscii → Ascii → Resource ()
setHeader name value
    = driftTo DecidingHeader ≫ setHeader' name value

setHeader' ∷ CIAscii → Ascii → Resource ()
setHeader' name value
    = do itr ← getInteraction
         liftIO $ atomically
                $ do res ← readTVar $ itrResponse itr
                     let res' = H.setHeader name value res
                     writeTVar (itrResponse itr) res'

-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
-- 'isRedirection' or it causes an error.
redirect ∷ StatusCode → URI → Resource ()
redirect code uri
    = do when (code ≡ NotModified ∨ not (isRedirection code))
             $ abort InternalServerError []
             $ Just
             $ A.toText
             $ A.fromAsciiBuilder
             $ A.toAsciiBuilder "Attempted to redirect with status "
             ⊕ printStatusCode code
         setStatus code
         setLocation uri

-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType ∷ MIMEType → Resource ()
setContentType
    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType

-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
setLocation ∷ URI → Resource ()
setLocation uri
    = case A.fromChars uriStr of
        Just a  → setHeader "Location" a
        Nothing → abort InternalServerError []
                  (Just $ "Malformed URI: " ⊕ T.pack uriStr)
    where
      uriStr = uriToString id uri ""

-- |Computation of @'setContentEncoding' codings@ sets the response
-- header \"Content-Encoding\" to @codings@.
setContentEncoding ∷ [CIAscii] → Resource ()
setContentEncoding codings
    = do ver ← getRequestVersion
         tr  ← case ver of
                  HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                  HttpVersion 1 1 → return toAB
                  _               → abort InternalServerError []
                                    (Just "setContentEncoding: Unknown HTTP version")
         setHeader "Content-Encoding"
                   (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
    where
      toAB = A.toAsciiBuilder ∘ A.fromCIAscii

-- |Computation of @'setWWWAuthenticate' challenge@ sets the response
-- header \"WWW-Authenticate\" to @challenge@.
setWWWAuthenticate ∷ AuthChallenge → Resource ()
setWWWAuthenticate challenge
    = setHeader "WWW-Authenticate" (printAuthChallenge challenge)


{- DecidingBody 時に使用するアクション群 -}

-- | Write a 'Lazy.ByteString' to the response body, and then transit
-- to the /Done/ state. It is safe to apply 'output' to an infinite
-- string, such as the lazy stream of \/dev\/random.
output ∷ Lazy.ByteString → Resource ()
{-# INLINE output #-}
output str = outputChunk str *> driftTo Done

-- | Write a 'Lazy.ByteString' to the response body. This action can
-- be repeated as many times as you want. It is safe to apply
-- 'outputChunk' to an infinite string.
outputChunk ∷ Lazy.ByteString → Resource ()
outputChunk wholeChunk
    = do driftTo DecidingBody
         itr ← getInteraction
         
         let limit = cnfMaxOutputChunkLength $ itrConfig itr
         when (limit ≤ 0)
             $ abort InternalServerError []
               (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))

         discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
         unless (discardBody)
             $ sendChunks itr wholeChunk limit

         unless (Lazy.null wholeChunk)
             $ liftIO $ atomically $
               writeTVar (itrSentNoBodySoFar itr) False
    where
      sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
      sendChunks itr@(Interaction {..}) str limit
          | Lazy.null str = return ()
          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
                               liftIO $ atomically
                                      $ putTMVar itrBodyToSend (chunkToBuilder chunk)
                               sendChunks itr remaining limit

      chunkToBuilder ∷ Lazy.ByteString → Builder
      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks

{-

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


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

  postprocess する。


  [Done に遷移する時]

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

-}

driftTo ∷ InteractionState → Resource ()
driftTo newState
    = do itr ← getInteraction
         liftIO $ atomically
                $ do oldState ← readTVar $ itrState itr
                     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
                            writeTVar (itrState itr) 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 (Interaction {..}) GettingBody _
          = writeTVar itrReqBodyWasteAll True
      drift itr DecidingHeader _
          = postprocess itr
      drift itr@(Interaction {..}) _ Done
          = do bodyIsNull ← readTVar itrSentNoBodySoFar
               when bodyIsNull
                   $ writeDefaultPage itr
      drift _ _ _
          = return ()