feat(submissions): improve behaviour of sheet-type-exam-part
Fixes #676
This commit is contained in:
Gregor Kleen
parent
8bdaae0881
commit
91a51664c3
@ -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:
|
||||
@ -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:
|
||||
|
||||
2
routes
2
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
)
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -70,6 +70,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthStaffTime
|
||||
| AuthAllocationTime
|
||||
| AuthCourseTime
|
||||
| AuthExamTime
|
||||
| AuthMaterials
|
||||
| AuthOwner
|
||||
| AuthPersonalisedSheetFiles
|
||||
|
||||
@ -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"
|
||||
|
||||
10
templates/submission-correction-invisible.hamlet
Normal file
10
templates/submission-correction-invisible.hamlet
Normal file
@ -0,0 +1,10 @@
|
||||
$newline never
|
||||
|
||||
_{MsgCorrectionInvisibleWarning}
|
||||
|
||||
$if not (null correctionInvisibleReasons)
|
||||
<br />
|
||||
_{MsgCorrectionInvisibleReasons}
|
||||
<ul>
|
||||
$forall reason <- correctionInvisibleReasons
|
||||
<li>_{reason}
|
||||
@ -1,8 +1,12 @@
|
||||
$newline never
|
||||
$maybe _ <- mcid
|
||||
$if is _Just mcid
|
||||
$maybe wdgt <- correctionWdgt
|
||||
<section>
|
||||
<h2>_{MsgRating}
|
||||
|
||||
$maybe warning <- correctionVisibleWarnWidget
|
||||
^{warning}
|
||||
|
||||
^{wdgt}
|
||||
|
||||
<section>
|
||||
@ -44,5 +48,5 @@ $maybe _ <- mcid
|
||||
<section>
|
||||
<h2>_{MsgSubmissionReplace}
|
||||
^{formWidget}
|
||||
$nothing
|
||||
$else
|
||||
^{formWidget}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user