fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(exams): automatically compute examResults

Browse Source 
BREAKING CHANGE: examPartName no longer required
This commit is contained in:
Gregor Kleen 2019-09-18 17:17:18 +02:00
parent fb1e42dc69
commit ea5a398bab
13 changed files with 361 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
messages/uniworx/de.msg
View File

@ -1347,6 +1347,8 @@ ExamBonusRule: Prüfungsbonus aus Übungsbetrieb
ExamNoBonus': Kein automatischer Bonus ExamNoBonus': Kein automatischer Bonus
ExamBonusPoints': Umrechnung von Übungspunkten ExamBonusPoints': Umrechnung von Übungspunkten
ExamBonusAchieved: Bonuspunkte
ExamEditHeading examn@ExamName: #{examn} bearbeiten ExamEditHeading examn@ExamName: #{examn} bearbeiten
ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte
@ -1393,8 +1395,9 @@ ExamParts: Teilprüfungen/Aufgaben
ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits
ExamPartNumber: Nummer ExamPartNumber: Nummer
ExamPartNumbered examPartNumber@ExamPartNumber: Teil #{view _ExamPartNumber examPartNumber}
ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet
ExamPartName: Name ExamPartName: Titel
ExamPartNameTip: Wird den Studierenden angezeigt ExamPartNameTip: Wird den Studierenden angezeigt
ExamPartMaxPoints: Maximalpunktzahl ExamPartMaxPoints: Maximalpunktzahl
ExamPartWeight: Gewichtung ExamPartWeight: Gewichtung
@ -1496,6 +1499,7 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun
CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können
CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können
CsvColumnExamUserBonus: Anzurechnende Bonuspunkte
CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
CsvColumnExamUserCourseNote: Notizen zum Teilnehmer CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
@ -1527,10 +1531,13 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
ExamUserCsvOverrideBonus: Bonuspunkte entgegen Bonusregelung überschreiben
ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben
ExamUserCsvSetBonus: Bonuspunkte eintragen
ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvSetResult: Ergebnis eintragen
ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen
ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
ExamBonusNone: Keine Bonuspunkte
ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht

10
models/exams
View File

@ -20,11 +20,11 @@ Exam
ExamPart ExamPart
exam ExamId exam ExamId
number ExamPartNumber number ExamPartNumber
name ExamPartName name ExamPartName Maybe
maxPoints Points Maybe maxPoints Points Maybe
weight Rational weight Rational
UniqueExamPartNumber exam number UniqueExamPartNumber exam number
UniqueExamPartName exam name UniqueExamPartName exam name !force
ExamOccurrence ExamOccurrence
exam ExamId exam ExamId
name ExamOccurrenceName name ExamOccurrenceName
@ -46,6 +46,12 @@ ExamPartResult
result ExamResultPoints result ExamResultPoints
lastChanged UTCTime default=now() lastChanged UTCTime default=now()
UniqueExamPartResult examPart user UniqueExamPartResult examPart user
ExamBonus
exam ExamId
user UserId
bonus Points
lastChanged UTCTime default=now()
UniqueExamBonus exam user
ExamResult ExamResult
exam ExamId exam ExamId
user UserId user UserId

9
src/Audit/Types.hs
View File

