multipart/form-data and more

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index bf75de8a5f6b5bf4ad5b5a9060713282c833788c..33eaa621a23236dba28302c6911a3d435bbe5a5d 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -137,6 +137,7 @@ import           Data.Bits
 import           Data.ByteString.Base (ByteString, LazyByteString(..))
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy.Char8 as L8
+import           Data.Char
 import           Data.List
 import           Data.Maybe
 import           Network.HTTP.Lucu.Abortion
@@ -147,6 +148,7 @@ 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.Parser
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.RFC1123DateTime
@@ -679,14 +681,11 @@ inputChunkLBS limit
 
 -- | Computation of @'inputForm' limit@ attempts to read the request
 -- body with 'input' and parse it as
--- application\/x-www-form-urlencoded. If the request header
--- \"Content-Type\" is not application\/x-www-form-urlencoded,
--- 'inputForm' makes 'Resource' abort with status \"415 Unsupported
--- Media Type\". If the request has no \"Content-Type\", it aborts
--- with \"400 Bad Request\".
---
--- This action should also support multipart\/form-data somehow, but
--- it is not (yet) done.
+-- 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\".
 inputForm :: Int -> Resource [(String, String)]
 inputForm limit
     = limit `seq` 
@@ -696,8 +695,8 @@ inputForm limit
                -> abort BadRequest [] (Just "Missing Content-Type")
            Just (MIMEType "application" "x-www-form-urlencoded" _)
                -> readWWWFormURLEncoded
-           Just (MIMEType "multipart" "form-data" _)
-               -> readMultipartFormData
+           Just (MIMEType "multipart" "form-data" params)
+               -> readMultipartFormData params
            Just cType
                -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
                                                           ++ show cType)
@@ -706,9 +705,16 @@ inputForm limit
           = do src <- input limit
                return $ parseWWWFormURLEncoded src
 
-      readMultipartFormData -- FIXME: 未對應
-          = abort UnsupportedMediaType []
-            (Just $! "Sorry, inputForm does not currently support multipart/form-data.")
+      readMultipartFormData params
+          = do case find ((== "boundary") . map toLower . fst) params of
+                 Nothing
+                     -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
+                 Just (_, boundary)
+                     -> do src <- inputLBS limit
+                           case parse (multipartFormP boundary) src of
+                             (# Success pairs, _ #) -> return pairs
+                             (# _, _ #)
+                                 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 
 -- | This is just a constant @-1@. It's better to say @'input'
 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly