Make use of mimeType quasi-quoter.

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 0dd73c96113971e2aa20d41f71eff4045bc1e6e6..704feda9c79ca2e5ab4619b1550166bdd8023f4c 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -3,15 +3,13 @@
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings

+  , QuasiQuotes

   , RecordWildCards
   , UnicodeSyntax
   #-}
   , 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.
+-- |This is the Resource Monad; monadic actions to define a behavior
+-- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
+-- implements 'MonadIO' class, and it is a state machine as well.

 -- 
 -- Request Processing Flow:
 --
 -- 
 -- Request Processing Flow:
 --


@@ -20,9 +18,9 @@
 --   2. If the URI of it matches to any resource, the corresponding
 --      'Resource' Monad starts running on a newly spawned thread.
 --
 --   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
+--   3. The 'Resource' Monad looks at request headers, find (or not
+--      find) an entity, receive the request body (if any), send
+--      response headers, and then send a response body. This process

 --      will be discussed later.
 --
 --   4. The 'Resource' Monad and its thread stops running. The client
 --      will be discussed later.
 --
 --   4. The 'Resource' Monad and its thread stops running. The client


@@ -32,29 +30,33 @@
 -- /Examining Request/ and the final state is /Done/.
 --
 --   [/Examining Request/] In this state, a 'Resource' looks at the
 -- /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.
+--   request header fields and thinks about the corresponding 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
+--   [/Receiving Body/] A 'Resource' asks the system to receive a
+--   request body from the 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
 --   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.
+--   receiving all or part of a request body, the system automatically
+--   discards it.

 --
 --

---   [/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 Header/] A 'Resource' makes a decision of response
+--   status code and header fields. When it transits to the next
+--   state, the system validates and completes the header fields and
+--   then sends them to the client.

 --
 --

---   [/Deciding Body/] In this state, a 'Resource' asks the system to
+--   [/Sending 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
 --   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.
+--   automatically completes it depending on the status code. (To be
+--   exact, such completion only occurs when the 'Resource' transits
+--   to this state without even declaring the \"Content-Type\" header
+--   field. See: 'setContentType')

 --
 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
 --   HTTP interaction anymore.
 --
 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
 --   HTTP interaction anymore.


@@ -65,20 +67,17 @@
 -- the entire request before starting 'Resource', nor we don't want to
 -- postpone writing the entire response till the end of 'Resource'
 -- computation.
 -- 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
 module Network.HTTP.Lucu.Resource
     (
     -- * Types
       Resource

+    , ResourceDef(..)
+    , emptyResource

     , FormData(..)
     , FormData(..)

-    , runRes -- private
-
-    -- * Actions

 
 

-    -- ** Getting request header
-
-    -- |These actions can be computed regardless of the current state,
-    -- and they don't change the state.
+    -- * Getting request header
+    -- |These functions can be called regardless of the current state,
+    -- and they don't change the state of 'Resource'.

     , getConfig
     , getRemoteAddr
     , getRemoteAddr'
     , getConfig
     , getRemoteAddr
     , getRemoteAddr'


@@ -98,148 +97,106 @@ module Network.HTTP.Lucu.Resource
     , getContentType
     , getAuthorization
 
     , 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.
+    -- * Finding an entity
+    -- |These functions can be called only in the /Examining Request/
+    -- state. They make the 'Resource' transit to the /Receiving Body/
+    -- state.

     , foundEntity
     , foundETag
     , foundTimeStamp
     , foundNoEntity
     , 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/.
+    , foundNoEntity'
+
+    -- * Receiving a request body
+    -- |These functions make the 'Resource' transit to the /Receiving
+    -- Body/ state.
+    , getChunk
+    , getChunks
+    , getForm
+
+    -- * Declaring response status and header fields
+    -- |These functions can be called at any time before transiting to
+    -- the /Sending Body/ state, but they themselves never causes any
+    -- state transitions.

     , setStatus
     , setStatus

-    , setHeader

     , redirect
     , setContentType
     , redirect
     , setContentType

-    , setLocation

     , setContentEncoding
     , setWWWAuthenticate
 
     , setContentEncoding
     , setWWWAuthenticate
 

-    -- ** Writing a response body
+    -- ** Less frequently used functions
+    , setLocation
+    , setHeader
+    , deleteHeader

 
 

-    -- |Computation of these actions changes the state to /Deciding
-    -- Body/.
-    , output
-    , outputChunk
+    -- * Sending a response body

 
 

-    , driftTo -- private
+    -- |These functions make the 'Resource' transit to the
+    -- /Sending Body/ state.
+    , putChunk
+    , putChunks
+    , putBuilder

     )
     where
 import Blaze.ByteString.Builder (Builder)
     )
     where
 import Blaze.ByteString.Builder (Builder)

