diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 1ba093fcb..b575ebe86 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -497,6 +497,7 @@ UnauthorizedParticipantSelf: Sie sind kein Teilnehmer dieser Veranstaltung. UnauthorizedApplicant: Angegebener Benutzer hat sich nicht für diese Veranstaltung beworben. UnauthorizedApplicantSelf: Sie sind kein Bewerber für diese Veranstaltung. UnauthorizedCourseTime: Dieser Kurs ist momentan nicht freigegeben. +UnauthorizedCorrectionExamTime: Sichtbarkeitseinstellungen der relevanten Prüfung verhindern momentan die Freigabe. UnauthorizedCourseRegistrationTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. @@ -1142,7 +1143,7 @@ SubmissionGradingSummaryTitle intgr@Integer: #{intgr} #{pluralDE intgr "Abgabe" SheetTypeExamPartPointsWeightNegative: Gewichtung darf nicht negativ sein SheetTypeExamPartPointsWeight: Gewichtung SheetTypeExamPartPointsExamPartOption examn@ExamName examPartNumber@ExamPartNumber: #{examn} - Teil #{view _ExamPartNumber examPartNumber} -SheetTypeInfoExamPartPoints: Bei diesem Übungsblatt erreichte Punkte werden direkt auf die Punktezahl eines Prüfungsteils angerechnet. Wenn die Anzahl von über Übungsblättern erreichbaren Punkten nicht der Maximalpunktzahl des Prüfungsteils entspricht, werden die Übungsblattpunkte anhand der angegebenen Gewichtung skaliert. +SheetTypeInfoExamPartPoints: Bei diesem Übungsblatt erreichte Punkte werden direkt auf die Punktezahl eines Prüfungsteils angerechnet. Wenn die Anzahl von über Übungsblättern erreichbaren Punkten nicht der Maximalpunktzahl des Prüfungsteils entspricht, werden die Übungsblattpunkte anhand der angegebenen Gewichtung skaliert. Korrekturen für dieses Übungsblatt werden den Teilnehmenden erst angezeigt sobald die Prüfungsfrist „_{MsgExamFinished}“ verstrichen ist. SheetTypeExamPartPointsExamPart: Prüfungsteil SheetTypeBonus': Bonus @@ -1579,6 +1580,7 @@ AuthTagTime: Zeitliche Einschränkungen sind erfüllt AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt AuthTagCourseTime: Zeitliche Einschränkungen für Kurssichtbarkeit sind erfüllt +AuthTagExamTime: Zeitliche Einschränkungen durch relevante Prüfung sind erfüllt AuthTagCourseRegistered: Nutzer ist Kursteilnehmer AuthTagAllocationRegistered: Nutzer nimmt an der Zentralanmeldung teil AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer @@ -1892,6 +1894,7 @@ ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten ExamBonusManual': Manuelle Berechnung +ExamBonusInfoPoints: Zur Berechnung von Bonuspunkten werden nur jene Blätter herangezogen, deren Aktivitätszeitraum vor Start des jeweiligen Termin/Prüfung begonnen hat ExamRegisterForOccurrence: Anmeldung zur Prüfung erfolgt durch Anmeldung zu einem Termin/Raum @@ -3209,3 +3212,8 @@ WorkflowGraphFormUploadIsDirectory: Upload ist Verzeichnis WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv + +CorrectionInvisibleExamUnfinished: Die Frist „_{MsgExamFinished}“ für die relevante Prüfung ist noch nicht verstrichen +CorrectionInvisibleRatingNotDone: Die Bewertung ist nicht als „Abgeschlossen“ markiert +CorrectionInvisibleWarning: Die Bewertung dieser Abgabe ist aktuell für mindestens eine an der Abgabe beteiligte Person nicht sichtbar! +CorrectionInvisibleReasons: Mögliche Gründe hierfür: \ No newline at end of file diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 4780888cd..39de22e28 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -494,6 +494,7 @@ UnauthorizedParticipantSelf: You are no participant of this course. UnauthorizedApplicant: The specified user is no applicant for this course. UnauthorizedApplicantSelf: You are no applicant for this course. UnauthorizedCourseTime: This course is not currently available. +UnauthorizedCorrectionExamTime: Visibility restrictions of the relevant exam are restricting access. UnauthorizedCourseRegistrationTime: This course does not currently allow enrollment. UnauthorizedAllocationRegisterTime: This central allocation does not currently allow applications. UnauthorizedSheetTime: This sheet is not currently available. @@ -1143,7 +1144,7 @@ SubmissionGradingSummaryTitle intgr: #{intgr} #{pluralEN intgr "submission" "sub SheetTypeExamPartPointsWeightNegative: Weight may not be negative SheetTypeExamPartPointsWeight: Weight SheetTypeExamPartPointsExamPartOption examn examPartNumber: #{examn} - Part #{view _ExamPartNumber examPartNumber} -SheetTypeInfoExamPartPoints: Points achieved in this exercise sheet will be directly applied to the result of an exam part. If the number of points achievable via exercise sheets for an exam part does not match the maximum number of points of that exam part, the points achieved via exercise sheets will be scaled according to their weight. +SheetTypeInfoExamPartPoints: Points achieved in this exercise sheet will be directly applied to the result of an exam part. If the number of points achievable via exercise sheets for an exam part does not match the maximum number of points of that exam part, the points achieved via exercise sheets will be scaled according to their weight. Corrections for this sheet will only be displayed to participants once the exam timestamp “_{MsgExamFinished}” has passed. SheetTypeExamPartPointsExamPart: Exam part SheetTypeBonus': Bonus @@ -1579,6 +1580,7 @@ AuthTagTime: Time restrictions are fulfilled AuthTagStaffTime: Time restrictions wrt. staff are fulfilled AuthTagAllocationTime: Time restrictions due to a central allocation are fulfilled AuthTagCourseTime: Time restrictions wrt. course visibility are fulfilled +AuthTagExamTime: Exam time restrictions are satisfied AuthTagCourseRegistered: User is enrolled in course AuthTagAllocationRegistered: User participates in central allocation AuthTagTutorialRegistered: User is tutorial participant @@ -1891,6 +1893,7 @@ ExamBonusRule: Bonus points from exercises ExamNoBonus': No automatic exam bonus ExamBonusPoints': Compute from exercise achievements ExamBonusManual': Manual computation +ExamBonusInfoPoints: When calculating an exam bonus only those sheets will be considered, for which the submission period started before the start of the relevant occurrence/room ExamRegisterForOccurrence: Registration for this exam is done by registering for an occurrence/room @@ -3209,3 +3212,8 @@ WorkflowGraphFormUploadIsDirectory: Upload is a directory WorkflowGraphFormInvalidNumberOfFiles: You need to upload exactly one file CourseSortingOnlyLoggedIn: The user interface for sorting this table is only active for logged in users + +CorrectionInvisibleExamUnfinished: The time configured in “_{MsgExamFinished}” of the relevant exam has not yet passed +CorrectionInvisibleRatingNotDone: The correction is not marked as “finished” +CorrectionInvisibleWarning: This correction is currently invisible for at least one of the submittors! +CorrectionInvisibleReasons: Possible reasons include: diff --git a/routes b/routes index b40036b29..14332ce5d 100644 --- a/routes +++ b/routes @@ -207,7 +207,7 @@ / SubShowR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !ownerANDread !correctorANDread /delete SubDelR GET POST !ownerANDtimeANDuser-submissionsANDexam-registeredANDpersonalised-sheet-files /assign SubAssignR GET POST !lecturerANDtime - /correction CorrectionR GET POST !corrector !ownerANDreadANDrated + /correction CorrectionR GET POST !corrector !ownerANDreadANDratedANDexam-time /invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 6cbe5bcf0..1d1ab7717 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1074,6 +1074,17 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route o guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r +tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of + CSubmissionR tid ssh csh shn _cID CorrectionR -> maybeT (unauthorizedI MsgUnauthorizedCorrectionExamTime) $ do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn + whenIsJust (sheetType ^? _examPart . from _SqlKey) $ \epId -> do + ExamPart{examPartExam} <- $cachedHereBinary epId . MaybeT $ get epId + Exam{..} <- $cachedHereBinary examPartExam . MaybeT $ get examPartExam + now <- liftIO getCurrentTime + guard $ NTop (Just now) >= NTop examFinished + return Authorized + r -> $unsupportedAuthPredicate AuthExamTime r tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if | Just courseRegisteredList <- mCourseRegisteredList , maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 4abbac251..497cea1bd 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -148,19 +148,22 @@ resultStudyFeatures = _dbrOutput . _8 resultAutomaticExamBonus :: Ord epId => Exam -> Map UserId (SheetTypeSummary epId) -> Fold ExamUserTableData Points resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) -resultAutomaticExamResult :: Exam -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPassedGrade -resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do +resultAutomaticExamResult :: Exam + -> Map UserId (SheetTypeSummary ExamPartId) + -> Map UserId (SheetTypeSummary ExamPartId) + -> Fold ExamUserTableData ExamResultPassedGrade +resultAutomaticExamResult exam@Exam{..} examBonus' resultSheets = folding . runReader $ do parts' <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> runMaybeT $ hoistMaybe (mRes ^? _Just . _entityVal . _examPartResultResult) - <|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) examBonus') + <|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) resultSheets) ) bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus' let gradeRes = examGrade exam bonus =<< sequence parts' return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes resultAutomaticExamPartResult :: Entity ExamPart -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPoints -resultAutomaticExamPartResult epEnt examBonus' = folding . runReader . runMaybeT $ do +resultAutomaticExamPartResult epEnt resultSheets = folding . runReader . runMaybeT $ do uid <- view $ resultUser . _entityKey - summary <- hoistMaybe $ Map.lookup uid examBonus' + summary <- hoistMaybe $ Map.lookup uid resultSheets hoistMaybe $ sheetExamResult summary epEnt @@ -378,12 +381,13 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, (bonus, resultSheets)) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn Course{..} <- getJust examCourse occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName] examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] - bonus <- examBonus exam + bonus <- examRelevantSheets exam True + resultSheets <- examRelevantSheets exam False let allBoni :: SheetGradeSummary @@ -398,7 +402,7 @@ postEUsersR tid ssh csh examn = do resultAutomaticExamBonus' :: Fold ExamUserTableData Points resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade - resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus + resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus resultSheets automaticCell :: forall msg m a b r. ( RenderMessage UniWorX msg @@ -486,7 +490,7 @@ postEUsersR tid ssh csh examn = do in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left , pure $ mconcat - [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt bonus . to Left + [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt resultSheets . to Left | epEnt@(Entity epId ExamPart{..}) <- sortOn (examPartNumber . entityVal) examParts ] , pure $ sortable (Just "exam-result") (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) @@ -615,7 +619,7 @@ postEUsersR tid ssh csh examn = do <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) encodePartResults = fmap Map.fromList . forM examParts $ \epEnt@(Entity epId ExamPart{..}) -> (examPartNumber, ) <$> - preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt bonus) + preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt resultSheets) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser' csv @@ -954,7 +958,7 @@ postEUsersR tid ssh csh examn = do (First (Just act), regMap) <- inp let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap return (act, regMap') - (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + (, exam, (bonus, resultSheets)) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case (ExamUserDeregisterData, Map.elems -> selectedRegistrations) -> do @@ -976,9 +980,9 @@ postEUsersR tid ssh csh examn = do uid <- view $ resultUser . _entityKey hasResult <- asks $ has resultExamResult hasBonus <- asks $ has resultExamBonus - autoResult <- preview $ resultAutomaticExamResult examVal bonus + autoResult <- preview $ resultAutomaticExamResult examVal bonus resultSheets autoBonus <- preview $ resultAutomaticExamBonus examVal bonus - autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) bonus) + autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) resultSheets) lift $ if | not hasResult , Just examResultResult <- autoResult diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 4067785d5..f47afda21 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -30,6 +30,14 @@ import Data.Aeson.Lens import Handler.Submission.SubmissionUserInvite +data CorrectionInvisibleReason + = CorrectionInvisibleExamUnfinished + | CorrectionInvisibleRatingNotDone + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +embedRenderMessage ''UniWorX ''CorrectionInvisibleReason id + + makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode @@ -476,9 +484,26 @@ submissionHelper tid ssh csh shn mcid = do | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR Nothing -> return () - (Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo + (Entity _ Sheet{..}, buddies, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo - showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + (showCorrection, correctionVisible, correctionInvisibleReasons) <- fmap (fromMaybe (False, False, Set.empty)) . for mcid $ \cid -> runDB $ do + showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + correctionVisible <- allMOf (folded . _Right) buddies $ \bId -> is _Authorized <$> evalAccessFor (Just bId) (CSubmissionR tid ssh csh shn cid CorrectionR) False + + correctionInvisibleReasons <- if + | correctionVisible -> return Set.empty + | otherwise -> mapReaderT execWriterT $ do + unless (maybe True submissionRatingDone msubmission) $ + tellPoint CorrectionInvisibleRatingNotDone + maybeT (return ()) $ do + epId <- hoistMaybe $ sheetType ^? _examPart . from _SqlKey + ExamPart{examPartExam} <- MaybeT $ get epId + Exam{..} <- MaybeT $ get examPartExam + now <- liftIO getCurrentTime + unless (NTop (Just now) >= NTop examFinished) $ + tellPoint CorrectionInvisibleExamUnfinished + + return (showCorrection, correctionVisible, correctionInvisibleReasons) -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) @@ -557,7 +582,12 @@ submissionHelper tid ssh csh shn mcid = do -> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal tr <- getTranslate - let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> + let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingTouched msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment in $(widgetFile "correction-user") + where submissionRatingTouched sub@Submission{..} = or + [ submissionRatingDone sub + , is _Just submissionRatingPoints, is _Just submissionRatingComment + ] + correctionVisibleWarnWidget = guardOn (is _Just msubmission && is _Just mcid && showCorrection && not correctionVisible) $ notificationWidget NotificationBroad Warning $(widgetFile "submission-correction-invisible") $(widgetFile "submission") diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 10e4f9b00..26bdcc946 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -3,9 +3,9 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam - , examBonus, examBonusPossible, examBonusAchieved + , examRelevantSheets, examBonusPossible, examBonusAchieved , examResultBonus, examGrade - , getRelevantSheetsUpTo, examBonusGrade + , examBonusGrade , ExamAutoOccurrenceConfig , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize @@ -92,8 +92,11 @@ fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn -examBonus :: (MonadHandler m, MonadThrow m) => Entity Exam -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId)) -examBonus (Entity eId Exam{..}) = runConduit $ +examRelevantSheets :: (MonadHandler m, MonadThrow m) + => Entity Exam + -> Bool -- ^ relevant for bonus (restricted to sheet having `sheetActiveTo` before `examOccurrenceStart`)? + -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId)) +examRelevantSheets (Entity eId Exam{..}) forBonus = runConduit $ let rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) @@ -104,16 +107,17 @@ examBonus (Entity eId Exam{..}) = runConduit $ E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId - E.where_ $ E.case_ - [ E.when_ - ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) - E.then_ - ( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo) - E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart - ) - ] - ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom - ) + when forBonus $ + E.where_ $ E.case_ + [ E.when_ + ( E.isJust $ examRegistration E.^. ExamRegistrationOccurrence ) + E.then_ + ( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo) + E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart + ) + ] + ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom + ) return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission, sheet E.^. SheetCourse) accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do sheetType' <- fmap entityKey <$> resolveSheetType cId sheetType @@ -124,29 +128,6 @@ examBonusPossible, examBonusAchieved :: Ord epId => UserId -> Map UserId (SheetT examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap -getRelevantSheetsUpTo :: CourseId - -> UserId - -> Maybe UTCTime - -> DB (Map SheetId (SheetType SqlBackendKey, Maybe Points)) -getRelevantSheetsUpTo cid uid mCutoff - = fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ sheet E.^. SheetId ] $ do - E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) - E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid - E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId - ) - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - case mCutoff of - Just cutoff -> E.where_ $ E.maybe E.true (E.<=. E.val cutoff) (sheet E.^. SheetActiveTo) - E.&&. E.maybe E.false (E.<=. E.val cutoff) (sheet E.^. SheetVisibleFrom) - Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom - return (sheet E.^. SheetId, sheet E.^. SheetType, submission) - where - postprocess :: [(E.Value SheetId, E.Value (SheetType SqlBackendKey), Maybe (Entity Submission))] - -> Map SheetId (SheetType SqlBackendKey, Maybe Points) - postprocess = Map.fromList . map postprocess' - where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub) - = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints - diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 818824c03..ff9d9f601 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -722,7 +722,8 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify ) , ( ExamBonusPoints' , ExamBonusPoints - <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) + <$ wFormToAForm (pure () <$ (wformMessage =<< messageI Info MsgExamBonusInfoPoints)) + <*> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev) ) diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 4ab5bce08..780dd4767 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -146,4 +146,8 @@ sheetExamResult SheetTypeSummary{ examSummary = MergeMap examSummary'' } (Entity pointsWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (sumSheetsPoints gradeSummary - sumSheetsPassPoints gradeSummary > 0) $ Sum sWeight) examSummary' passesWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (numSheetsPasses gradeSummary > 0) $ Sum sWeight) examSummary' - in ExamAttended . roundToPoints . (* examPartWeight) . (* weightRescale) . getSum . fold $ foldMapM (fmap Sum . toExamPoints) examSummary' + in if | SheetGradeSummary{numMarked} <- foldOf (folded . _2) examSummary' + , numMarked <= 0 + -> ExamNoShow + | otherwise + -> ExamAttended . roundToPoints . (* examPartWeight) . (* weightRescale) . getSum . fold $ foldMapM (fmap Sum . toExamPoints) examSummary' diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index a7fa4d442..756d69750 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -70,6 +70,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthStaffTime | AuthAllocationTime | AuthCourseTime + | AuthExamTime | AuthMaterials | AuthOwner | AuthPersonalisedSheetFiles diff --git a/src/Utils.hs b/src/Utils.hs index c980269dd..e2a820d87 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -8,7 +8,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold import Data.Foldable as Utils (foldlM, foldrM) -import Data.Monoid (First, Sum(..)) +import Data.Monoid (First, Sum(..), Endo) import Data.Proxy import Control.Arrow (Kleisli(..)) import Control.Arrow.Instances () @@ -891,6 +891,10 @@ allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) - allM xs f = andM . fmap f $ otoList xs anyM xs f = orM . fmap f $ otoList xs +allMOf, anyMOf :: Monad m => Getting (Endo [a]) s a -> s -> (a -> m Bool) -> m Bool +allMOf l x = allM $ x ^.. l +anyMOf l x = anyM $ x ^.. l + ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono) ofoldr1M f (otoList -> x:xs) = foldrM f x xs ofoldr1M _ _ = error "otoList of NonNull is empty" diff --git a/templates/submission-correction-invisible.hamlet b/templates/submission-correction-invisible.hamlet new file mode 100644 index 000000000..c9e7c92f2 --- /dev/null +++ b/templates/submission-correction-invisible.hamlet @@ -0,0 +1,10 @@ +$newline never + +_{MsgCorrectionInvisibleWarning} + +$if not (null correctionInvisibleReasons) +
+ _{MsgCorrectionInvisibleReasons} +