@ -33,6 +33,15 @@ data Transaction
, transactionUser :: UserId , transactionUser :: UserId
} }
| TransactionExamBonusEdit
{ transactionExam :: ExamId
, transactionUser :: UserId
}
| TransactionExamBonusDeleted
{ transactionExam :: ExamId
, transactionUser :: UserId
}
| TransactionExamResultEdit | TransactionExamResultEdit
{ transactionExam :: ExamId { transactionExam :: ExamId
, transactionUser :: UserId , transactionUser :: UserId

7
src/Handler/Exam/Form.hs
View File

@ -57,7 +57,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm
data ExamPartForm = ExamPartForm data ExamPartForm = ExamPartForm
{ epfId :: Maybe CryptoUUIDExamPart { epfId :: Maybe CryptoUUIDExamPart
, epfNumber :: ExamPartNumber , epfNumber :: ExamPartNumber
, epfName :: ExamPartName , epfName :: Maybe ExamPartName
, epfMaxPoints :: Maybe Points , epfMaxPoints :: Maybe Points
, epfWeight :: Rational , epfWeight :: Rational
} deriving (Read, Show, Eq, Ord, Generic, Typeable) } deriving (Read, Show, Eq, Ord, Generic, Typeable)
@ -202,7 +202,7 @@ examPartsForm prev = wFormToAForm $ do
examPartForm' nudge mPrev csrf = do examPartForm' nudge mPrev csrf = do
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
(epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev) (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
(epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev)
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
(epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
@ -220,7 +220,8 @@ examPartsForm prev = wFormToAForm $ do
(res, formWidget) <- examPartForm' nudge Nothing csrf (res, formWidget) <- examPartForm' nudge Nothing csrf
let let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
| any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
-> FormFailure [mr MsgExamPartAlreadyExists]
| otherwise -> FormSuccess $ pure newDat | otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examParts/add")) return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
miCell' nudge dat = examPartForm' nudge (Just dat) miCell' nudge dat = examPartForm' nudge (Just dat)

10
src/Handler/Exam/Show.hs
View File

@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
mUid <- maybeAuthId mUid <- maybeAuthId
(Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@ -62,9 +62,13 @@ getEShowR tid ssh csh examn = do
registered <- for mUid $ existsBy . UniqueExamRegistration eId registered <- for mUid $ existsBy . UniqueExamRegistration eId
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), lecturerInfoShown)
let occurrenceNamesShown = lecturerInfoShown
partNumbersShown = lecturerInfoShown
examClosedShown = lecturerInfoShown
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
registerWidget registerWidget

325
src/Handler/Exam/Users.hs
View File

@ -48,6 +48,7 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration)
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
) )
) )
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
type ExamUserTableData = DBRow ( Entity ExamRegistration type ExamUserTableData = DBRow ( Entity ExamRegistration
@ -56,6 +57,7 @@ type ExamUserTableData = DBRow ( Entity ExamRegistration
, Maybe (Entity StudyFeatures) , Maybe (Entity StudyFeatures)
, Maybe (Entity StudyDegree) , Maybe (Entity StudyDegree)
, Maybe (Entity StudyTerms) , Maybe (Entity StudyTerms)
, Maybe (Entity ExamBonus)
, Maybe (Entity ExamResult) , Maybe (Entity ExamResult)
, Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
, Maybe (Entity CourseUserNote) , Maybe (Entity CourseUserNote)
@ -71,28 +73,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
_userTableOccurrence = _dbrOutput . _3 _userTableOccurrence = _dbrOutput . _3
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1)
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1)
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
queryExamOccurrence = $(sqlLOJproj 5 2) queryExamOccurrence = $(sqlLOJproj 6 2)
queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
queryExamBonus = $(sqlLOJproj 6 4)
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
queryExamResult = $(sqlLOJproj 5 4) queryExamResult = $(sqlLOJproj 6 5)
queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryCourseNote = $(sqlLOJproj 5 5) queryCourseNote = $(sqlLOJproj 6 6)
queryExamPart :: forall a.
PersistField a
=> ExamPartId
-> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
-> ExamUserTableExpr
-> E.SqlExpr (E.Value a)
queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
examRegistration <- asks queryExamRegistration
lift $ do
E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart
E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser)
E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam
E.&&. examPart E.^. ExamPartId E.==. E.val epId
cont examPart examPartResult
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
resultExamRegistration = _dbrOutput . _1 resultExamRegistration = _dbrOutput . _1
@ -112,23 +137,36 @@ resultStudyField = _dbrOutput . _6 . _Just
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just resultExamOccurrence = _dbrOutput . _3 . _Just
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
resultExamBonus = _dbrOutput . _7 . _Just
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _7 . _Just resultExamResult = _dbrOutput . _8 . _Just
resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
resultExamParts = _dbrOutput . _8 . itraversed resultExamParts = _dbrOutput . _9 . itraversed
-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart) -- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity -- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
-- resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
-- resultExamPartResult epId = _dbrOutput . _8 . unsafeSingular (ix epId) . _2 resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2
-- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
-- resultExamPartResults = resultExamParts <. _2 resultExamPartResults = resultExamParts <. _2
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
resultCourseNote = _dbrOutput . _9 . _Just resultCourseNote = _dbrOutput . _10 . _Just
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> examBonusPossible uid examBonus' <*> examBonusAchieved uid examBonus')
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
resultAutomaticExamResult exam examBonus' = folding . runReader $ do
parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
return $ examGrade exam bonus =<< parts'
csvExamPartHeader :: Prism' Csv.Name ExamPartNumber csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
@ -151,10 +189,11 @@ data ExamUserTableCsv = ExamUserTableCsv
, csvEUserDegree :: Maybe Text , csvEUserDegree :: Maybe Text
, csvEUserSemester :: Maybe Int , csvEUserSemester :: Maybe Int
, csvEUserOccurrence :: Maybe (CI Text) , csvEUserOccurrence :: Maybe (CI Text)
, csvEUserExercisePoints :: Maybe Points , csvEUserExercisePoints :: Maybe (Maybe Points)
, csvEUserExerciseNumPasses :: Maybe Int , csvEUserExerciseNumPasses :: Maybe (Maybe Int)
, csvEUserExercisePointsMax :: Maybe Points , csvEUserExercisePointsMax :: Maybe (Maybe Points)
, csvEUserExerciseNumPassesMax :: Maybe Int , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int)
, csvEUserBonus :: Maybe (Maybe Points)
, csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints) , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
, csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserExamResult :: Maybe ExamResultPassedGrade
, csvEUserCourseNote :: Maybe Html , csvEUserCourseNote :: Maybe Html
@ -172,11 +211,14 @@ instance ToNamedRecord ExamUserTableCsv where
, "degree" Csv..= csvEUserDegree , "degree" Csv..= csvEUserDegree
, "semester" Csv..= csvEUserSemester , "semester" Csv..= csvEUserSemester
, "occurrence" Csv..= csvEUserOccurrence , "occurrence" Csv..= csvEUserOccurrence
, "exercise-points" Csv..= csvEUserExercisePoints ] ++ catMaybes
, "exercise-num-passes" Csv..= csvEUserExerciseNumPasses [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints
, "exercise-points-max" Csv..= csvEUserExercisePointsMax , fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses
, "exercise-num-passes-max" Csv..= csvEUserExerciseNumPassesMax , fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax
] ++ examPartResults ++ , fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax
, fmap ("bonus" Csv..=) csvEUserBonus
]
++ examPartResults ++
[ "exam-result" Csv..= csvEUserExamResult [ "exam-result" Csv..= csvEUserExamResult
, "course-note" Csv..= csvEUserCourseNote , "course-note" Csv..= csvEUserCourseNote
] ]
@ -196,10 +238,11 @@ instance FromNamedRecord ExamUserTableCsv where
<*> csv .:?? "degree" <*> csv .:?? "degree"
<*> csv .:?? "semester" <*> csv .:?? "semester"
<*> csv .:?? "occurrence" <*> csv .:?? "occurrence"
<*> csv .:?? "exercise-points" <*> fmap Just (csv .:?? "exercise-points")
<*> csv .:?? "exercise-num-passes" <*> fmap Just (csv .:?? "exercise-num-passes")
<*> csv .:?? "exercise-points-max" <*> fmap Just (csv .:?? "exercise-points-max")
<*> csv .:?? "exercise-num-passes-max" <*> fmap Just (csv .:?? "exercise-num-passes-max")
<*> fmap Just (csv .:?? "bonus")
<*> examPartResults <*> examPartResults
<*> csv .:?? "exam-result" <*> csv .:?? "exam-result"
<*> csv .:?? "course-note" <*> csv .:?? "course-note"
@ -222,6 +265,7 @@ instance CsvColumnsExplained ExamUserTableCsv where
, single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses
, single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax
, single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
, single "bonus" MsgCsvColumnExamUserBonus
, single "exam-result" MsgCsvColumnExamUserResult , single "exam-result" MsgCsvColumnExamUserResult
, single "course-note" MsgCsvColumnExamUserCourseNote , single "course-note" MsgCsvColumnExamUserCourseNote
] ]
@ -232,17 +276,22 @@ instance CsvColumnsExplained ExamUserTableCsv where
examUserTableCsvHeader :: ( MonoFoldable mono examUserTableCsvHeader :: ( MonoFoldable mono
, Element mono ~ ExamPartNumber , Element mono ~ ExamPartNumber
) )
=> mono -> Csv.Header => SheetGradeSummary -> Bool -> mono -> Csv.Header
examUserTableCsvHeader pNames = Csv.header $ examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
[ "surname", "first-name", "name" [ "surname", "first-name", "name"
, "matriculation" , "matriculation"
, "field", "degree", "semester" , "field", "degree", "semester"
, "course-note" , "course-note"
, "occurrence" , "occurrence"
, "exercise-points", "exercise-num-passes", "exercise-points-max", "exercise-num-passes-max" ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints)
] ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++ ++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses)
++ bool mempty ["bonus"] doBonus
++ map (review csvExamPartHeader) (sort $ otoList pNames) ++
[ "exam-result" [ "exam-result"
] ]
where
showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0
data ExamUserAction = ExamUserDeregister data ExamUserAction = ExamUserDeregister
| ExamUserAssignOccurrence | ExamUserAssignOccurrence
@ -262,6 +311,8 @@ data ExamUserCsvActionClass
| ExamUserCsvAssignOccurrence | ExamUserCsvAssignOccurrence
| ExamUserCsvSetCourseField | ExamUserCsvSetCourseField
| ExamUserCsvSetPartResult | ExamUserCsvSetPartResult
| ExamUserCsvSetBonus
| ExamUserCsvOverrideBonus
| ExamUserCsvSetResult | ExamUserCsvSetResult
| ExamUserCsvOverrideResult | ExamUserCsvOverrideResult
| ExamUserCsvSetCourseNote | ExamUserCsvSetCourseNote
@ -295,6 +346,11 @@ data ExamUserCsvAction
, examUserCsvActExamPart :: ExamPartNumber , examUserCsvActExamPart :: ExamPartNumber
, examUserCsvActExamPartResult :: Maybe ExamResultPoints , examUserCsvActExamPartResult :: Maybe ExamResultPoints
} }
| ExamUserCsvSetBonusData
{ examUserCsvIsBonusOverride :: Bool
, examUserCsvActUser :: UserId
, examUserCsvActExamBonus :: Maybe Points
}
| ExamUserCsvSetResultData | ExamUserCsvSetResultData
{ examUserCsvIsResultOverride :: Bool { examUserCsvIsResultOverride :: Bool
, examUserCsvActUser :: UserId , examUserCsvActUser :: UserId
@ -325,46 +381,88 @@ getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName ->
getEUsersR = postEUsersR getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do postEUsersR tid ssh csh examn = do
((registrationResult, examUsersTable), Entity eId _) <- runDB $ do ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
bonus <- examBonus exam bonus <- examBonus exam
let let
allBoni :: SheetGradeSummary
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0 doBonus = is _Just examGradingRule || is _Just examBonusRule
showPasses = doBonus && numSheetsPasses allBoni /= 0
showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
resultView :: ExamResultGrade -> ExamResultPassedGrade resultView :: ExamResultGrade -> ExamResultPassedGrade
resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
resultAutomaticExamBonus' :: Fold ExamUserTableData Points
resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
automaticCell :: forall msg m a r.
( RenderMessage UniWorX msg
, IsDBTable m a
, Eq msg
)
=> Getting (Endo [Either msg msg]) r (Either msg msg)
-> r
-> DBCell m a
automaticCell l r = case toListOf l r of
[] -> mempty
(Left auto : _)
-> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")]
(Right man : others)
| all ((== man) . either id id) others
-> i18nCell man
| otherwise
-> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")]
csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
let let
examUsersDBTable = DBTable{..} examUsersDBTable = DBTable{..}
where where
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do dbtSQLQuery = runReaderT $ do
E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) examRegistration <- asks queryExamRegistration
E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) user <- asks queryUser
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) occurrence <- asks queryExamOccurrence
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) courseParticipant <- asks queryCourseParticipant
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField studyFeatures <- asks queryStudyFeatures
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree studyDegree <- asks queryStudyDegree
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) studyField <- asks queryStudyField
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) examBonus' <- asks queryExamBonus
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) examResult <- asks queryExamResult
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) courseUserNote <- asks queryCourseNote
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId lift $ do
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId)
E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid)
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote)
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
(,,,,,,,,) (,,,,,,,,,)
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8
<*> getExamParts <*> getExamParts
<*> view _8 <*> view _9
where where
getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts = do getExamParts = do
@ -395,25 +493,33 @@ postEUsersR tid ssh csh examn = do
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
, guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
, guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) , pure $ mconcat
[ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
| Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
]
, pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
, pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
] ]
dbtSorting = Map.fromList dbtSorting = mconcat
[ sortUserNameLink queryUser [ uncurry singletonMap $ sortUserNameLink queryUser
, sortUserMatriclenr queryUser , uncurry singletonMap $ sortUserMatriclenr queryUser
, sortField queryStudyField , uncurry singletonMap $ sortField queryStudyField
, sortDegreeShort queryStudyDegree , uncurry singletonMap $ sortDegreeShort queryStudyDegree
, sortFeaturesSemester queryStudyFeatures , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , mconcat
, ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
, ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) | Entity epId ExamPart{..} <- examParts
, ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date ]
, singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
, singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
E.sub_select . E.from $ \edit -> do E.sub_select . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser [ fltrUserNameEmail queryUser
@ -479,7 +585,7 @@ postEUsersR tid ssh csh examn = do
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName = unpack csvName , dbtCsvName = unpack csvName
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader $ examParts ^.. folded . _entityVal . _examPartNumber , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
} }
where where
doEncode' = ExamUserTableCsv doEncode' = ExamUserTableCsv
@ -491,12 +597,13 @@ postEUsersR tid ssh csh examn = do
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints)
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
<*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
<*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
<*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
dbtCsvDecode = Just DBTCsvDecode dbtCsvDecode = Just DBTCsvDecode
{ dbtCsvRowKey = \csv -> do { dbtCsvRowKey = \csv -> do
@ -523,6 +630,9 @@ postEUsersR tid ssh csh examn = do
when (epNumber `elem` examPartNumbers) $ when (epNumber `elem` examPartNumbers) $
yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
when (is _Just . join $ csvEUserBonus dbCsvNew) $
yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
when (is _Just $ csvEUserExamResult dbCsvNew) $ when (is _Just $ csvEUserExamResult dbCsvNew) $
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
@ -547,27 +657,39 @@ postEUsersR tid ssh csh examn = do
when (epRes /= oldPartResult) $ when (epRes /= oldPartResult) $
yield $ ExamUserCsvSetPartResultData uid epNumber epRes yield $ ExamUserCsvSetPartResultData uid epNumber epRes
let newResults :: Map ExamPartNumber (Maybe ExamResultPoints) let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
newResults = csvEUserExamPartResults dbCsvNew newResults = sequence (csvEUserExamPartResults dbCsvNew)
`Map.union` toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
newGrade :: Maybe ExamResultPassedGrade newBonus, oldBonus :: Maybe Points
newGrade = do newBonus = join (csvEUserBonus dbCsvNew)
possible <- examBonusPossible uid bonus oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
achieved <- examBonusAchieved uid bonus
resultView <$> examGrade exam possible achieved (newResults ^.. folded . _Just)
oldResult = dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView newResult, oldResult :: Maybe ExamResultPassedGrade
newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
case newGrade of case newBonus of
_ | newBonus == oldBonus
-> return ()
_ | is _Nothing newBonus
-> return ()
Nothing
-> yield $ ExamUserCsvSetBonusData False uid newBonus
Just _
-> yield $ ExamUserCsvSetBonusData True uid newBonus
case newResult of
_ | csvEUserExamResult dbCsvNew == oldResult _ | csvEUserExamResult dbCsvNew == oldResult
-> return () -> return ()
_ | is _Nothing $ csvEUserExamResult dbCsvNew
-> return ()
Nothing Nothing
-> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
Just _ Just _
| csvEUserExamResult dbCsvNew /= newGrade | csvEUserExamResult dbCsvNew /= newResult
-> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
| oldResult /= newGrade | oldResult /= newResult
-> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
| otherwise | otherwise
-> return () -> return ()
@ -581,6 +703,9 @@ postEUsersR tid ssh csh examn = do
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
ExamUserCsvSetBonusData{..}
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
| otherwise -> ExamUserCsvSetBonus
ExamUserCsvSetResultData{..} ExamUserCsvSetResultData{..}
| examUserCsvIsResultOverride -> ExamUserCsvOverrideResult | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult
| otherwise -> ExamUserCsvSetResult | otherwise -> ExamUserCsvSetResult
@ -639,6 +764,19 @@ postEUsersR tid ssh csh examn = do
, ExamPartResultLastChanged =. now , ExamPartResultLastChanged =. now
] ]
audit $ TransactionExamPartResultEdit epid examUserCsvActUser audit $ TransactionExamPartResultEdit epid examUserCsvActUser
ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of
Nothing -> do
deleteBy $ UniqueExamBonus eid examUserCsvActUser
audit $ TransactionExamBonusDeleted eid examUserCsvActUser
Just res -> do
now <- liftIO getCurrentTime
void $ upsertBy
(UniqueExamBonus eid examUserCsvActUser)
(ExamBonus eid examUserCsvActUser res now)
[ ExamBonusBonus =. res
, ExamBonusLastChanged =. now
]
audit $ TransactionExamBonusEdit eid examUserCsvActUser
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
Nothing -> do Nothing -> do
deleteBy $ UniqueExamResult eid examUserCsvActUser deleteBy $ UniqueExamResult eid examUserCsvActUser
@ -724,12 +862,25 @@ postEUsersR tid ssh csh examn = do
[whamlet| [whamlet|
$newline never $newline never
^{nameWidget userDisplayName userSurname} ^{nameWidget userDisplayName userSurname}
, „#{examPartName}“ $maybe pName <- examPartName
, „#{pName}“
$nothing
, _{MsgExamPartNumbered examPartNumber}
$maybe newResult <- examUserCsvActExamPartResult $maybe newResult <- examUserCsvActExamPartResult
, _{newResult} , _{newResult}
$nothing $nothing
, _{MsgExamResultNone} , _{MsgExamResultNone}
|] |]
ExamUserCsvSetBonusData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe newBonus <- examUserCsvActExamBonus
, _{newBonus}
$nothing
, _{MsgExamBonusNone}
|]
ExamUserCsvSetResultData{..} -> do ExamUserCsvSetResultData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
[whamlet| [whamlet|

69
src/Handler/Utils/Exam.hs
View File

@ -2,7 +2,7 @@ module Handler.Utils.Exam
( fetchExamAux ( fetchExamAux
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
, examBonus, examBonusPossible, examBonusAchieved , examBonus, examBonusPossible, examBonusAchieved
, examGrade , examResultBonus, examGrade
) where ) where
import Import.NoFoundation import Import.NoFoundation
@ -84,18 +84,42 @@ examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap
examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap
examResultBonus :: ExamBonusRule
-> SheetGradeSummary -- ^ `examBonusPossible`
-> SheetGradeSummary -- ^ `examBonusAchieved`
-> Points
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
ExamBonusPoints{..}
-> roundToPoints $ toRational bonusMaxPoints * bonusProp
where
bonusProp :: Rational
bonusProp
| possible <= 0 = 1
| otherwise = achieved / possible
where
achieved = toRational (getSum $ achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)
possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
scalePasses :: Integer -> Rational
-- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
scalePasses passes
| passesPossible <= 0 = 0
| otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
where
passesPossible = getSum $ numSheetsPasses bonusPossible
pointsPossible = getSum $ sumSheetsPoints bonusPossible
roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a))
examGrade :: ( MonoFoldable mono examGrade :: ( MonoFoldable mono
, Element mono ~ ExamResultPoints , Element mono ~ ExamResultPoints
) )
=> Entity Exam => Exam
-> SheetGradeSummary -- ^ `examBonusPossible` -> Maybe Points -- ^ Bonus
-> SheetGradeSummary -- ^ `examBonusAchieved`
-> mono -- ^ `ExamPartResult`s -> mono -- ^ `ExamPartResult`s
-> Maybe ExamResultGrade -> Maybe ExamResultGrade
examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results) examGrade Exam{..} mBonus (otoList -> results)
| null results
= Nothing
| otherwise
= traverse pointsToGrade achievedPoints' = traverse pointsToGrade achievedPoints'
where where
achievedPoints' :: ExamResultPoints achievedPoints' :: ExamResultPoints
@ -103,37 +127,24 @@ examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results)
withBonus :: Points -> Points withBonus :: Points -> Points
withBonus ps withBonus ps
| Just ExamBonusPoints{..} <- examBonusRule | Just bonusRule <- examBonusRule
= if = if
| not bonusOnlyPassed | maybe True not (bonusRule ^? _bonusOnlyPassed)
|| fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True) || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
-> ps + roundToPoints (toRational bonusMaxPoints * bonusProp) -> maybe id (+) mBonus ps
| otherwise | otherwise
-> ps -> ps
| otherwise | otherwise
= ps = ps
where
bonusProp :: Rational
bonusProp = clamp 0 1 $ toRational (getSum (achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved))
/ toRational (getSum (sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible))
where
scalePasses :: Integer -> Points
-- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
scalePasses passes = fromInteger passes / (fromInteger . getSum $ numSheetsPasses bonusPossible) * (getSum $ sumSheetsPoints bonusPossible)
roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a))
pointsToGrade :: Points -> Maybe ExamGrade pointsToGrade :: Points -> Maybe ExamGrade
pointsToGrade ps pointsToGrade ps = examGradingRule <&> \case
| Just ExamGradingKey{..} <- examGradingRule ExamGradingKey{..}
= Just $ gradeFromKey examGradingKey -> gradeFromKey examGradingKey
| otherwise
= Nothing
where where
gradeFromKey :: [Points] -> ExamGrade gradeFromKey :: [Points] -> ExamGrade
gradeFromKey examGradingKey' = maximum $ impureNonNull [ g | (g, b) <- lowerBounds, b <= clampMin 0 ps ] gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
where where
lowerBounds :: [(ExamGrade, Points)] lowerBounds :: [(ExamGrade, Points)]
lowerBounds = zip [Grade50, Grade40 ..] $ 0 : examGradingKey' lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'

3
src/Utils.hs
View File

@ -241,7 +241,8 @@ stepTextCounter text
notUsedT :: a -> Text notUsedT :: a -> Text
notUsedT = notUsed notUsedT = notUsed
fromText :: (IsString a, Textual t) => t -> a
fromText = fromString . unpack
---------- ----------
-- Bool -- -- Bool --

1
src/Utils/Lens.hs
View File

@ -167,6 +167,7 @@ makeLenses_ ''Invitation
makeLenses_ ''ExamBonusRule makeLenses_ ''ExamBonusRule
makeLenses_ ''ExamGradingRule makeLenses_ ''ExamGradingRule
makeLenses_ ''ExamResult makeLenses_ ''ExamResult
makeLenses_ ''ExamBonus
makeLenses_ ''ExamPart makeLenses_ ''ExamPart
makeLenses_ ''ExamPartResult makeLenses_ ''ExamPartResult

9
templates/corrections-overview.hamlet
View File

@ -57,9 +57,7 @@
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table $# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall shn <- orderedSheetNames $forall shn <- orderedSheetNames
<th .table__th colspan=5> <th .table__th colspan=5>
$# Links currently look ugly in table headers; used an icon as a workaround: ^{simpleLink (toWidget shn) (CSheetR tid ssh csh shn SShowR)}
^{simpleLink (toWidget iconLink) (CSheetR tid ssh csh shn SShowR)}
#{shn}
<tr .table__row .table__row--head> <tr .table__row .table__row--head>
<th .table__th>_{MsgNrSubmissionsTotal} <th .table__th>_{MsgNrSubmissionsTotal}
<th .table__th>_{MsgNrSubmissionsNotCorrected} <th .table__th>_{MsgNrSubmissionsNotCorrected}
@ -140,8 +138,9 @@
<th colspan=3> <th colspan=3>
$# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table $# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
$forall shn <- orderedSheetNames $forall shn <- orderedSheetNames
<th .table__th colspan=5>#{shn} <th .table__th colspan=5>
^{simpleLink (toWidget shn) (CSheetR tid ssh csh shn SShowR)}
^{btnWdgt} ^{btnWdgt}
<div> <div>
<p>_{MsgAssignSubmissionsRandomWarning} <p>_{MsgAssignSubmissionsRandomWarning}

