MultiFileField
This commit is contained in:
Gregor Kleen
parent
217ae28d9e
commit
7ee2aac209
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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{..}
|
||||
|
||||
5
templates/multiFileField.hamlet
Normal file
5
templates/multiFileField.hamlet
Normal file
@ -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}>
|
||||
Loading…
Reference in New Issue
Block a user