feat(exams): csv-based grade upload
This commit is contained in:
Gregor Kleen
parent
40e952a452
commit
932145ccf7
@ -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
|
||||
ExamResultVoided: Entwertet
|
||||
ExamResultNone: Kein Klausurergebnis
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
19
src/Utils/Csv.hs
Normal file
19
src/Utils/Csv.hs
Normal file
@ -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
|
||||
|]
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user