29
templates/default-layout.lucius
View File

@ -366,11 +366,20 @@ input[type="button"].btn-info:hover,
vertical-align: top; vertical-align: top;
} }
.table__td--automatic {
font-style: oblique;
color: var(--color-fontsec);
}
.table__td--overriden {
font-weight: bold;
}
.table__th { .table__th {
background-color: var(--color-dark); background-color: var(--color-dark);
position: relative; position: relative;
font-size: 16px; font-size: 16px;
color: #fff; color: white;
line-height: 1.4; line-height: 1.4;
padding-top: 10px; padding-top: 10px;
padding-bottom: 10px; padding-bottom: 10px;
@ -378,7 +387,20 @@ input[type="button"].btn-info:hover,
text-align: left; text-align: left;
a { a {
color: white;
text-decoration: none; text-decoration: none;
font-weight: bold;
&:hover {
color: inherit;
}
&::before {
content: "\f0c1";
font-family: "Font Awesome 5 Free";
font-weight: 900;
margin-right: 0.25em;
}
} }
} }
@ -395,11 +417,10 @@ input[type="button"].btn-info:hover,
} }
.table__th-link { .table__th-link {
color: white;
font-weight: bold; font-weight: bold;
&:hover { &::before {
color: inherit; display: none;
} }
} }

