feat(exams): csv-based grade upload

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
@@ -1275,3 +1277,4 @@ TableHeadingCsvExport: CSV-Export
 ExamResultAttended: Teilgenommen
 ExamResultNoShow: Nicht erschienen
 ExamResultVoided: Entwertet
+ExamResultNone: Kein Klausurergebnis

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           )
+    [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname           )
-    , ('csvEUserName             , MsgCsvColumnExamUserName              )
+    , ('csvEUserName                , MsgCsvColumnExamUserName              )
-    , ('csvEUserMatriculation    , MsgCsvColumnExamUserMatriculation     )
+    , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation     )
-    , ('csvEUserField            , MsgCsvColumnExamUserField             )
+    , ('csvEUserField               , MsgCsvColumnExamUserField             )
-    , ('csvEUserDegree           , MsgCsvColumnExamUserDegree            )
+    , ('csvEUserDegree              , MsgCsvColumnExamUserDegree            )
-    , ('csvEUserSemester         , MsgCsvColumnExamUserSemester          )
+    , ('csvEUserSemester            , MsgCsvColumnExamUserSemester          )
-    , ('csvEUserOccurrence       , MsgCsvColumnExamUserOccurrence        )
+    , ('csvEUserOccurrence          , MsgCsvColumnExamUserOccurrence        )
-    , ('csvEUserExercisePoints   , MsgCsvColumnExamUserExercisePoints    )
+    , ('csvEUserExercisePoints      , MsgCsvColumnExamUserExercisePoints    )
-    , ('csvEUserExercisePasses   , MsgCsvColumnExamUserExercisePasses    )
+    , ('csvEUserExerciseNumPasses   , MsgCsvColumnExamUserExercisePasses    )
-    , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax )
+    , ('csvEUserExercisePointsMax   , MsgCsvColumnExamUserExercisePointsMax )
-    , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax )
+    , ('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

src/Model/Types/Exam.hs

@@ -12,11 +12,14 @@ 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
                      | ExamVoided
@@ -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 ExamResultPoints = ExamResult' Points
-type ExamResultGrade = ExamResult' ExamGrade
+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

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)

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
+  |]

templates/exam-show.hamlet

@@ -148,10 +148,8 @@ $if gradingShown && not (null parts)
             <td .table__td>
               $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