Reimplement MultipartForm

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 72b751709132b38b2ef66994d2d551d62a42b99c..6463bc8fd7d0fc0ee12b50a8a3363891af894127 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    GeneralizedNewtypeDeriving
+    BangPatterns
+  , GeneralizedNewtypeDeriving

   , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
   , DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards


@@ -28,8 +29,8 @@
 -- /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 fields and thinks about a corresponding entity for
---   it. If there is a suitable entity, the 'Resource' tells the
+--   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
 --   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


@@ -41,11 +42,11 @@
 --   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
 --   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

---   receives and discards it.
+--   discards it.

 --
 --

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


@@ -69,6 +70,8 @@ module Network.HTTP.Lucu.Resource
     (
     -- * Types
       Resource
     (
     -- * Types
       Resource

+    , ResourceDef(..)
+    , emptyResource

     , FormData(..)
 
     -- * Getting request header
     , FormData(..)
 
     -- * Getting request header


@@ -101,6 +104,7 @@ module Network.HTTP.Lucu.Resource
     , foundETag
     , foundTimeStamp
     , foundNoEntity
     , foundETag
     , foundTimeStamp
     , foundNoEntity

+    , foundNoEntity'

 
     -- * Receiving a request body
     -- |These functions make the 'Resource' transit to the /Receiving
 
     -- * Receiving a request body
     -- |These functions make the 'Resource' transit to the /Receiving


@@ -125,40 +129,39 @@ module Network.HTTP.Lucu.Resource
     , deleteHeader
 
     -- * Sending a response body
     , deleteHeader
 
     -- * Sending a response body

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

     , putChunk
     , putChunks
     , putBuilder
     )
     where
     , putChunk
     , putChunks
     , putBuilder
     )
     where

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

 import Control.Applicative
 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 qualified Data.Attoparsec.Char8 as P
 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 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 qualified Data.ByteString.Lazy.Internal as Lazy
-import Data.Foldable (toList)

 import Data.List
 import qualified Data.Map as M
 import Data.Maybe
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe

+import Data.Monoid

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

-import Data.Sequence (Seq)
-import Data.Sequence.Unicode hiding ((∅))

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


@@ -178,15 +181,17 @@ 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
 -- |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' = 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)
+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


@@ -214,9 +219,8 @@ getPathInfo = do rsrcPath ← getResourcePath
 -- |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
 -- |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 ∷ Resource [(Strict.ByteString, FormData)]

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


@@ -226,18 +230,19 @@ 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 = parseMIMEType "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
 
 -- |@'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 actions like 'getContentType' for every common headers.
+-- 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


@@ -253,10 +258,10 @@ getAccept
            Just accept
                → case P.parseOnly p (A.toByteString accept) of
                     Right xs → return xs
            Just accept
                → case P.parseOnly p (A.toByteString accept) of
                     Right xs → return xs

-                    Left  _  → abort BadRequest []
-                               (Just $ "Unparsable Accept: " ⊕ A.toText accept)
+                    Left  _  → abort $ mkAbortion' BadRequest
+                                     $ "Unparsable Accept: " ⊕ A.toText accept

     where
     where

-      p = do xs ← mimeTypeListP
+      p = do xs ← mimeTypeList

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -276,8 +281,8 @@ 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 のみが許される。
            Just ae
                → if ae ≡ "" then
                       -- identity のみが許される。


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

     where
     where

-      p = do xs ← acceptEncodingListP
+      p = do xs ← acceptEncodingList

              P.endOfInput
              return xs
 
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
              P.endOfInput
              return xs
 
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 

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

 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where
 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
     where


@@ -312,10 +318,10 @@ getContentType
            Just cType
                → case P.parseOnly p (A.toByteString cType) of
                     Right t → return $ Just t
            Just cType
                → case P.parseOnly p (A.toByteString cType) of
                     Right t → return $ Just t

-                    Left  _ → abort BadRequest []
-                              (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
+                    Left  _ → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable Content-Type: " ⊕ A.toText cType

     where
     where

-      p = do t ← mimeTypeP
+      p = do t ← mimeType

              P.endOfInput
              return t
 
              P.endOfInput
              return t
 


@@ -332,7 +338,7 @@ getAuthorization
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
     where
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
     where

-      p = do ac ← authCredentialP
+      p = do ac ← authCredential

              P.endOfInput
              return ac
 
              P.endOfInput
              return ac
 


@@ -358,8 +364,9 @@ foundEntity tag timeStamp
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)

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

          foundETag tag
 
          driftTo ReceivingBody
          foundETag tag
 
          driftTo ReceivingBody


@@ -381,8 +388,9 @@ foundETag tag
              $ A.fromAsciiBuilder
              $ printETag tag
          when (method ≡ POST)
              $ A.fromAsciiBuilder
              $ printETag tag
          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"
 
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"


@@ -396,13 +404,12 @@ foundETag tag
                                   -- tags の中に一致するものが無ければ
                                   -- PreconditionFailed で終了。
                                   → when ((¬) (any (≡ tag) tags))
                                   -- tags の中に一致するものが無ければ
                                   -- PreconditionFailed で終了。
                                   → when ((¬) (any (≡ tag) tags))

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

                                         $ "The entity tag doesn't match: " ⊕ A.toText value
                               Left _
                                         $ "The entity tag doesn't match: " ⊕ A.toText value
                               Left _

-                                  → abort BadRequest []
-                                    $ Just
-                                    $ "Unparsable If-Match: " ⊕ A.toText value
+                                  → 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


@@ -415,22 +422,22 @@ foundETag tag
          case ifNoneMatch of
            Nothing    → return ()
            Just value → if value ≡ "*" then
          case ifNoneMatch of
            Nothing    → return ()
            Just value → if value ≡ "*" then

-                            abort statusForNoneMatch [] (Just "The entity tag matches: *")
+                            abort $ mkAbortion' statusForNoneMatch
+                                  $ "The entity tag matches: *"

                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)

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

                                         $ "The entity tag matches: " ⊕ A.toText value
                               Left _
                                         $ "The entity tag matches: " ⊕ A.toText value
                               Left _

-                                  → abort BadRequest []
-                                    $ Just
-                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+                                  → abort $ mkAbortion' BadRequest
+                                          $ "Unparsable If-None-Match: " ⊕ A.toText value

 
          driftTo ReceivingBody
     where
 
          driftTo ReceivingBody
     where

-      p = do xs ← eTagListP
+      p = do xs ← eTagList

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -452,8 +459,9 @@ foundTimeStamp timeStamp
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          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


@@ -467,8 +475,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 ()


@@ -479,8 +488,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 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 ()


@@ -501,16 +511,22 @@ 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
+             $ abort
+             $ mkAbortion PreconditionFailed [] msgM

 
          driftTo ReceivingBody
 
 
          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
 
 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the


@@ -522,8 +538,8 @@ foundNoEntity msgM
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 -- limitation value ('cnfMaxEntityLength') instead.
 --
 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 -- limitation value ('cnfMaxEntityLength') instead.
 --

--- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of
+-- '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)
 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 getChunks ∷ Maybe Int → Resource Lazy.ByteString
 getChunks (Just n)


@@ -536,19 +552,23 @@ getChunks Nothing
 getChunks' ∷ Int → Resource Lazy.ByteString
 getChunks' limit = go limit (∅)
     where
 getChunks' ∷ Int → Resource Lazy.ByteString
 getChunks' limit = go limit (∅)
     where

-      go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
-      go 0 _  = abort RequestEntityTooLarge []
-                (Just $ "Request body must be smaller than "
-                        ⊕ T.pack (show limit) ⊕ " bytes.")
-      go n xs = do let n'  = min n Lazy.defaultChunkSize
-                   chunk ← getChunk n'
-                   if Strict.null chunk then
-                       -- Got EOF
-                       return $ Lazy.fromChunks $ toList xs
-                   else
-                       do let n'' = n' - Strict.length chunk
-                              xs' = xs ⊳ chunk
-                          go n'' xs'
+      go ∷ Int → Builder → Resource Lazy.ByteString
+      go  0  _ = do chunk ← getChunk 1
+                    if Strict.null chunk then
+                        return (∅)
+                    else
+                        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
 
 -- |@'getForm' limit@ attempts to read the request body with
 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or


@@ -557,29 +577,24 @@ 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 → Resource [(Strict.ByteString, FormData)]

 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of
            Nothing
 getForm limit
     = 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: "
+                       ⊕ printMIMEType cType

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


@@ -589,26 +604,21 @@ getForm 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")
+              Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"

 
       readMultipartFormData params
 
       readMultipartFormData params

-          = do case M.lookup "boundary" params of
-                 Nothing
-                     → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
-                 Just boundary
-                     → do src ← getChunks 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
+          = case M.lookup "boundary" params 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
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy


@@ -616,8 +626,8 @@ getForm limit
 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 "


@@ -638,8 +648,8 @@ setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a
 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 ""
 


@@ -651,10 +661,13 @@ setContentEncoding codings
          tr  ← case ver of
                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                   HttpVersion 1 1 → return toAB
          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
 


@@ -669,9 +682,8 @@ setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 putChunk ∷ Strict.ByteString → Resource ()
 putChunk = putBuilder ∘ BB.fromByteString
 
 putChunk ∷ Strict.ByteString → Resource ()
 putChunk = putBuilder ∘ BB.fromByteString
 

--- |Write a chunk in 'Lazy.ByteString' to the response body. It is
--- safe to apply this function to an infinitely long
--- 'Lazy.ByteString'.
+-- |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
 --
 -- Note that you must first declare the response header
 -- \"Content-Type\" before applying this function. See