-import qualified Blaze.ByteString.Builder.ByteString as BB
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Internal as BB

 import Control.Applicative
 import Control.Applicative

-import Control.Concurrent.STM
-import Control.Monad.Reader
+import Control.Arrow
+import Control.Monad
+import Control.Monad.IO.Class

 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.Attoparsec.Char8 as P
 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.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.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 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 Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Network.HTTP.Lucu.Abortion

-import Network.HTTP.Lucu.Authorization
+import Network.HTTP.Lucu.Authentication

 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.ContentCoding
 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.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.Parser

 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Request

+import Network.HTTP.Lucu.Resource.Internal

 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Response

-import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEParams
+import Network.HTTP.Lucu.MIMEType (MIMEType(..))
+import qualified Network.HTTP.Lucu.MIMEType as MT
+import Network.HTTP.Lucu.MIMEType.TH

 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)

-import OpenSSL.X509

 import Prelude.Unicode
 
 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
 -- |Get the string representation of the address of remote host. If

--- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
+-- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.

 getRemoteAddr' ∷ Resource HostName
 getRemoteAddr' ∷ Resource HostName

-getRemoteAddr'
-    = do sa          ← getRemoteAddr
-         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
-         return a
+getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
+    where
+      toNM ∷ SockAddr → IO HostName
+      toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False

 
 -- |Resolve an address to the remote host.
 getRemoteHost ∷ Resource (Maybe HostName)
 
 -- |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
-    = do itr ← getInteraction
-         liftIO $ atomically $ fromJust <$> readItr itrRequest itr
+getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
+    where
+      getHN ∷ SockAddr → IO (Maybe HostName)
+      getHN = (fst <$>) ∘ getNameInfo [] True False

 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method


@@ -253,52 +210,22 @@ getRequestURI = reqURI <$> getRequest
 getRequestVersion ∷ Resource HttpVersion
 getRequestVersion = reqVersion <$> getRequest
 
 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.
+-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
+-- @[]@ if the corresponding
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
+-- 'getResourcePath'

 --
 --

--- 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]
+-- Note that the returned path components are URI-decoded.
+getPathInfo ∷ Resource [Strict.ByteString]

 getPathInfo = do rsrcPath ← getResourcePath
                  reqPath  ← splitPathInfo <$> getRequestURI
 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
                  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)]
+-- application\/x-www-form-urlencoded, and parse it into pairs of
+-- @(name, formData)@. This function doesn't read the request
+-- body.
+getQueryForm ∷ Resource [(Strict.ByteString, FormData)]

 getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
 getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘


@@ -308,23 +235,25 @@ getQueryForm = parse' <$> getRequestURI
                drop 1 ∘
                uriQuery
 
                drop 1 ∘
                uriQuery
 

-toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
+toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)

 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing

+               , fdMIMEType = [mimeType| text/plain |]

                , fdContent  = Lazy.fromChunks [value]
                }
                , fdContent  = Lazy.fromChunks [value]
                }

-      in (T.decodeUtf8 name, fd)
+      in (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' name@ returns the value of the request header field
+-- @name@. Comparison of header name is case-insensitive. Note that
+-- this function is not intended to be used so frequently: there
+-- should be functions like 'getContentType' for every common headers.

 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest
 
 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest
 

--- |Get a list of 'MIMEType' enumerated on header \"Accept\".
+-- |Return the list of 'MIMEType' enumerated on the value of request
+-- header \"Accept\", or @[]@ if absent.

 getAccept ∷ Resource [MIMEType]
 getAccept
     = do acceptM ← getHeader "Accept"
 getAccept ∷ Resource [MIMEType]
 getAccept
     = do acceptM ← getHeader "Accept"


@@ -332,18 +261,14 @@ getAccept
            Nothing
                → return []
            Just accept
            Nothing
                → return []
            Just accept

-               → case P.parseOnly p (A.toByteString accept) of
+               → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of

                     Right xs → return xs
                     Right xs → return xs

-                    Left  _  → abort BadRequest []
-                               (Just $ "Unparsable Accept: " ⊕ A.toText accept)
-    where
-      p = do xs ← mimeTypeListP
-             P.endOfInput
-             return xs
+                    Left  _  → abort $ mkAbortion' BadRequest
+                                     $ "Unparsable Accept: " ⊕ A.toText accept

 
 

--- |Get a list of @(contentCoding, qvalue)@ enumerated on header
--- \"Accept-Encoding\". The list is sorted in descending order by
--- qvalue.
+-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
+-- value of request header \"Accept-Encoding\". The list is sorted in
+-- descending order by qvalue.

 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 getAcceptEncoding
     = do accEncM ← getHeader "Accept-Encoding"
 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 getAcceptEncoding
     = do accEncM ← getHeader "Accept-Encoding"


@@ -357,33 +282,30 @@ getAcceptEncoding
                     case ver of
                       HttpVersion 1 0 → return [("identity", Nothing)]
                       HttpVersion 1 1 → return [("*"       , Nothing)]
                     case ver of
                       HttpVersion 1 0 → return [("identity", Nothing)]
                       HttpVersion 1 1 → return [("*"       , Nothing)]

-                      _               → abort InternalServerError []
-                                        (Just "getAcceptEncoding: unknown HTTP version")
+                      _               → abort $ mkAbortion' InternalServerError
+                                                "getAcceptEncoding: unknown HTTP version"

            Just ae
                → if ae ≡ "" then
                       -- identity のみが許される。
                       return [("identity", Nothing)]
            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)
+                 else
+                     case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
+                       Right xs → return $ map toTuple $ reverse $ sort xs
+                       Left  _  → abort $ mkAbortion' BadRequest
+                                        $ "Unparsable Accept-Encoding: " ⊕ A.toText ae

     where
     where

-      p = do xs ← acceptEncodingListP
-             P.endOfInput
-             return xs
-

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

--- |Check whether a given content-coding is acceptable.
+-- |Return 'True' iff a given content-coding is acceptable by the
+-- client.

 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable ∷ CIAscii → Resource Bool

-isEncodingAcceptable encoding = any f <$> getAcceptEncoding
+isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding

     where
     where

-      f (e, q)
-          = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
+      doesMatch ∷ (CIAscii, Maybe Double) → Bool
+      doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0

 
 

--- |Get the header \"Content-Type\" as 'MIMEType'.
+-- |Return the value of request header \"Content-Type\" as 'MIMEType'.

 getContentType ∷ Resource (Maybe MIMEType)
 getContentType
     = do cTypeM ← getHeader "Content-Type"
 getContentType ∷ Resource (Maybe MIMEType)
 getContentType
     = do cTypeM ← getHeader "Content-Type"


@@ -391,16 +313,13 @@ getContentType
            Nothing
                → return Nothing
            Just cType
            Nothing
                → return Nothing
            Just cType

-               → case P.parseOnly p (A.toByteString cType) of
+               → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of

                     Right t → return $ Just t
                     Right t → return $ Just t

-                    Left  _ → abort BadRequest []
-                              (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
-    where
-      p = do t ← mimeTypeP
-             P.endOfInput
-             return t
+                    Left  _ → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable Content-Type: " ⊕ A.toText cType

 
 

--- |Get the header \"Authorization\" as 'AuthCredential'.
+-- |Return the value of request header \"Authorization\" as
+-- 'AuthCredential'.

 getAuthorization ∷ Resource (Maybe AuthCredential)
 getAuthorization
     = do authM ← getHeader "Authorization"
 getAuthorization ∷ Resource (Maybe AuthCredential)
 getAuthorization
     = do authM ← getHeader "Authorization"


@@ -408,79 +327,80 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
            Nothing
                → return Nothing
            Just auth

-               → case P.parseOnly p (A.toByteString auth) of
+               → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of

                     Right ac → return $ Just ac
                     Left  _  → return Nothing
                     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
 
 -- |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.
+-- a datum which was stored for the URI until now. For POST requests
+-- it raises an error.

 --
 --

--- 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.
+-- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
+-- whenever possible, and if those tests fail, it 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.
+-- If the request method is either GET or HEAD, 'foundEntity'
+-- automatically puts \"ETag\" and \"Last-Modified\" headers into the
+-- response.

 foundEntity ∷ ETag → UTCTime → Resource ()
 foundEntity ∷ ETag → UTCTime → Resource ()

-foundEntity !tag !timeStamp
+foundEntity tag timeStamp

     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)

-             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)

          when (method ≡ POST)
          when (method ≡ POST)

-             $ abort InternalServerError []
-               (Just "Illegal computation of foundEntity for a POST request.")
+             $ abort
+             $ mkAbortion' InternalServerError
+               "foundEntity: this is a POST request."

          foundETag tag
 
          foundETag tag
 

-         driftTo GettingBody
+         driftTo ReceivingBody

 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. The only difference from 'foundEntity' is that
 
 -- |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
+-- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into

 -- the response.
 --
 -- the response.
 --

--- This action is not preferred. You should use 'foundEntity' whenever
--- possible.
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.

 foundETag ∷ ETag → Resource ()
 foundETag ∷ ETag → Resource ()

-foundETag !tag
+foundETag tag

     = do driftTo ExaminingRequest
       
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
     = do driftTo ExaminingRequest
       
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)

-              $ setHeader' "ETag" (printETag tag)
+             $ setHeader "ETag"
+             $ A.fromAsciiBuilder
+             $ printETag tag

          when (method ≡ POST)
          when (method ≡ POST)

-              $ abort InternalServerError []
-                (Just "Illegal computation of foundETag for POST request.")
+             $ abort
+             $ mkAbortion' InternalServerError
+               "Illegal computation of foundETag for POST request."

 
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"
          case ifMatch of
 
          -- 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)
+           Nothing
+               → return ()
+           Just value
+               → if value ≡ "*" then
+                      return ()
+                  else
+                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                        Right tags
+                            -- tags の中に一致するものが無ければ
+                            -- PreconditionFailed で終了。
+                            → when ((¬) (any (≡ tag) tags))
+                                  $ abort
+                                  $ mkAbortion' PreconditionFailed
+                                  $ "The entity tag doesn't match: " ⊕ A.toText value
+                        Left _
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable If-Match: " ⊕ A.toText value

 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then


@@ -491,45 +411,46 @@ foundETag !tag
          -- If-None-Match があればそれを見る。
          ifNoneMatch ← getHeader "If-None-Match"
          case ifNoneMatch of
          -- 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
+           Nothing
+               → return ()
+           Just value
+               → if value ≡ "*" then
+                      abort $ mkAbortion' statusForNoneMatch
+                            $ "The entity tag matches: *"
+                  else
+                      case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+                        Right tags
+                            → when (any (≡ tag) tags)
+                                  $ abort
+                                  $ mkAbortion' statusForNoneMatch
+                                  $ "The entity tag matches: " ⊕ A.toText value
+                        Left _
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+
+         driftTo ReceivingBody

 
 -- |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
 
 -- |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
+-- \"If-None-Match\" test. Be aware that any tests based on a last

 -- modification time are unsafe because it is possible to mess up such
 -- tests by modifying the entity twice in a second.
 --
 -- 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.
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.

 foundTimeStamp ∷ UTCTime → Resource ()
 foundTimeStamp timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
 foundTimeStamp ∷ UTCTime → Resource ()
 foundTimeStamp timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)

-             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)

          when (method ≡ POST)
          when (method ≡ POST)

-             $ abort InternalServerError []
-               (Just "Illegal computation of foundTimeStamp for POST request.")
+             $ abort
+             $ mkAbortion' InternalServerError
+               "Illegal computation of foundTimeStamp for POST request."

 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then
 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then


@@ -543,8 +464,9 @@ foundTimeStamp timeStamp
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp ≤ lastTime)
            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)
+                               $ abort
+                               $ mkAbortion' statusForIfModSince
+                               $ "The entity has not been modified since " ⊕ A.toText str

                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()


@@ -555,21 +477,22 @@ foundTimeStamp timeStamp
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp > lastTime)
            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)
+                               $ abort
+                               $ mkAbortion' PreconditionFailed
+                               $ "The entity has not been modified since " ⊕ A.toText str

                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
 
                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
 

-         driftTo GettingBody
+         driftTo ReceivingBody

 
 

--- | 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.
+-- |@'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,
+-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
+-- test and when that fails it aborts with status \"412 Precondition
+-- Failed\". If the request method is GET, HEAD, POST or DELETE,

 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 foundNoEntity ∷ Maybe Text → Resource ()
 foundNoEntity msgM
 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 foundNoEntity ∷ Maybe Text → Resource ()
 foundNoEntity msgM


