Reimplement MultipartForm

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 71ff4838c3945380d44f2dee36fddc2b3952d3d1..6463bc8fd7d0fc0ee12b50a8a3363891af894127 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -141,13 +141,13 @@ 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 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


@@ -158,7 +158,6 @@ import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Monoid.Unicode
 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


@@ -182,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


@@ -218,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 ∘


@@ -230,13 +230,14 @@ 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
 
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that


@@ -260,7 +261,7 @@ getAccept
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
     where
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
     where

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

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -292,7 +293,7 @@ getAcceptEncoding
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where

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

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -320,7 +321,7 @@ getContentType
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
     where
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
     where

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

              P.endOfInput
              return t
 
              P.endOfInput
              return t
 


@@ -337,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
 


@@ -436,7 +437,7 @@ foundETag tag
 
          driftTo ReceivingBody
     where
 
          driftTo ReceivingBody
     where

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

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -527,7 +528,6 @@ foundNoEntity' ∷ Resource ()
 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 
 {-# 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
 -- |@'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


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

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


@@ -620,19 +616,9 @@ 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
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy