diff --git a/ChangeLog.md b/ChangeLog.md index 923e51045..401601e10 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -9,6 +9,8 @@ Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit) + + Übungsblätter können Abgabe von Dateien verbieten und angeben ob ZIP-Archive entpackt werden sollen * Version 06.08.2018 diff --git a/db.hs b/db.hs index 4a2a1bf7c..0fe4b8812 100755 --- a/db.hs +++ b/db.hs @@ -196,11 +196,11 @@ fillDb = do void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp - sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing + sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing + sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing + sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) insert_ $ SheetEdit gkleen now sheetkey -- EIP eip <- insert Course @@ -284,6 +284,7 @@ fillDb = do , sheetVisibleFrom = Just now , sheetActiveFrom = now , sheetActiveTo = (14 * nominalDay) `addUTCTime` now + , sheetUploadMode = Upload True , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing } diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index fefe2075f..b16a7d255 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 @@ -289,3 +290,11 @@ CorrectorExcused: Entschuldigt DayIsAHoliday tid@TermId date@Text: #{date} ist ein Feiertag DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid} DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid} +UploadModeNone: Kein Upload +UploadModeUnpack: Upload, einzelne Datei +UploadModeNoUnpack: Upload, ZIP-Archive entpacken + +SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. + +FieldPrimary: Hauptfach +FieldSecondary: Nebenfach \ No newline at end of file diff --git a/models b/models index 7bc1477f0..62f4d0e43 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/Foundation.hs b/src/Foundation.hs index 233db9e21..d4f8890b1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -178,6 +178,12 @@ instance RenderMessage UniWorX TermIdentifier where Winter -> renderMessage' $ MsgWinterTerm year where renderMessage' = renderMessage foundation ls +instance RenderMessage UniWorX StudyFieldType where + renderMessage foundation ls = \case + FieldPrimary -> renderMessage' MsgFieldPrimary + FieldSecondary -> renderMessage' MsgFieldSecondary + where renderMessage' = renderMessage foundation ls + newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving (Eq, Ord, Read, Show) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 701f3ea4e..649c748ae 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -130,10 +130,14 @@ getProfileR = do E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId - return (studydegree E.^. StudyDegreeName - ,studyterms E.^. StudyTermsName - ,studyfeat E.^. StudyFeaturesType - ,studyfeat E.^. StudyFeaturesSemester) + return ( ( studydegree E.^. StudyDegreeName + , studydegree E.^. StudyDegreeKey + ) + , ( studyterms E.^. StudyTermsName + , studyterms E.^. StudyTermsKey + ) + , studyfeat E.^. StudyFeaturesType + , studyfeat E.^. StudyFeaturesSemester) ) let formText = Just MsgSettings actionUrl = ProfileR diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1ab2cb169..6cc6daa2f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -82,6 +82,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)) @@ -119,6 +120,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) (sfHintFrom <$> template) @@ -364,6 +366,7 @@ getSheetNewR tid ssh csh = do , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom , sfActiveFrom = addOneWeek sheetActiveFrom , sfActiveTo = addOneWeek sheetActiveTo + , sfUploadMode = sheetUploadMode , sfSheetF = Nothing , sfHintFrom = addOneWeek <$> sheetHintFrom , sfHintF = Nothing @@ -397,6 +400,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 @@ -425,7 +429,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 @@ -436,6 +440,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 a11f2a670..cd8ce6cd4 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -63,10 +63,14 @@ import System.FilePath -- 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 (csheet,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/default-layout.lucius b/templates/default-layout.lucius index 96b838972..34285a821 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -156,6 +156,7 @@ h4 { position: relative; min-height: calc(100vh - var(--header-height)); padding: 20px; + overflow: hidden; } @media (max-width: 768px) { @@ -169,7 +170,6 @@ h4 { .main__content { position: relative; background-color: white; - overflow: hidden; transition: padding-left .2s ease-out; max-width: 1200px; margin: 0 auto; diff --git a/templates/profile.hamlet b/templates/profile.hamlet index c2ae2bb18..40b468cd8 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -49,12 +49,20 @@
+ _{MsgSubmissionNoUploadExpected} $if not (null lastEdits)