MultiFileField

src/Handler/Sheet.hs

@@ -51,7 +51,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
-      , sfSheetF       :: Maybe FileInfo
+      , sfSheetF       :: Maybe (Source Handler File)
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe FileInfo
       , sfSolutionFrom :: Maybe UTCTime
@@ -65,19 +65,19 @@ makeSheetForm template = identForm FIDsheet $ \html -> do
     -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
     -- Erstmal nur mit ZIP arbeiten
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq textField     (fsb "Name")                     (sfName <$> template)
+      <$> areq textField      (fsb "Name")                     (sfName <$> template)
-      <*> aopt htmlField     (fsb "Hinweise für Teilnehmer")  (sfDescription <$> template)
+      <*> aopt htmlField      (fsb "Hinweise für Teilnehmer")  (sfDescription <$> template)
-      <*> sheetTypeAFormReq  (fsb "Bewertung")                (sfType <$> template)
+      <*> sheetTypeAFormReq   (fsb "Bewertung")                (sfType <$> template)
-      <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
+      <*> sheetGroupAFormReq  (fsb "Abgabegruppengröße") (sfGrouping <$> template)
-      <*> aopt htmlField     (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
+      <*> aopt htmlField      (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
-      <*> aopt utcTimeField  (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
+      <*> aopt utcTimeField   (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
-      <*> areq utcTimeField  (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
+      <*> areq utcTimeField   (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
-      <*> areq utcTimeField  (fsb "Abgabefrist") (sfActiveTo     <$> template)
+      <*> areq utcTimeField   (fsb "Abgabefrist") (sfActiveTo     <$> template)
-      <*> fileAFormOpt       (fsb "Aufgabenstellung")
+      <*> aopt multiFileField (fsb "Aufgabenstellung") (error "No defaults for file uploads")
-      <*> aopt utcTimeField  (fsb "Hinweis ab")  (sfHintFrom     <$> template)
+      <*> aopt utcTimeField   (fsb "Hinweis ab")  (sfHintFrom     <$> template)
-      <*> fileAFormOpt       (fsb "Hinweis")
+      <*> fileAFormOpt        (fsb "Hinweis")
-      <*> aopt utcTimeField  (fsb "Lösung ab")   (sfSolutionFrom <$> template)
+      <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
-      <*> fileAFormOpt       (fsb "Lösung")
+      <*> fileAFormOpt        (fsb "Lösung")
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
@@ -320,7 +320,7 @@ handleSheetEdit tid csh template dbAction = do
         case mbsid of
           Nothing    -> False <$ addMessageI "danger" (MsgSheetNameDup tident csh sfName)
           (Just sid) ->  do -- save files in DB:
-            whenIsJust sfSheetF    $ insertSheetFile sid SheetExercise
+            whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
             whenIsJust sfHintF     $ insertSheetFile sid SheetHint
             whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution
             addMessageI "info" $ MsgSheetEditOk tident csh sfName
@@ -374,3 +374,10 @@ insertSheetFile sid ftype finfo = do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
 
+insertSheetFile' :: SheetId -> SheetFileType -> Source Handler File -> YesodDB UniWorX ()
+insertSheetFile' sid ftype fs = do
+    runConduit $ transPipe lift fs =$= C.mapM_ finsert
+  where
+    finsert file = do
+      fid <- insert file
+      void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step

src/Handler/Utils/Form.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Handler.Utils.Form where
 
@@ -27,6 +28,9 @@ import qualified Text.Blaze.Internal as Blaze (null)
 
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
+import Handler.Utils.Zip
+import qualified Data.Conduit.List as C
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
@@ -232,6 +236,18 @@ schoolEntField = selectField schools
   where
     schools = optionsPersist [] [Asc SchoolName] schoolName
 
+multiFileField :: Field Handler (Source Handler File)
+multiFileField = Field{..}
+  where
+    fieldEnctype = Multipart
+    fieldParse vals files
+      | null files = return $ Right Nothing
+      | [unpackZips] == vals = return . Right . Just $ mapM_ sourceFiles files
+      | otherwise = return . Right . Just $ C.sourceList files .| C.mapM acceptFile
+    fieldView fieldId fieldName attrs prev req = $(widgetFile "multiFileField")
+    unpackZips :: Text
+    unpackZips = "unpack-zip"
+
 sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
 sheetTypeAFormReq d Nothing =
   -- TODO, offer options to choose between Normal/Bonus/Pass

src/Handler/Utils/Zip.hs

@@ -11,7 +11,7 @@ module Handler.Utils.Zip
   , produceZip
   , consumeZip
   , modifyFileTitle
-  , sourceFiles
+  , sourceFiles, acceptFile
   ) where
 
 import Import
@@ -102,11 +102,13 @@ modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
 sourceFiles :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
 sourceFiles fInfo
     | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
-    | otherwise = do
+    | otherwise = yieldM $ acceptFile fInfo
-        let fileTitle = unpack $ fileName fInfo
-        fileModified <- liftIO getCurrentTime
-        yieldM $ do
-          fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
-          return File{..}
   where
     mimeType = defaultMimeLookup (fileName fInfo)
+
+acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
+acceptFile fInfo = do
+  let fileTitle = unpack $ fileName fInfo
+  fileModified <- liftIO getCurrentTime
+  fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
+  return File{..}

templates/multiFileField.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<input type=checkbox id=#{fieldId}_zip name=#{fieldName} value=#{unpackZips} :req:required>
+<label for=#{fieldId}_zip>
+  ZIPs entpacken
+<input type=file id=#{fieldId} name=#{fieldName}>