From 899741bb41990fa2e14aaa58f674649170a3c1c2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 18 Sep 2018 20:43:32 +0200 Subject: [PATCH] Add UploadMode to Sheet Fixes #181 --- messages/uniworx/de.msg | 7 +++++++ models | 1 + src/Handler/Sheet.hs | 7 ++++++- src/Handler/Submission.hs | 22 ++++++++++++++++------ src/Handler/Utils/Form.hs | 7 +++++++ src/Model/Migration.hs | 8 +++++++- src/Model/Types.hs | 6 ++++++ templates/submission.hamlet | 17 +++++++++++------ 8 files changed, 61 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e66535980..8af5acdbb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -85,6 +85,7 @@ SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheet SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht. +SheetUploadMode: Abgabe von Dateien SheetExercise: Aufgabenstellung SheetHint: Hinweis SheetHintFrom: Hinweis ab @@ -285,3 +286,9 @@ DummyLoginTitle: Development-Login CorrectorNormal: Normal CorrectorMissing: Abwesend CorrectorExcused: Entschuldigt + +UploadModeNone: Kein Upload +UploadModeUnpack: Upload, einzelne Datei +UploadModeNoUnpack: Upload, ZIP-Archive entpacken + +SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. \ No newline at end of file diff --git a/models b/models index 341499e8f..52a89ff76 100644 --- a/models +++ b/models @@ -108,6 +108,7 @@ Sheet activeTo UTCTime hintFrom UTCTime Maybe solutionFrom UTCTime Maybe + uploadMode UploadMode CourseSheet course name SheetEdit user UserId diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index efaacf2e1..571b78e42 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -81,6 +81,7 @@ data SheetForm = SheetForm , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime + , sfUploadMode :: UploadMode , sfSheetF :: Maybe (Source Handler (Either FileId File)) , sfHintFrom :: Maybe UTCTime , sfHintF :: Maybe (Source Handler (Either FileId File)) @@ -118,6 +119,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) + <*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True)) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetHintFromTip) @@ -367,6 +369,7 @@ getSheetNewR tid ssh csh = do , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom , sfActiveFrom = addOneWeek sheetActiveFrom , sfActiveTo = addOneWeek sheetActiveTo + , sfUploadMode = sheetUploadMode , sfSheetF = Nothing , sfHintFrom = addOneWeek <$> sheetHintFrom , sfHintF = Nothing @@ -400,6 +403,7 @@ getSEditR tid ssh csh shn = do , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo + , sfUploadMode = sheetUploadMode , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint @@ -428,7 +432,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do actTime <- liftIO getCurrentTime cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let newSheet = Sheet - { sheetCourse = cid + { sheetCourse = cid , sheetName = sfName , sheetDescription = sfDescription , sheetType = sfType @@ -439,6 +443,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetActiveTo = sfActiveTo , sheetHintFrom = sfHintFrom , sheetSolutionFrom = sfSolutionFrom + , sheetUploadMode = sfUploadMode } mbsid <- dbAction newSheet case mbsid of diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index a39a5a62e..853fdab97 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -63,10 +63,14 @@ import qualified Text.Blaze.Html5.Attributes as HA -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. -makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) -makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do +makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) +makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do + let + fileUpload = case uploadMode of + NoUpload -> pure Nothing + (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing flip (renderAForm FormStandard) html $ (,) - <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing + <$> fileUpload <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy | g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies @@ -173,8 +177,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do return $ (userName, submissionEdit E.^. SubmissionEditTime) forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (sheet,buddies,lastEdits) - let unpackZips = True -- undefined -- TODO - ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies + ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies mCID <- runDB $ do res' <- case res of (FormMissing ) -> return $ FormMissing @@ -231,7 +234,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do -> return smid (Just files, _) -- new files -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False - _ -> error "Impossible, because of definition of `makeSubmissionForm`" + (Nothing, Nothing) -- new submission, no file upload requested + -> insert Submission + { submissionSheet = shid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Nothing + , submissionRatingTime = Nothing + } -- Determine members of pre-registered group groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e1fab772b..28064466d 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -249,6 +249,13 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName +uploadModeField :: Field Handler UploadMode +uploadModeField = selectFieldList + [ (MsgUploadModeNone , NoUpload ) + , (MsgUploadModeNoUnpack, Upload False) + , (MsgUploadModeUnpack , Upload True ) + ] + zipFileField :: Bool -- ^ Unpack zips? -> Field Handler (Source Handler File) zipFileField doUnpack = Field{..} diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 723ccd964..5b45329f9 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -168,12 +168,18 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "user") $ do userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |] [executeQQ| - ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' '; + ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ''; |] forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of Just name -> update uid [UserSurname =. name] _other -> error $ "Empty userDisplayName found" ) + , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] + , whenM (tableExists "sheet") $ do + [executeQQ| + ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }'; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 386d828e7..5d5f9e5a9 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -193,6 +193,12 @@ instance DisplayAble DA where -} +data UploadMode = NoUpload | Upload { unpackZips :: Bool } + deriving (Show, Read, Eq, Ord) + +deriveJSON defaultOptions ''UploadMode +derivePersistFieldJSON ''UploadMode + data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "ExamStatus" diff --git a/templates/submission.hamlet b/templates/submission.hamlet index d5044150b..aeaf9ca2f 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,12 +1,17 @@ $maybe cID <- mcid
-

- Archiv - (Original) + $case sheetUploadMode + $of Upload _ +

+ Archiv + (Original) - $maybe fileTable <- mFileTable -

_{MsgSubmissionFiles} - ^{fileTable} + $maybe fileTable <- mFileTable +

_{MsgSubmissionFiles} + ^{fileTable} + $of _ +

+ _{MsgSubmissionNoUploadExpected} $if not (null lastEdits)

_{MsgLastEdits}