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 + +