@@ -577,264 +500,123 @@ foundNoEntity msgM
 
          method ← getMethod
          when (method ≢ PUT)
 
          method ← getMethod
          when (method ≢ PUT)

-             $ abort NotFound [] msgM
+             $ abort
+             $ mkAbortion NotFound [] msgM

 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- If-Match: 條件も滿たさない。
          ifMatch ← getHeader "If-Match"
          when (ifMatch ≢ Nothing)
 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- 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.
+             $ abort
+             $ mkAbortion PreconditionFailed [] msgM
+
+         driftTo ReceivingBody
+
+-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
+foundNoEntity' ∷ Resource ()
+{-# INLINE foundNoEntity' #-}
+foundNoEntity' = foundNoEntity Nothing
+
+-- |@'getChunks' limit@ attemts to read the entire request body up to
+-- @limit@ bytes, and then make the 'Resource' transit to the
+-- /Deciding Header/ state. When the actual size of the body is larger
+-- than @limit@ bytes, 'getChunks' immediately aborts with status
+-- \"413 Request Entity Too Large\". When the request has no body, it
+-- 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'.
+-- When the @limit@ is 'Nothing', 'getChunks' uses the default
+-- limitation value ('cnfMaxEntityLength') instead.

 --
 --

--- '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
-         hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
-         chunk   ← if hasBody then
-                       askForInput itr
-                   else
-                       do driftTo DecidingHeader
-                          return (∅)
-         return chunk
+-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
+-- lazy: reading from the socket just happens at the computation of
+-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
+getChunks ∷ Maybe Int → Resource Lazy.ByteString
+getChunks (Just n)
+    | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
+    | n ≡ 0     = return (∅)
+    | otherwise = getChunks' n
+getChunks Nothing
+    = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
+
+getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' limit = go limit (∅)

     where
     where

-      askForInput ∷ Interaction → Resource Lazy.ByteString
-      askForInput itr
-          = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
-                   actualLimit = if limit ≤ 0 then
-                                     confLimit
-                                 else
-                                     limit
-               when (actualLimit ≤ 0)
-                        $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-               -- Reader にリクエスト
-               liftIO $ atomically
-                      $ do chunkLen ← readItr itrReqChunkLength itr
-                           writeItr itrWillReceiveBody True itr
-                           if ((> actualLimit) <$> chunkLen) ≡ Just True then
-                               -- 受信前から多過ぎる事が分かってゐる
-                               tooLarge actualLimit
-                           else
-                               writeItr itrReqBodyWanted (Just actualLimit) itr
-               -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
-               chunk ← liftIO $ atomically
-                       $ do chunkLen    ← readItr itrReceivedBodyLen itr
-                            chunkIsOver ← readItr itrReqChunkIsOver  itr
-                            if chunkLen < actualLimit then
-                                -- 要求された量に滿たなくて、まだ殘りが
-                                -- あるなら再試行。
-                                unless chunkIsOver
-                                    $ retry
-                            else
-                                -- 制限値一杯まで讀むやうに指示したのに
-                                -- まだ殘ってゐるなら、それは多過ぎる。
-                                unless chunkIsOver
-                                    $ tooLarge actualLimit
-                            -- 成功。itr 内にチャンクを置いたままにする
-                            -- とメモリの無駄になるので除去。
-                            chunk ← seqToLBS <$> readItr itrReceivedBody itr
-                            writeItr itrReceivedBody    (∅) itr
-                            writeItr itrReceivedBodyLen 0   itr
-                            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
-         hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
-         chunk   ← if hasBody then
-                        askForInput itr
+      go ∷ Int → Builder → Resource Lazy.ByteString
+      go  0  _ = do chunk ← getChunk 1
+                    if Strict.null chunk then
+                        return (∅)

                     else
                     else

-                        do driftTo DecidingHeader
-                           return (∅)
-         return chunk
-    where
-      askForInput ∷ Interaction → Resource Lazy.ByteString
-      askForInput itr
-          = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
-                   actualLimit = if limit < 0 then
-                                      confLimit
-                                  else
-                                      limit
-               when (actualLimit <= 0)
-                        $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-               -- Reader にリクエスト
-               liftIO $ atomically
-                      $ do writeItr itrReqBodyWanted (Just actualLimit) itr
-                           writeItr itrWillReceiveBody True itr
-               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
-               chunk ← liftIO $ atomically
-                       $ do chunkLen ← readItr itrReceivedBodyLen itr
-                            -- 要求された量に滿たなくて、まだ殘りがある
-                            -- なら再試行。
-                            when (chunkLen < actualLimit)
-                                $ do chunkIsOver ← readItr itrReqChunkIsOver itr
-                                     unless chunkIsOver
-                                         $ retry
-                            -- 成功
-                            chunk ← seqToLBS <$> readItr itrReceivedBody itr
-                            writeItr itrReceivedBody    (∅) itr
-                            writeItr itrReceivedBodyLen 0   itr
-                            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\".
+                        abort $ mkAbortion' RequestEntityTooLarge
+                              $ "Request body must be smaller than "
+                              ⊕ T.pack (show limit)
+                              ⊕ " bytes."
+      go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
+                    if Strict.null c then
+                        -- Got EOF
+                        return $ BB.toLazyByteString b
+                    else
+                        do let n'  = n - Strict.length c
+                               xs' = b ⊕ BB.fromByteString c
+                           go n' xs'
+
+-- |@'getForm' limit@ attempts to read the request body with
+-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
+-- @multipart\/form-data@. If the request header \"Content-Type\" is
+-- neither of them, 'getForm' aborts 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
+-- Note that there are currently a few limitations on parsing
+-- @multipart/form-data@. See: 'parseMultipartFormData'
+getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
+getForm limit

     = do cTypeM ← getContentType
          case cTypeM of
            Nothing
     = do cTypeM ← getContentType
          case cTypeM of
            Nothing

-               → abort BadRequest [] (Just "Missing Content-Type")
+               → abort $ mkAbortion' BadRequest "Missing Content-Type"

            Just (MIMEType "application" "x-www-form-urlencoded" _)
                → readWWWFormURLEncoded
            Just (MIMEType "multipart" "form-data" params)
                → readMultipartFormData params
            Just cType
            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
+               → abort $ mkAbortion' UnsupportedMediaType
+                       $ A.toText
+                       $ A.fromAsciiBuilder
+                       $ A.toAsciiBuilder "Unsupported media type: "
+                       ⊕ MT.printMIMEType cType

     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
             <$>
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
             <$>

-            (bsToAscii =≪ input limit)
+            (bsToAscii =≪ getChunks limit)

 
       bsToAscii bs
           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
               Just a  → return a
 
       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 code
-    = do driftTo DecidingHeader
-         itr ← getInteraction
-         liftIO $ atomically $ updateItr itrResponse f itr
-    where
-      f 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 ∷ CIAscii → Ascii → Resource ()
-setHeader name value
-    = driftTo DecidingHeader ≫ setHeader' name value
-
-setHeader' ∷ CIAscii → Ascii → Resource ()
-setHeader' name value
-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ updateItr itrResponse (H.setHeader name value) itr
-
--- | 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.
+              Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
+
+      readMultipartFormData (MIMEParams m)
+          = case M.lookup "boundary" m of
+              Nothing
+                  → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
+              Just boundary
+                  → do src ← getChunks limit
+                       b   ← case A.fromText boundary of
+                                Just b  → return b
+                                Nothing → abort $ mkAbortion' BadRequest
+                                                $ "Malformed boundary: " ⊕ boundary
+                       case parseMultipartFormData b src of
+                         Right xs → return $ map (first A.toByteString) xs
+                         Left err → abort $ mkAbortion' BadRequest $ T.pack err
+
+-- |@'redirect' code uri@ declares the response status as @code@ and
+-- \"Location\" header field as @uri@. The @code@ must satisfy
+-- 'isRedirection' or it raises an error.

 redirect ∷ StatusCode → URI → Resource ()
 redirect code uri
     = do when (code ≡ NotModified ∨ not (isRedirection code))
 redirect ∷ StatusCode → URI → Resource ()
 redirect code uri
     = do when (code ≡ NotModified ∨ not (isRedirection code))

-             $ abort InternalServerError []
-             $ Just
+             $ abort
+             $ mkAbortion' InternalServerError

              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "


@@ -842,144 +624,58 @@ redirect code uri
          setStatus code
          setLocation uri
 
          setStatus code
          setLocation uri
 

--- | Computation of @'setContentType' mType@ sets the response header
--- \"Content-Type\" to @mType@.
+-- |@'setContentType' mType@ declares the response header
+-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
+-- mandatory for sending a response body.

 setContentType ∷ MIMEType → Resource ()
 setContentType
 setContentType ∷ MIMEType → Resource ()
 setContentType

-    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType

 
 

--- | Computation of @'setLocation' uri@ sets the response header
--- \"Location\" to @uri@.
+-- |@'setLocation' uri@ declares the response header \"Location\" as
+-- @uri@. You usually don't need to call this function directly.

 setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a
 setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a

-        Nothing → abort InternalServerError []
-                  (Just $ "Malformed URI: " ⊕ T.pack uriStr)
+        Nothing → abort $ mkAbortion' InternalServerError
+                        $ "Malformed URI: " ⊕ T.pack uriStr

     where
       uriStr = uriToString id uri ""
 
     where
       uriStr = uriToString id uri ""
 

--- |Computation of @'setContentEncoding' codings@ sets the response
--- header \"Content-Encoding\" to @codings@.
+-- |@'setContentEncoding' codings@ declares the response header
+-- \"Content-Encoding\" as @codings@.

 setContentEncoding ∷ [CIAscii] → Resource ()
 setContentEncoding codings
     = do ver ← getRequestVersion
          tr  ← case ver of
                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                   HttpVersion 1 1 → return toAB
 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")
+                  _               → abort $ mkAbortion' InternalServerError
+                                            "setContentEncoding: Unknown HTTP version"

          setHeader "Content-Encoding"
          setHeader "Content-Encoding"

-                   (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
+             $ A.fromAsciiBuilder
+             $ mconcat
+             $ intersperse (A.toAsciiBuilder ", ")
+             $ map tr codings

     where
       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 
     where
       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 

--- |Computation of @'setWWWAuthenticate' challenge@ sets the response
--- header \"WWW-Authenticate\" to @challenge@.
+-- |@'setWWWAuthenticate' challenge@ declares the response header
+-- \"WWW-Authenticate\" as @challenge@.

 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 setWWWAuthenticate ∷ AuthChallenge → Resource ()

-setWWWAuthenticate challenge
-    = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
-
-
-{- 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.
-output ∷ Lazy.ByteString → Resource ()
-{-# INLINE output #-}
-output str = outputChunk 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.
-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 $
-                       readItr itrWillDiscardBody itr
-
-         unless (discardBody)
-             $ sendChunks wholeChunk limit
-
-         unless (Lazy.null wholeChunk)
-             $ liftIO $ atomically $
-               writeItr itrSentNoBody False itr
-    where
-      sendChunks ∷ Lazy.ByteString → Int → Resource ()
-      sendChunks str limit
-          | Lazy.null str = return ()
-          | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
-                               itr ← getInteraction
-                               liftIO $ atomically
-                                      $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
-                               sendChunks remaining limit
-
-      chunkToBuilder ∷ Lazy.ByteString → Builder
-      chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
-
-{-
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge

 
 

-  [GettingBody からそれ以降の状態に遷移する時]
-  
-  body を讀み終へてゐなければ、殘りの body を讀み捨てる。
+-- |Write a chunk in 'Strict.ByteString' to the response body. You
+-- must first declare the response header \"Content-Type\" before
+-- applying this function. See: 'setContentType'
+putChunk ∷ Strict.ByteString → Resource ()
+putChunk = putBuilder ∘ BB.fromByteString

 
 

-
-  [DecidingHeader からそれ以降の状態に遷移する時]
-
-  postprocess する。
-
-
-  [Done に遷移する時]
-
-  bodyIsNull が False ならば何もしない。True だった場合は出力補完す
-  る。
-
--}
-
-driftTo ∷ InteractionState → Resource ()
-driftTo newState
-    = do itr ← getInteraction
-         liftIO $ atomically $ do oldState ← readItr 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
-                                         writeItr itrState newState itr
-    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 itrReqBodyWasteAll True itr
-
-      drift itr DecidingHeader _
-          = postprocess itr
-
-      drift itr _ Done
-          = do bodyIsNull ← readItr itrSentNoBody itr
-               when bodyIsNull
-                   $ writeDefaultPage itr
-
-      drift _ _ _
-          = return ()
+-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
+-- can be safely applied to an infinitely long 'Lazy.ByteString'.
+--
+-- Note that you must first declare the response header
+-- \"Content-Type\" before applying this function. See:
+-- 'setContentType'
+putChunks ∷ Lazy.ByteString → Resource ()
+putChunks = putBuilder ∘ BB.fromLazyByteString