20
templates/exam-show.hamlet
View File

@ -55,9 +55,10 @@ $maybe desc <- examDescription
$maybe finished <- examFinished $maybe finished <- examFinished
<dt .deflist__dt>_{MsgExamFinishedParticipant} <dt .deflist__dt>_{MsgExamFinishedParticipant}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime finished} <dd .deflist__dd>^{formatTimeW SelFormatDateTime finished}
$maybe closed <- examClosed $if examClosedShown
<dt .deflist__dt>_{MsgExamClosed} $maybe closed <- examClosed
<dd .deflist__dd>^{formatTimeW SelFormatDateTime closed} <dt .deflist__dt>_{MsgExamClosed} ^{isVisible False}
<dd .deflist__dd>^{formatTimeW SelFormatDateTime closed}
$if gradingShown $if gradingShown
$maybe gradingRule <- examGradingRule $maybe gradingRule <- examGradingRule
<dt .deflist__dt> <dt .deflist__dt>
@ -137,7 +138,9 @@ $if gradingShown && not (null examParts)
<table .table .table--striped .table--hover > <table .table .table--striped .table--hover >
<thead> <thead>
<tr .table__row .table__row--head> <tr .table__row .table__row--head>
<th .table__th>_{MsgExamPartNumber} $if partNumbersShown
<th .table__th>
_{MsgExamPartNumber} ^{isVisible False}
<th .table__th>_{MsgExamPartName} <th .table__th>_{MsgExamPartName}
$if showMaxPoints $if showMaxPoints
<th .table__th>_{MsgExamPartMaxPoints} <th .table__th>_{MsgExamPartMaxPoints}
@ -146,8 +149,13 @@ $if gradingShown && not (null examParts)
<tbody> <tbody>
$forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts
<tr .table__row> <tr .table__row>
<td .table__td>#{examPartNumber} $if partNumbersShown
<td .table__td>#{examPartName} <td .table__td>#{examPartNumber}
<td .table__td>
$maybe pName <- examPartName
#{pName}
$nothing
_{MsgExamPartNumbered examPartNumber}
$if showMaxPoints $if showMaxPoints
<td .table__td> <td .table__td>
$maybe mPoints <- examPartMaxPoints $maybe mPoints <- examPartMaxPoints

4
templates/widgets/massinput/examParts/layout.hamlet
View File

@ -5,9 +5,7 @@ $newline never
<th> <th>
_{MsgExamPartNumber} # _{MsgExamPartNumber} #
<span .form-group__required-marker> <span .form-group__required-marker>
<th> <th>_{MsgExamPartName}
_{MsgExamPartName} #
<span .form-group__required-marker>
<th>_{MsgExamPartMaxPoints} <th>_{MsgExamPartMaxPoints}
<th> <th>
_{MsgExamPartWeight} # _{MsgExamPartWeight} #