From 932145ccf794cffce396ddb2d85f01e74d1c7c75 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 16:59:09 +0200 Subject: [PATCH] feat(exams): csv-based grade upload --- messages/uniworx/de.msg | 5 ++- src/Handler/Exam/Users.hs | 66 ++++++++++++++++++++++++++++++-------- src/Model/Types/Exam.hs | 22 +++++++++++-- src/Utils.hs | 1 + src/Utils/Csv.hs | 19 +++++++++++ templates/exam-show.hamlet | 4 +-- 6 files changed, 98 insertions(+), 19 deletions(-) create mode 100644 src/Utils/Csv.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 62fdc716d..4d43a6a1e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1250,6 +1250,7 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Klausurtermin erreichen hätte können CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können +CsvColumnExamResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") Action: Aktion @@ -1263,6 +1264,7 @@ ExamUserCsvRegister: Kursteilnehmer zur Klausur anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern +ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden @@ -1274,4 +1276,5 @@ TableHeadingCsvExport: CSV-Export ExamResultAttended: Teilgenommen ExamResultNoShow: Nicht erschienen -ExamResultVoided: Entwertet \ No newline at end of file +ExamResultVoided: Entwertet +ExamResultNone: Kein Klausurergebnis \ No newline at end of file diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 0d2604336..3bfecea7c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -99,11 +99,13 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserSemester :: Maybe Int , csvEUserOccurrence :: Maybe (CI Text) , csvEUserExercisePoints :: Maybe Points - , csvEUserExercisePasses :: Maybe Int + , csvEUserExerciseNumPasses :: Maybe Int , csvEUserExercisePointsMax :: Maybe Points - , csvEUserExercisePassesMax :: Maybe Int + , csvEUserExerciseNumPassesMax :: Maybe Int + , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) } deriving (Generic) +makeLenses_ ''ExamUserTableCsv examUserTableCsvOptions :: Csv.Options examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } @@ -119,17 +121,18 @@ instance DefaultOrdered ExamUserTableCsv where instance CsvColumnsExplained ExamUserTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList - [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) - , ('csvEUserName , MsgCsvColumnExamUserName ) - , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) - , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) - , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) - , ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses ) - , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax ) - , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) + [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) + , ('csvEUserName , MsgCsvColumnExamUserName ) + , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) + , ('csvEUserField , MsgCsvColumnExamUserField ) + , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) + , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) + , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) + , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) + , ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses ) + , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) + , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) + , ('csvEUserExamResult , MsgCsvColumnExamResult ) ] data ExamUserAction = ExamUserDeregister @@ -150,6 +153,7 @@ data ExamUserCsvActionClass | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField | ExamUserCsvDeregister + | ExamUserCsvSetResult deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id @@ -174,6 +178,10 @@ data ExamUserCsvAction | ExamUserCsvDeregisterData { examUserCsvActRegistration :: ExamRegistrationId } + | ExamUserCsvSetResultData + { examUserCsvActUser :: UserId + , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel @@ -203,6 +211,9 @@ postEUsersR tid ssh csh examn = do showPasses = numSheetsPasses allBoni /= 0 showPoints = getSum (numSheetsPoints allBoni) /= 0 + resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade + resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades + let examUsersDBTable = DBTable{..} where @@ -324,6 +335,7 @@ postEUsersR tid ssh csh examn = do <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) + <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser csv @@ -344,6 +356,8 @@ postEUsersR tid ssh csh examn = do yield $ ExamUserCsvSetCourseFieldData cpId newFeatures | otherwise -> yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew + when (is _Just $ csvEUserExamResult dbCsvNew) $ + yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew DBCsvDiffExisting{..} -> do newOccurrence <- lift $ lookupOccurrence dbCsvNew when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ @@ -353,12 +367,16 @@ postEUsersR tid ssh csh examn = do when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey yield $ ExamUserCsvSetCourseFieldData cpId newFeatures + + when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ + yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew , dbtCsvClassifyAction = \case ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister ExamUserCsvRegisterData{} -> ExamUserCsvRegister ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField + ExamUserCsvSetResultData{} -> ExamUserCsvSetResult , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew @@ -394,6 +412,13 @@ postEUsersR tid ssh csh examn = do update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] ExamUserCsvSetCourseFieldData{..} -> update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] + ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of + Nothing -> deleteBy $ UniqueExamResult eid examUserCsvActUser + Just res -> let res' = either (over _examResult $ review passingGrade) id res + in void $ upsert + (ExamResult eid examUserCsvActUser res') + [ ExamResultResult =. res' + ] ExamUserCsvDeregisterData{..} -> do ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration User{userIdent} <- getJust examRegistrationUser @@ -445,6 +470,21 @@ postEUsersR tid ssh csh examn = do $nothing , _{MsgCourseStudyFeatureNone} |] + ExamUserCsvSetResultData{..} -> do + User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe newResult <- examUserCsvActExamResult + $case newResult + $of Left pResult + , _{pResult} + $of Right gResult + , _{gResult} + $nothing + , _{MsgExamResultNone} + |] + ExamUserCsvDeregisterData{..} -> registeredUserName' examUserCsvActRegistration , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index e8af44735..db46371e7 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -12,10 +12,13 @@ module Model.Types.Exam import Import.NoModel import Model.Types.Common +import qualified Data.Text as Text + import Control.Lens hiding (universe) import Utils.Lens.TH import qualified Data.Csv as Csv + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -161,6 +164,12 @@ instance PathPiece ExamGrade where pathPieceJSON ''ExamGrade pathPieceJSONKey ''ExamGrade +instance Csv.ToField ExamGrade where + toField = Csv.toField . toPathPiece +instance Csv.FromField ExamGrade where + parseField x = (parse =<< Csv.parseField x) <|> (parse . Text.replace "," "." =<< Csv.parseField x) -- Ugh. + where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece + data ExamGradingRule = ExamGradingManual | ExamGradingKey @@ -182,12 +191,21 @@ newtype ExamPassed = ExamPassed { examPassed :: Bool } deriveFinite ''ExamPassed finitePathPiece ''ExamPassed ["failed", "passed"] makeWrapped ''ExamPassed +pathPieceCsv ''ExamPassed +pathPieceJSON ''ExamPassed +pathPieceJSONKey ''ExamPassed passingGrade :: Iso' ExamGrade ExamPassed -- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10` passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed) -type ExamResultPoints = ExamResult' (Maybe Points) -type ExamResultGrade = ExamResult' ExamGrade +type ExamResultPoints = ExamResult' Points +type ExamResultGrade = ExamResult' ExamGrade type ExamResultPassed = ExamResult' ExamPassed + +instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where + toField = either Csv.toField Csv.toField + +instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where + parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint diff --git a/src/Utils.hs b/src/Utils.hs index 982ba28f5..795787841 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -27,6 +27,7 @@ import Utils.Icon as Utils import Utils.Message as Utils import Utils.Lang as Utils import Utils.Parameters as Utils +import Utils.Csv as Utils import Control.Concurrent.Async.Lifted.Safe.Utils as Utils import Text.Blaze (Markup, ToMarkup) diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs new file mode 100644 index 000000000..0205eab4f --- /dev/null +++ b/src/Utils/Csv.hs @@ -0,0 +1,19 @@ +module Utils.Csv + ( pathPieceCsv + ) where + +import ClassyPrelude +import Data.Csv hiding (Name) + +import Language.Haskell.TH (Name) +import Language.Haskell.TH.Lib + + +pathPieceCsv :: Name -> DecsQ +pathPieceCsv (conT -> t) = + [d| + instance ToField $(t) where + toField = toField . toPathPiece + instance FromField $(t) where + parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField + |] diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 3fd03a2c5..9fa543452 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -148,10 +148,8 @@ $if gradingShown && not (null parts) $case fmap (examPartResultResult . entityVal) (results !? partId) $of Nothing - $of Just (ExamAttended (Just ps)) + $of Just (ExamAttended ps) #{showFixed True ps} - $of Just (ExamAttended Nothing) - #{iconOK} $of Just ExamNoShow _{MsgExamNoShow} $of Just ExamVoided