diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 77d79eefb..f009c3969 100644
--- a/src/Handler/Sheet.hs
+++ b/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)
- <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
- <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
- <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
- <*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
- <*> aopt utcTimeField (fsb "Sichtbar ab") (sfVisibleFrom <$> template)
- <*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
- <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
- <*> fileAFormOpt (fsb "Aufgabenstellung")
- <*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
- <*> fileAFormOpt (fsb "Hinweis")
- <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
- <*> fileAFormOpt (fsb "Lösung")
+ <$> areq textField (fsb "Name") (sfName <$> template)
+ <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
+ <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
+ <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
+ <*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
+ <*> aopt utcTimeField (fsb "Sichtbar ab") (sfVisibleFrom <$> template)
+ <*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
+ <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
+ <*> aopt multiFileField (fsb "Aufgabenstellung") (error "No defaults for file uploads")
+ <*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
+ <*> fileAFormOpt (fsb "Hinweis")
+ <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
+ <*> 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
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 59923e591..b534f1198 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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
diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs
index 06405b8d6..b972555a7 100644
--- a/src/Handler/Utils/Zip.hs
+++ b/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
- let fileTitle = unpack $ fileName fInfo
- fileModified <- liftIO getCurrentTime
- yieldM $ do
- fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
- return File{..}
+ | otherwise = yieldM $ acceptFile fInfo
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{..}
diff --git a/templates/multiFileField.hamlet b/templates/multiFileField.hamlet
new file mode 100644
index 000000000..fb315ade7
--- /dev/null
+++ b/templates/multiFileField.hamlet
@@ -0,0 +1,5 @@
+$newline never
+
+