group file uploads

this fix allows uploads with similar names i.e.
<input multiple type="file" name="pictures" />

Author: frostbane

Spock-core/src/Web/Spock/Internal/CoreAction.hs

@@ -149,7 +149,7 @@ jsonBody' =
 {-# INLINE jsonBody' #-}
 
 -- | Get uploaded files
-files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text UploadedFile)
+files :: MonadIO m => ActionCtxT ctx m (HM.HashMap T.Text [UploadedFile])
 files =
   do
     b <- asks ri_reqBody

Spock-core/src/Web/Spock/Internal/Wire.hs

@@ -142,7 +142,7 @@ loadCacheVar (CacheVar lock makeVal valRef readV) =
 data RequestBody = RequestBody
   { rb_value :: CacheVar BS.ByteString,
     rb_postParams :: CacheVar [(T.Text, T.Text)],
-    rb_files :: CacheVar (HM.HashMap T.Text UploadedFile)
+    rb_files :: CacheVar (HM.HashMap T.Text [UploadedFile])
   }
 
 data RequestInfo ctx = RequestInfo
@@ -418,13 +418,13 @@ makeActionEnvironment st stdMethod req =
               (bodyParams, bodyFiles) <-
                 P.sinkRequestBody (P.tempFileBackEnd st) rbt loader
               let uploadedFiles =
-                    HM.fromList $
+                    HM.fromListWith (<>) $
                       flip map bodyFiles $ \(k, fileInfo) ->
                         ( T.decodeUtf8 k,
-                          UploadedFile
+                          [UploadedFile
                             (T.decodeUtf8 $ P.fileName fileInfo)
                             (T.decodeUtf8 $ P.fileContentType fileInfo)
-                            (P.fileContent fileInfo)
+                            (P.fileContent fileInfo)]
                         )
                   postParams =
                     map (T.decodeUtf8 *** T.decodeUtf8) bodyParams

Spock-core/test/Web/Spock/FrameworkSpecHelper.hs

@@ -63,6 +63,7 @@ frameworkSpec app =
       actionSpec
       headerTest
       cookieTest
+      fileTest
 
 routingSpec :: SpecWith (st, Wai.Application)
 routingSpec =
@@ -233,3 +234,76 @@ matchCookie name val =
               then Nothing
               else loop xs
    in loop relevantHeaders
+
+fileTest :: SpecWith (st, Wai.Application)
+fileTest =
+  describe "" $
+    do
+      it "receives a single file" $
+        do
+          request methodPost "file/upload" headers bodySingle `shouldRespondWith` "1" {matchStatus = 200}
+      it "receives multiple files with different names" $
+        do
+          request methodPost "file/upload" headers bodyUnique `shouldRespondWith` "2" {matchStatus = 200}
+      it "receives multiple files with similar names" $
+        do
+          request methodPost "file/upload/multi" headers bodyMulti `shouldRespondWith` "2" {matchStatus = 200}
+  where
+    bodySingle = BSLC.pack $
+             boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"name\"" <> crlf <> crlf
+             <> "file1.pdf" <> crlf
+             <> boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"file\"; filename=\"file1.pdf\"" <> crlf
+             <> "Content-Type: application/pdf" <> crlf
+             <> "Content-Transfer-Encoding: base64" <> crlf <> crlf
+             <> "aGFza2VsbA==" <> crlf
+             <> boundary <> "--" <> crlf
+
+    bodyUnique = BSLC.pack $
+             boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"names\"" <> crlf <> crlf
+             <> "file1.pdf; file2.pdf" <> crlf
+             <> boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"file1\"; filename=\"file1.pdf\"" <> crlf
+             <> "Content-Type: application/pdf" <> crlf
+             <> "Content-Transfer-Encoding: base64" <> crlf <> crlf
+             <> "aGFza2VsbA==" <> crlf
+             <> boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"file2\"; filename=\"file2.pdf\"" <> crlf
+             <> "Content-Type: application/pdf" <> crlf
+             <> "Content-Transfer-Encoding: base64" <> crlf <> crlf
+             <> "c3BvY2s=" <> crlf
+             <> boundary <> "--" <> crlf
+
+    bodyMulti = BSLC.pack $
+             boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"name1\"" <> crlf <> crlf
+             <> "file1.pdf" <> crlf
+             <> "Content-Disposition: form-data; name=\"name2\"" <> crlf <> crlf
+             <> "file2.pdf" <> crlf
+             <> boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"file\"; filename=\"file1.pdf\"" <> crlf
+             <> "Content-Type: application/pdf" <> crlf
+             <> "Content-Transfer-Encoding: base64" <> crlf <> crlf
+             <> "aGFza2VsbA==" <> crlf
+             <> boundary <> crlf
+             <> "Content-Disposition: form-data; name=\"file\"; filename=\"file2.pdf\"" <> crlf
+             <> "Content-Type: application/pdf" <> crlf
+             <> "Content-Transfer-Encoding: base64" <> crlf <> crlf
+             <> "c3BvY2s=" <> crlf
+             <> boundary <> "--" <> crlf
+
+    boundary :: String
+    boundary = "--__boundary"
+
+    crlf :: String
+    crlf = "\r\n"
+
+    headers :: [Header]
+    headers = [ mkHeader "Content-Type" "multipart/form-data; boundary=__boundary"
+              , mkHeader "Accept-Encoding" "gzip"
+              ]
+
+    mkHeader :: HeaderName -> BS.ByteString -> Header
+    mkHeader key val = (key, val)

Spock-core/test/Web/Spock/SafeSpec.hs

@@ -22,6 +22,7 @@ import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as BSLC
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import qualified Data.HashMap.Strict as HM
 import GHC.Generics
 import Network.HTTP.Types.Status
 import qualified Network.Wai as Wai
@@ -114,6 +115,15 @@ app =
     hookAnyCustom "MYVERB" $ text . T.intercalate "/"
     get ("wai" <//> wildcard) $ \_ ->
       respondApp dummyWai
+    post "file/upload" $
+      do
+        f <- files
+        text (T.pack $ show $ HM.size f)
+    post "file/upload/multi" $
+      do
+        f <- files
+        let uploadFiles = f HM.! "file"
+        text (T.pack $ show $ length $ uploadFiles)
 
 dummyWai :: Wai.Application
 dummyWai req respond =