Code clean-up using convertible-text

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 71ff4838c3945380d44f2dee36fddc2b3952d3d1..6f3ecce8b851e8526e1f5eb48f6bf255656533ab 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,13 +1,15 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    BangPatterns
+    CPP
+  , BangPatterns

   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings

+  , QuasiQuotes

   , RecordWildCards
   , UnicodeSyntax
   #-}
 -- |This is the Resource Monad; monadic actions to define a behavior
   , RecordWildCards
   , UnicodeSyntax
   #-}
 -- |This is the Resource Monad; monadic actions to define a behavior

--- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
+-- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it

 -- implements 'MonadIO' class, and it is a state machine as well.
 -- 
 -- Request Processing Flow:
 -- implements 'MonadIO' class, and it is a state machine as well.
 -- 
 -- Request Processing Flow:


@@ -15,73 +17,73 @@
 --   1. A client issues an HTTP request.
 --
 --   2. If the URI of it matches to any resource, the corresponding
 --   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.
+--      'Rsrc' Monad starts running on a newly spawned thread.

 --
 --

---   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.
+--   3. The 'Rsrc' 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
---      may or may not be sending us the next request at this point.
+--   4. The 'Rsrc' 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
+-- 'Rsrc' Monad takes the following states. The initial state is

 -- /Examining Request/ and the final state is /Done/.
 --
 -- /Examining Request/ and the final state is /Done/.
 --

---   [/Examining Request/] In this state, a 'Resource' looks at the
+--   [/Examining Request/] In this state, a 'Rsrc' looks at the

 --   request header fields and thinks about the corresponding entity
 --   request header fields and thinks about the corresponding entity

---   for it. If there is a suitable entity, the 'Resource' tells the
+--   for it. If there is a suitable entity, the 'Rsrc' 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,
 --   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.
+--   'Rsrc' does nothing in this state.

 --
 --

---   [/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
---   receiving all or part of a request body, the system automatically
---   discards it.
+--   [/Receiving Body/] A 'Rsrc' 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 'Rsrc' transits to the next state without receiving all or part
+--   of a request body, the system automatically discards it.

 --
 --

---   [/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 Header/] A 'Rsrc' 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.

 --
 --

---   [/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
---   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'.)
+--   [/Sending Body/] In this state, a 'Rsrc' 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 automatically
+--   completes it depending on the status code. (To be exact, such
+--   completion only occurs when the 'Rsrc' 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 'Rsrc' 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
 --
 -- 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'
+-- the entire request before starting 'Rsrc', nor we don't want to
+-- postpone writing the entire response till the end of 'Rsrc'

 -- computation.
 module Network.HTTP.Lucu.Resource
     (
     -- * Types
 -- computation.
 module Network.HTTP.Lucu.Resource
     (
     -- * Types

-      Resource
-    , ResourceDef(..)
-    , emptyResource
+      Resource(..)
+    , Rsrc

     , FormData(..)
 
     -- * Getting request header
     -- |These functions can be called regardless of the current state,
     , FormData(..)
 
     -- * Getting request header
     -- |These functions can be called regardless of the current state,

-    -- and they don't change the state of 'Resource'.
+    -- and they don't change the state of 'Rsrc'.

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

+#if defined(HAVE_SSL)

     , getRemoteCertificate
     , getRemoteCertificate

+#endif

     , getRequest
     , getMethod
     , getRequestURI
     , getRequest
     , getMethod
     , getRequestURI


@@ -98,7 +100,7 @@ module Network.HTTP.Lucu.Resource
 
     -- * Finding an entity
     -- |These functions can be called only in the /Examining Request/
 
     -- * Finding an entity
     -- |These functions can be called only in the /Examining Request/

-    -- state. They make the 'Resource' transit to the /Receiving Body/
+    -- state. They make the 'Rsrc' transit to the /Receiving Body/

     -- state.
     , foundEntity
     , foundETag
     -- state.
     , foundEntity
     , foundETag


@@ -107,7 +109,7 @@ module Network.HTTP.Lucu.Resource
     , foundNoEntity'
 
     -- * Receiving a request body
     , foundNoEntity'
 
     -- * Receiving a request body

-    -- |These functions make the 'Resource' transit to the /Receiving
+    -- |These functions make the 'Rsrc' transit to the /Receiving

     -- Body/ state.
     , getChunk
     , getChunks
     -- Body/ state.
     , getChunk
     , getChunks


@@ -130,8 +132,8 @@ module Network.HTTP.Lucu.Resource
 
     -- * Sending a response body
 
 
     -- * Sending a response body
 

-    -- |These functions make the 'Resource' transit to the
-    -- /Sending Body/ state.
+    -- |These functions make the 'Rsrc' transit to the /Sending Body/
+    -- state.

     , putChunk
     , putChunks
     , putBuilder
     , putChunk
     , putChunks
     , putBuilder


@@ -141,26 +143,29 @@ import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder as BB
 import qualified Blaze.ByteString.Builder.Internal as BB
 import Control.Applicative
 import qualified Blaze.ByteString.Builder as BB
 import qualified Blaze.ByteString.Builder.Internal as BB
 import Control.Applicative

+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 Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A

+import Data.Attempt

 import qualified Data.Attoparsec.Char8 as P
 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.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.Convertible.Base
+import Data.List (intersperse, sort)

 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode

+import Data.Proxy
+import Data.Tagged

 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 Data.Time

-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP

 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Authentication
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Authentication
 import Network.HTTP.Lucu.Config


@@ -170,57 +175,61 @@ 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.HttpVersion
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.MultipartForm

+import Network.HTTP.Lucu.Parser

 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response

-import Network.HTTP.Lucu.MIMEType
+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 Prelude hiding (any, drop, lookup, reverse)

 import Prelude.Unicode
 
 -- |Get the string representation of the address of remote host. If
 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 import Prelude.Unicode
 
 -- |Get the string representation of the address of remote host. If
 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.

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

 
 -- |Resolve an address to the remote host.
 
 -- |Resolve an address to the remote host.

-getRemoteHost ∷ Resource (Maybe HostName)
-getRemoteHost
-    = do sa ← getRemoteAddr
-         fst <$> (liftIO $ getNameInfo [] True False sa)
+getRemoteHost ∷ Rsrc (Maybe HostName)
+getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
+    where
+      getHN ∷ SockAddr → IO (Maybe HostName)
+      getHN = (fst <$>) ∘ getNameInfo [] True False

 
 -- |Get the 'Method' value of the request.
 
 -- |Get the 'Method' value of the request.

-getMethod ∷ Resource Method
+getMethod ∷ Rsrc Method

 getMethod = reqMethod <$> getRequest
 
 -- |Get the URI of the request.
 getMethod = reqMethod <$> getRequest
 
 -- |Get the URI of the request.

-getRequestURI ∷ Resource URI
+getRequestURI ∷ Rsrc URI

 getRequestURI = reqURI <$> getRequest
 
 -- |Get the HTTP version of the request.
 getRequestURI = reqURI <$> getRequest
 
 -- |Get the HTTP version of the request.

-getRequestVersion ∷ Resource HttpVersion
+getRequestVersion ∷ Rsrc HttpVersion

 getRequestVersion = reqVersion <$> getRequest
 
 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 getRequestVersion = reqVersion <$> getRequest
 
 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns

--- @[]@ if the corresponding
--- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
+-- @[]@ if the corresponding 'Resource' is not greedy. See

 -- 'getResourcePath'.
 --
 -- Note that the returned path components are URI-decoded.
 -- 'getResourcePath'.
 --
 -- Note that the returned path components are URI-decoded.

-getPathInfo ∷ Resource [Strict.ByteString]
+getPathInfo ∷ Rsrc [Strict.ByteString]

 getPathInfo = do rsrcPath ← getResourcePath
 getPathInfo = do rsrcPath ← getResourcePath

-                 reqPath  ← splitPathInfo <$> getRequestURI
+                 reqPath  ← uriPathSegments <$> getRequestURI

                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request

--- body. Field names are decoded in UTF-8 for an hardly avoidable
--- reason. See 'getForm'.
-getQueryForm ∷ Resource [(Text, FormData)]
+-- body.
+getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]

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


@@ -230,44 +239,41 @@ 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)

 
 -- |@'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' 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 ∷ CIAscii → Rsrc (Maybe Ascii)

 getHeader name
     = H.getHeader name <$> getRequest
 
 -- |Return the list of 'MIMEType' enumerated on the value of request
 -- header \"Accept\", or @[]@ if absent.
 getHeader name
     = H.getHeader name <$> getRequest
 
 -- |Return the list of 'MIMEType' enumerated on the value of request
 -- header \"Accept\", or @[]@ if absent.

-getAccept ∷ Resource [MIMEType]
+getAccept ∷ Rsrc [MIMEType]

 getAccept
     = do acceptM ← getHeader "Accept"
          case acceptM of
            Nothing
                → return []
            Just accept
 getAccept
     = do acceptM ← getHeader "Accept"
          case acceptM of
            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
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept

-    where
-      p = do xs ← mimeTypeListP
-             P.endOfInput
-             return xs

 
 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 -- value of request 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 ∷ Rsrc [(CIAscii, Maybe Double)]

 getAcceptEncoding
     = do accEncM ← getHeader "Accept-Encoding"
          case accEncM of
 getAcceptEncoding
     = do accEncM ← getHeader "Accept-Encoding"
          case accEncM of


@@ -287,65 +293,53 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else

-                     case P.parseOnly p (A.toByteString ae) of
+                     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
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where

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

       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
 -- |Return 'True' iff a given content-coding is acceptable by the
 -- client.
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
 -- |Return 'True' iff a given content-coding is acceptable by the
 -- client.

-isEncodingAcceptable ∷ CIAscii → Resource Bool
+isEncodingAcceptable ∷ CIAscii → Rsrc Bool

 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where
       doesMatch ∷ (CIAscii, Maybe Double) → Bool
       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 
 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where
       doesMatch ∷ (CIAscii, Maybe Double) → Bool
       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 
 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.

-getContentType ∷ Resource (Maybe MIMEType)
+getContentType ∷ Rsrc (Maybe MIMEType)

 getContentType
     = do cTypeM ← getHeader "Content-Type"
          case cTypeM of
            Nothing
                → return Nothing
            Just cType
 getContentType
     = do cTypeM ← getHeader "Content-Type"
          case cTypeM of
            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
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType

-    where
-      p = do t ← mimeTypeP
-             P.endOfInput
-             return t

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

-getAuthorization ∷ Resource (Maybe AuthCredential)
+getAuthorization ∷ Rsrc (Maybe AuthCredential)

 getAuthorization
     = do authM ← getHeader "Authorization"
          case authM of
            Nothing
                → return Nothing
            Just auth
 getAuthorization
     = do authM ← getHeader "Authorization"
          case authM of
            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
-
--- |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. For POST requests
--- it raises an error.
+
+-- |Tell the system that the 'Rsrc' 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. For POST requests it raises
+-- an error.

 --
 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
 -- whenever possible, and if those tests fail, it immediately aborts
 --
 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
 -- whenever possible, and if those tests fail, it immediately aborts


@@ -355,13 +349,15 @@ getAuthorization
 -- If the request method is either GET or HEAD, '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 → Rsrc ()

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

-             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified"
+             $ flip proxy http
+             $ cs timeStamp

          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError


@@ -370,14 +366,13 @@ foundEntity tag timeStamp
 
          driftTo ReceivingBody
 
 
          driftTo ReceivingBody
 

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

 --
 -- Using this function is discouraged. You should use 'foundEntity'
 -- whenever possible.
 --
 -- Using this function is discouraged. You should use 'foundEntity'
 -- whenever possible.

-foundETag ∷ ETag → Resource ()
+foundETag ∷ ETag → Rsrc ()

 foundETag tag
     = do driftTo ExaminingRequest
       
 foundETag tag
     = do driftTo ExaminingRequest
       


@@ -385,7 +380,7 @@ foundETag tag
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
              $ A.fromAsciiBuilder
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "ETag"
              $ A.fromAsciiBuilder

-             $ printETag tag
+             $ cs tag

          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError


@@ -394,53 +389,53 @@ foundETag tag
          -- 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
-                                        $ mkAbortion' PreconditionFailed
-                                        $ "The entity tag doesn't match: " ⊕ A.toText value
-                              Left _
-                                  → abort $ mkAbortion' BadRequest
-                                          $ "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

-                       NotModified
+                       fromStatusCode NotModified

                    else
                    else

-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed

 
          -- 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 $ mkAbortion' statusForNoneMatch
-                                  $ "The entity tag matches: *"
-                        else
-                            case P.parseOnly p (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
+           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
 
          driftTo ReceivingBody

-    where
-      p = do xs ← eTagListP
-             P.endOfInput
-             return xs

 
 

--- |Tell the system that the 'Resource' found an entity for the
+-- |Tell the system that the 'Rsrc' 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
 -- 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


@@ -450,61 +445,63 @@ foundETag tag
 --
 -- Using this function is discouraged. You should use 'foundEntity'
 -- whenever possible.
 --
 -- Using this function is discouraged. You should use 'foundEntity'
 -- whenever possible.

-foundTimeStamp ∷ UTCTime → Resource ()
+foundTimeStamp ∷ UTCTime → Rsrc ()

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

-             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified"
+             $ flip proxy http
+             $ cs timeStamp

          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError

-               "Illegal computation of foundTimeStamp for POST request."
+               "Illegal call of foundTimeStamp for POST request."

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

-                       NotModified
+                       fromStatusCode NotModified

                    else
                    else

-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed

 
 

-         -- If-Modified-Since があればそれを見る。

          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of
          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of

-           Just str → case HTTP.fromAscii str of
-                         Right lastTime
+           Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+                         Just lastTime

                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince
                                $ "The entity has not been modified since " ⊕ A.toText str
                              → when (timeStamp ≤ lastTime)
                                $ abort
                                $ mkAbortion' statusForIfModSince
                                $ "The entity has not been modified since " ⊕ A.toText str

-                         Left _
-                             → return () -- 不正な時刻は無視
+                         Nothing
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Malformed If-Modified-Since: " ⊕ A.toText str

            Nothing  → return ()
 
            Nothing  → return ()
 

-         -- If-Unmodified-Since があればそれを見る。

          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of
          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of

-           Just str → case HTTP.fromAscii str of
-                         Right lastTime
+           Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+                         Just lastTime

                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed
                                $ "The entity has not been modified since " ⊕ A.toText str
                              → when (timeStamp > lastTime)
                                $ abort
                                $ mkAbortion' PreconditionFailed
                                $ "The entity has not been modified since " ⊕ A.toText str

-                         Left _
-                             → return () -- 不正な時刻は無視
+                         Nothing
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Malformed If-Unmodified-Since: " ⊕ A.toText str

            Nothing  → return ()
 
          driftTo ReceivingBody
 
            Nothing  → return ()
 
          driftTo ReceivingBody
 

--- |@'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 'Rsrc' found no
+-- entity for the request URI. @mStr@ is an optional error message to
+-- be replied to the client.

 --
 -- 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\".
 --
 -- 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 ∷ Maybe Text → Rsrc ()

 foundNoEntity msgM
     = do driftTo ExaminingRequest
 
 foundNoEntity msgM
     = do driftTo ExaminingRequest
 


@@ -523,16 +520,15 @@ foundNoEntity msgM
          driftTo ReceivingBody
 
 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
          driftTo ReceivingBody
 
 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.

-foundNoEntity' ∷ Resource ()
+foundNoEntity' ∷ Rsrc ()

 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 
 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 

-

 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- |@'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
+-- @limit@ bytes, and then make the 'Rsrc' 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.
 --
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 -- returns an empty string.
 --
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default


@@ -541,7 +537,7 @@ foundNoEntity' = foundNoEntity Nothing
 -- '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' 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 ∷ Maybe Int → Rsrc Lazy.ByteString

 getChunks (Just n)
     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
     | n ≡ 0     = return (∅)
 getChunks (Just n)
     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
     | n ≡ 0     = return (∅)


@@ -549,10 +545,10 @@ getChunks (Just n)
 getChunks Nothing
     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 
 getChunks Nothing
     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 

-getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' ∷ Int → Rsrc Lazy.ByteString

 getChunks' limit = go limit (∅)
     where
 getChunks' limit = go limit (∅)
     where

-      go ∷ Int → Builder → Resource Lazy.ByteString
+      go ∷ Int → Builder → Rsrc Lazy.ByteString

       go  0  _ = do chunk ← getChunk 1
                     if Strict.null chunk then
                         return (∅)
       go  0  _ = do chunk ← getChunk 1
                     if Strict.null chunk then
                         return (∅)


@@ -577,13 +573,9 @@ getChunks' limit = go limit (∅)
 -- Media Type\". If the request has no \"Content-Type\", it aborts
 -- with \"400 Bad Request\".
 --
 -- 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 character
--- encodings for field names, so they'll always be decoded in
--- UTF-8. (This could be a bad design, but I can't think of any better
--- idea.)
-getForm ∷ Maybe Int → Resource [(Text, FormData)]
+-- Note that there are currently a few limitations on parsing
+-- @multipart/form-data@. See: 'parseMultipartFormData'
+getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]

 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of
 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of


@@ -598,7 +590,7 @@ getForm limit
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "
                        $ A.toText
                        $ A.fromAsciiBuilder
                        $ A.toAsciiBuilder "Unsupported media type: "

-                       ⊕ printMIMEType cType
+                       ⊕ MT.printMIMEType cType

     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)


@@ -610,8 +602,8 @@ getForm limit
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 
               Just a  → return a
               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 

-      readMultipartFormData params
-          = case M.lookup "boundary" params of
+      readMultipartFormData m
+          = case lookup "boundary" m of

               Nothing
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary
               Nothing
                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
               Just boundary


@@ -620,45 +612,35 @@ getForm limit
                                 Just b  → return b
                                 Nothing → abort $ mkAbortion' BadRequest
                                                 $ "Malformed boundary: " ⊕ boundary
                                 Just b  → return b
                                 Nothing → abort $ mkAbortion' BadRequest
                                                 $ "Malformed boundary: " ⊕ boundary

-                       case LP.parse (p b) src of
-                         LP.Done _ formList
-                             → return formList
-                         LP.Fail _ eCtx e
-                             → abort $ mkAbortion' BadRequest
-                                     $ "Unparsable multipart/form-data: "
-                                     ⊕ T.pack (intercalate ", " eCtx)
-                                     ⊕ ": "
-                                     ⊕ T.pack e
-          where
-            p b = do xs ← multipartFormP b
-                     P.endOfInput
-                     return xs
+                       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' 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 sc ⇒ sc → URI → Rsrc ()
+redirect sc uri
+    = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))

              $ abort
              $ mkAbortion' InternalServerError
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
              $ abort
              $ mkAbortion' InternalServerError
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "

-             ⊕ printStatusCode code
-         setStatus code
+             ⊕ printStatusCode sc
+         setStatus sc

          setLocation uri
 
 -- |@'setContentType' mType@ declares the response header
 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 -- mandatory for sending a response body.
          setLocation uri
 
 -- |@'setContentType' mType@ declares the response header
 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 -- mandatory for sending a response body.

-setContentType ∷ MIMEType → Resource ()
+setContentType ∷ MIMEType → Rsrc ()

 setContentType
 setContentType

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

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

-setLocation ∷ URI → Resource ()
+setLocation ∷ URI → Rsrc ()

 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a


@@ -669,7 +651,7 @@ setLocation uri
 
 -- |@'setContentEncoding' codings@ declares the response header
 -- \"Content-Encoding\" as @codings@.
 
 -- |@'setContentEncoding' codings@ declares the response header
 -- \"Content-Encoding\" as @codings@.

-setContentEncoding ∷ [CIAscii] → Resource ()
+setContentEncoding ∷ [CIAscii] → Rsrc ()

 setContentEncoding codings
     = do ver ← getRequestVersion
          tr  ← case ver of
 setContentEncoding codings
     = do ver ← getRequestVersion
          tr  ← case ver of


@@ -687,13 +669,13 @@ setContentEncoding codings
 
 -- |@'setWWWAuthenticate' challenge@ declares the response header
 -- \"WWW-Authenticate\" as @challenge@.
 
 -- |@'setWWWAuthenticate' challenge@ declares the response header
 -- \"WWW-Authenticate\" as @challenge@.

-setWWWAuthenticate ∷ AuthChallenge → Resource ()
-setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
+setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs

 
 -- |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'.
 
 -- |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 ∷ Strict.ByteString → Rsrc ()

 putChunk = putBuilder ∘ BB.fromByteString
 
 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 putChunk = putBuilder ∘ BB.fromByteString
 
 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It


@@ -702,5 +684,5 @@ putChunk = putBuilder ∘ BB.fromByteString
 -- Note that you must first declare the response header
 -- \"Content-Type\" before applying this function. See
 -- 'setContentType'.
 -- Note that you must first declare the response header
 -- \"Content-Type\" before applying this function. See
 -- 'setContentType'.

-putChunks ∷ Lazy.ByteString → Resource ()
+putChunks ∷ Lazy.ByteString → Rsrc ()

 putChunks = putBuilder ∘ BB.fromLazyByteString
 putChunks = putBuilder ∘ BB.fromLazyByteString