From 0e49bc14e5a66f75f75612a57024dace0303f299 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 18 Feb 2020 15:43:07 +0100 Subject: [PATCH] feat(exams): improve handling of exam results everywhere BREAKING CHANGE: ExamResult now contains ExamResultPassedGrade --- .../src/utils/form/interactive-fieldset.js | 6 +- messages/uniworx/de-de-formal.msg | 9 + models/exams.model | 2 +- models/external-exams.model | 2 +- src/Foundation.hs | 4 +- src/Handler/Exam/Correct.hs | 11 +- src/Handler/Exam/Show.hs | 2 +- src/Handler/Exam/Users.hs | 185 +++++++++++++----- src/Handler/ExamOffice/Exam.hs | 10 +- src/Handler/Utils/ExternalExam/Users.hs | 21 +- src/Handler/Utils/Form.hs | 95 +++++++-- src/Handler/Utils/Table/Columns.hs | 36 +--- src/Import/NoModel.hs | 1 + src/Model/Migration.hs | 8 + src/Model/Types/Exam.hs | 11 ++ src/Yesod/Form/Fields/Instances.hs | 29 +++ templates/exam-show.hamlet | 8 +- templates/external-exam-show.hamlet | 8 +- .../widgets/multi-action/multi-action.hamlet | 5 +- 19 files changed, 315 insertions(+), 138 deletions(-) create mode 100644 src/Yesod/Form/Fields/Instances.hs diff --git a/frontend/src/utils/form/interactive-fieldset.js b/frontend/src/utils/form/interactive-fieldset.js index 0f6a7a395..30e2bead9 100644 --- a/frontend/src/utils/form/interactive-fieldset.js +++ b/frontend/src/utils/form/interactive-fieldset.js @@ -29,9 +29,9 @@ export class InteractiveFieldset { return false; } - if (this._element.querySelector('[uw-interactive-fieldset]')) { - return false; - } + // if (this._element.querySelector('[uw-interactive-fieldset]')) { + // return false; + // } // param conditionalInput if (!this._element.dataset.conditionalInput) { diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index e41922081..40c5fafd4 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1640,6 +1640,7 @@ ExamCorrectors: Korrektoren ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen. ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen +ExamPart: Teilprüfung/Aufgabe ExamParts: Teilprüfungen/Aufgaben ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits @@ -1703,10 +1704,16 @@ ExamUserAssignOccurrence: Termin/Raum zuweisen ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen ExamUserResetBonus: Auch Bonuspunkte zurücksetzen +ExamUserSetPartResult: Teilergebnis setzen +ExamUserSetBonus: Bonuspunkte setzen +ExamUserSetResult: Prüfungsergebnis setzen ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt +ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst +ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst +ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst ExamUserSynchronised: Synchronisiert ExamUserSyncOfficeName: Name @@ -2314,3 +2321,5 @@ BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Nachnamen beginnend mit ExamRoomMappingMatriculation: Matrikelnummern endend in ExamRoomLoad: Auslastung + +NoFilter: Keine Einschränkung \ No newline at end of file diff --git a/models/exams.model b/models/exams.model index 2bdc42cda..632f49a84 100644 --- a/models/exams.model +++ b/models/exams.model @@ -56,7 +56,7 @@ ExamBonus ExamResult exam ExamId user UserId - result ExamResultGrade + result ExamResultPassedGrade lastChanged UTCTime default=now() UniqueExamResult exam user ExamCorrector diff --git a/models/external-exams.model b/models/external-exams.model index bd203fa0d..18b584d5b 100644 --- a/models/external-exams.model +++ b/models/external-exams.model @@ -9,7 +9,7 @@ ExternalExam ExternalExamResult user UserId exam ExternalExamId - result ExamResultGrade + result ExamResultPassedGrade time UTCTime lastChanged UTCTime UniqueExternalExamResult exam user diff --git a/src/Foundation.hs b/src/Foundation.hs index 20eb9b329..6c9f11c3f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2255,7 +2255,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the let navChildren = flip map (toList appLanguages) $ \lang -> NavLink { navLabel = MsgLanguage lang - , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ]) + , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) , navAccess' = return True , navType = NavTypeButton { navMethod = POST @@ -2281,7 +2281,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navIcon = IconMenuHelp , navLink = NavLink { navLabel = MsgMenuHelp - , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ]) + , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) , navAccess' = return True , navType = NavTypeLink { navModal = True } , navQuick' = mempty diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index 95adddd58..895d72d86 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -213,11 +213,8 @@ postECorrectR tid ssh csh examn = do delete oldId audit $ TransactionExamResultDeleted eId uid return Nothing - | Just result <- ciqGrade' -> let - mOld = view passedGrade . examResultResult . entityVal <$> mOldResult - resultGrade = review passedGrade result - passedGrade :: Iso' ExamResultGrade ExamResultPassedGrade - passedGrade = iso (fmap $ bool (Left . view passingGrade) Right examShowGrades) (fmap $ either (review passingGrade) id) + | Just resultGrade <- ciqGrade' -> let + mOld = examResultResult . entityVal <$> mOldResult in if | ciqGrade' /= mOld -> do newResult <- upsert ExamResult @@ -230,8 +227,8 @@ postECorrectR tid ssh csh examn = do , ExamResultLastChanged =. now ] audit $ TransactionExamResultEdit eId uid - return $ newResult ^? _entityVal . _examResultResult . passedGrade - | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult . passedGrade + return $ newResult ^? _entityVal . _examResultResult + | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult | otherwise -> return Nothing user <- userToResponse match diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 8a01b551b..ab6f799db 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -88,7 +88,7 @@ getEShowR tid ssh csh examn = do noBonus = fromMaybe False $ do guardM $ bonusOnlyPassed <$> examBonusRule - return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not + return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not sumPoints = fmap getSum . mconcat $ catMaybes [ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 2d82115c7..54d1a1e1e 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -167,11 +167,12 @@ resultCourseNote = _dbrOutput . _10 . _Just resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) -resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade -resultAutomaticExamResult exam examBonus' = folding . runReader $ do +resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade +resultAutomaticExamResult exam@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' + let gradeRes = examGrade exam bonus =<< parts' + return $ fmap (bool (Left . view passingGrade) Right examShowGrades) <$> gradeRes csvExamPartHeader :: Prism' Csv.Name ExamPartNumber @@ -301,6 +302,9 @@ examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence + | ExamUserSetPartResult + | ExamUserSetBonus + | ExamUserSetResult | ExamUserAcceptComputedResult | ExamUserResetToComputedResult deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -312,11 +316,15 @@ embedRenderMessage ''UniWorX ''ExamUserAction id data ExamUserActionData = ExamUserDeregisterData | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) + | ExamUserSetPartResultData ExamPartNumber (Maybe ExamResultPoints) + | ExamUserSetBonusData (Maybe Points) + | ExamUserSetResultData (Maybe ExamResultPassedGrade) | ExamUserAcceptComputedResultData | ExamUserResetToComputedResultData { examUserResetBonus :: Bool } + data ExamUserCsvActionClass = ExamUserCsvCourseRegister | ExamUserCsvRegister @@ -394,6 +402,7 @@ getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn + occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName] examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam @@ -405,14 +414,11 @@ postEUsersR tid ssh csh examn = do showPasses = doBonus && numSheetsPasses allBoni /= 0 showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 - resultView :: ExamResultGrade -> ExamResultPassedGrade - resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades - examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber resultAutomaticExamBonus' :: Fold ExamUserTableData Points resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus - resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade + resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus automaticCell :: forall msg m a b r. @@ -512,7 +518,7 @@ postEUsersR tid ssh csh examn = do [ 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 "exam-result") (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) , 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 ] @@ -528,34 +534,20 @@ postEUsersR tid ssh csh examn = do ] , 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] + , sortExamResult (to $ queryExamResult >>> (E.?. ExamResultResult)) , singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date E.subSelectMaybe . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , fltrField queryStudyField - , fltrDegree queryStudyDegree - , fltrFeaturesSemester queryStudyFeatures - , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - , ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult)) - , ( "result-bool" - , FilterColumn $ \row criteria -> if - | Set.null criteria -> E.true - | otherwise -> let passed :: [ExamResultGrade] - passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF - criteria' = Set.map (fmap $ review passingGrade) criteria - criteria'' - | ExamAttended (ExamPassed True) `Set.member` criteria - = criteria' `Set.union` Set.fromList passed - | otherwise - = criteria' - in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'') - ) + dbtFilter = mconcat + [ uncurry singletonMap $ fltrUserNameEmail queryUser + , uncurry singletonMap $ fltrUserMatriclenr queryUser + , uncurry singletonMap $ fltrField queryStudyField + , uncurry singletonMap $ fltrDegree queryStudyDegree + , uncurry singletonMap $ fltrFeaturesSemester queryStudyFeatures + , uncurry singletonMap ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + , fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult)) ] dbtFilterUI mPrev = mconcat $ catMaybes [ Just $ fltrUserNameEmailUI mPrev @@ -563,9 +555,8 @@ postEUsersR tid ssh csh examn = do , Just $ fltrFieldUI mPrev , Just $ fltrDegreeUI mPrev , Just $ fltrFeaturesSemesterUI mPrev - , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) - , guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult) - , guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult) + , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence) + , Just $ fltrExamResultPointsUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm @@ -581,17 +572,36 @@ postEUsersR tid ssh csh examn = do pure ExamUserDeregisterData , singletonMap ExamUserAssignOccurrence $ ExamUserAssignOccurrenceData - <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) - , bool mempty computeActionMap $ is _Just examGradingRule - ] - computeActionMap = mconcat - [ singletonMap ExamUserAcceptComputedResult $ + <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) + , singletonMap ExamUserAcceptComputedResult $ pure ExamUserAcceptComputedResultData , singletonMap ExamUserResetToComputedResult $ ExamUserResetToComputedResultData - <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule) + <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule) + , singletonMap ExamUserSetPartResult $ + ExamUserSetPartResultData + <$> areq (selectField $ optionsPairs (map ((MsgExamPartNumbered &&& id) . examPartNumber . entityVal) examParts)) (fslI MsgExamPart) Nothing + <*> (fmap ExamAttended <$> aopt pointsField (fslI MsgPoints) Nothing) + , singletonMap ExamUserSetBonus $ + ExamUserSetBonusData + <$> aopt pointsField (fslI MsgPoints) Nothing + , singletonMap ExamUserSetResult $ + ExamUserSetResultData + <$> aopt (examResultField (Just $ SomeMessage MsgExamResultNone) examPassedGradeField) (fslI MsgExamResult) Nothing ] - (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + + actionOpts :: Handler (OptionList ExamUserAction) + actionOpts = execWriterT $ do + tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ] + when (is _Just examGradingRule) $ + tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ] + when (not $ null examParts) $ + tell =<< optionsF [ ExamUserSetPartResult ] + when doBonus $ + tell =<< optionsF [ ExamUserSetBonus ] + tell =<< optionsF [ ExamUserSetResult ] + + (res, formWgt) <- multiActionMOpts actionMap actionOpts (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost @@ -623,7 +633,7 @@ postEUsersR tid ssh csh examn = do <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _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)) - <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView + <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do @@ -686,8 +696,8 @@ postEUsersR tid ssh csh examn = do oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') newResult, oldResult :: Maybe ExamResultPassedGrade - newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults - oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView + newResult = fmap (fmap $ bool (Left . view passingGrade) Right examShowGrades) . examGrade examVal (newBonus <|> oldBonus) =<< newResults + oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') when doBonus $ case newBonus of @@ -806,12 +816,11 @@ postEUsersR tid ssh csh examn = do deleteBy $ UniqueExamResult eid examUserCsvActUser audit $ TransactionExamResultDeleted eid examUserCsvActUser Just res -> do - let res' = either (review passingGrade) id <$> res now <- liftIO getCurrentTime void $ upsertBy (UniqueExamResult eid examUserCsvActUser) - (ExamResult eid examUserCsvActUser res' now) - [ ExamResultResult =. res' + (ExamResult eid examUserCsvActUser res now) + [ ExamResultResult =. res , ExamResultLastChanged =. now ] audit $ TransactionExamResultEdit eid examUserCsvActUser @@ -1084,6 +1093,88 @@ postEUsersR tid ssh csh examn = do Nothing -> return mempty addMessageI Success $ MsgExamUsersResultsReset nrReset redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserSetPartResultData part mPts, Map.elems -> rows) -> do + now <- liftIO getCurrentTime + updated <- fmap getSum . runDB $ do + partId <- getKeyBy $ UniqueExamPartNumber eId part + flip foldMapM partId $ \epId -> flip foldMapM rows $ \row -> do + let uid = row ^. resultUser . _entityKey + oldPartResult <- getBy $ UniqueExamPartResult epId uid + case mPts of + Just pts + | maybe True ((/= pts) . examPartResultResult . entityVal) oldPartResult -> do + void $ upsert + ExamPartResult + { examPartResultExamPart = epId + , examPartResultUser = row ^. resultUser . _entityKey + , examPartResultResult = pts + , examPartResultLastChanged = now + } + [ ExamPartResultResult =. pts, ExamPartResultLastChanged =. now ] + audit $ TransactionExamPartResultEdit epId uid + return $ Sum 1 + Nothing + | is _Just oldPartResult -> do + deleteBy $ UniqueExamPartResult epId uid + audit $ TransactionExamPartResultDeleted epId uid + return $ Sum 1 + _other -> return mempty + addMessageI Success $ MsgExamUsersPartResultsSet updated + redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserSetBonusData mPts, Map.elems -> rows) -> do + now <- liftIO getCurrentTime + updated <- fmap getSum . runDB $ do + flip foldMapM rows $ \row -> do + let uid = row ^. resultUser . _entityKey + oldBonus <- getBy $ UniqueExamBonus eId uid + case mPts of + Just pts + | maybe True ((/= pts) . examBonusBonus . entityVal) oldBonus -> do + void $ upsert + ExamBonus + { examBonusExam = eId + , examBonusUser = row ^. resultUser . _entityKey + , examBonusBonus = pts + , examBonusLastChanged = now + } + [ ExamBonusBonus =. pts, ExamBonusLastChanged =. now ] + audit $ TransactionExamBonusEdit eId uid + return $ Sum 1 + Nothing + | is _Just oldBonus -> do + deleteBy $ UniqueExamBonus eId uid + audit $ TransactionExamBonusDeleted eId uid + return $ Sum 1 + _other -> return mempty + addMessageI Success $ MsgExamUsersBonusSet updated + redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserSetResultData mRes, Map.elems -> rows) -> do + now <- liftIO getCurrentTime + updated <- fmap getSum . runDB $ do + flip foldMapM rows $ \row -> do + let uid = row ^. resultUser . _entityKey + oldResult <- getBy $ UniqueExamResult eId uid + case mRes of + Just res + | maybe True ((/= res) . examResultResult . entityVal) oldResult -> do + void $ upsert + ExamResult + { examResultExam = eId + , examResultUser = row ^. resultUser . _entityKey + , examResultResult = res + , examResultLastChanged = now + } + [ ExamResultResult =. res, ExamResultLastChanged =. now ] + audit $ TransactionExamResultEdit eId uid + return $ Sum 1 + Nothing + | is _Just oldResult -> do + deleteBy $ UniqueExamResult eId uid + audit $ TransactionExamResultDeleted eId uid + return $ Sum 1 + _other -> return mempty + addMessageI Success $ MsgExamUsersResultSet updated + redirect $ CExamR tid ssh csh examn EUsersR closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index c92ec1e62..64d3b78bd 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -341,7 +341,7 @@ postEGradesR tid ssh csh examn = do start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just lift $ maybe mempty (flip (formatTimeRangeW SelFormatDateTime) end) start - , colExamResult examShowGrades (resultExamResult . _entityVal . _examResultResult) + , colExamResult (resultExamResult . _entityVal . _examResultResult) ] dbtSorting = mconcat [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname))) @@ -350,7 +350,7 @@ postEGradesR tid ssh csh examn = do , sortStudyDegree queryStudyDegree , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester)) , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart))) - , maybeOpticSortColumn (sortExamResult examShowGrades) (queryExamResult . to (E.^. ExamResultResult)) + , maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult)) , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid) ] dbtFilter = mconcat @@ -359,7 +359,7 @@ postEGradesR tid ssh csh examn = do , fltrStudyTerms queryStudyField , fltrStudyDegree queryStudyDegree , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester)) - , fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult)) + , fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just) , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid) ] dbtFilterUI = mconcat @@ -368,7 +368,7 @@ postEGradesR tid ssh csh examn = do , fltrStudyTermsUI , fltrStudyDegreeUI , fltrStudyFeaturesSemesterUI - , fltrExamResultPointsUI examShowGrades + , fltrExamResultPointsUI , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -408,7 +408,7 @@ postEGradesR tid ssh csh examn = do (row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand)) (row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester) (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime) - (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades)) + (row ^. resultExamResult . _entityVal . _examResultResult) , dbtCsvName = unpack csvName , dbtCsvNoExportData = Nothing , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 3e217429d..545a5bbe2 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -178,9 +178,6 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute let - resultView :: ExamResultGrade -> ExamResultPassedGrade - resultView = fmap $ bool (Left . view passingGrade) Right externalExamShowGrades - dbtSQLQuery = runReaderT $ do result <- view queryResult user <- view queryUser @@ -262,25 +259,25 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do t <- view $ resultResult . _entityVal . _externalExamResultTime lift $ formatTimeW SelFormatDateTime t - , colExamResult externalExamShowGrades (resultResult . _entityVal . _externalExamResultResult) + , colExamResult (resultResult . _entityVal . _externalExamResultResult) ] dbtSorting = mconcat [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname))) , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) , sortOccurrenceStart (queryResult . to (E.^. ExternalExamResultTime)) - , maybeOpticSortColumn (sortExamResult externalExamShowGrades) (queryResult . to (E.^. ExternalExamResultResult)) + , maybeOpticSortColumn sortExamResult (queryResult . to (E.^. ExternalExamResultResult)) , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid) ] dbtFilter = mconcat [ fltrUserName' (queryUser . to (E.^. UserDisplayName)) , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) - , fltrExamResultPoints externalExamShowGrades (queryResult . to (E.^. ExternalExamResultResult)) + , fltrExamResultPoints (queryResult . to (E.^. ExternalExamResultResult) . to E.just) , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid) ] dbtFilterUI = mconcat [ fltrUserNameUI' , fltrUserMatriculationUI - , fltrExamResultPointsUI externalExamShowGrades + , fltrExamResultPointsUI , case mode of EEUMGrades -> \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised) @@ -332,7 +329,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , csvEUserName = row ^? resultUser . _entityVal . _userDisplayName , csvEUserMatriculation = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just , csvEUserOccurrenceStart = row ^. resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime - , csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult . to (fmap $ bool (Left . view passingGrade) Right externalExamShowGrades) + , csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult } dbtCsvDecode | mode == EEUMUsers = Just DBTCsvDecode @@ -353,7 +350,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do when (zonedTimeToUTC csvEUserOccurrenceStart /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $ yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) (zonedTimeToUTC csvEUserOccurrenceStart) - when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult . to resultView) $ + when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $ yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult , dbtCsvClassifyAction = \case ExternalExamUserCsvRegisterData{} -> ExternalExamUserCsvRegister @@ -368,12 +365,11 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do C.mapM_ $ \case ExternalExamUserCsvRegisterData{..} -> do now <- liftIO getCurrentTime - let res' = either (review passingGrade) id <$> externalExamUserCsvActResult insert_ ExternalExamResult { externalExamResultExam = eeId , externalExamResultUser = externalExamUserCsvActUser , externalExamResultTime = externalExamUserCsvActTime - , externalExamResultResult = res' + , externalExamResultResult = externalExamUserCsvActResult , externalExamResultLastChanged = now } audit $ TransactionExternalExamResultEdit eeId externalExamUserCsvActUser @@ -386,9 +382,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do audit $ TransactionExternalExamResultEdit eeId externalExamResultUser ExternalExamUserCsvSetResultData{..} -> do now <- liftIO getCurrentTime - let res' = either (review passingGrade) id <$> externalExamUserCsvActResult ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration - [ ExternalExamResultResult =. res' + [ ExternalExamResultResult =. externalExamUserCsvActResult , ExternalExamResultLastChanged =. now ] audit $ TransactionExternalExamResultEdit eeId externalExamResultUser diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4bcf7e775..63a8245aa 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -221,6 +221,15 @@ multiAction :: forall action a. -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiAction = multiAction' mpopt + +multiActionOpts :: forall action a. + Ord action + => Map action (AForm Handler a) + -> Handler (OptionList action) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) +multiActionOpts = multiActionOpts' mpopt multiAction' :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action ) @@ -229,15 +238,37 @@ multiAction' :: forall action a. -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -multiAction' minp acts fs@FieldSettings{..} defAction csrf = do - (actionRes, actionView) <- minp (selectField . optionsF $ Map.keysSet acts) fs defAction - results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts +multiAction' minp acts = multiActionOpts' minp acts (optionsF $ Map.keysSet acts) + +multiActionOpts' :: forall action a. + Ord action + => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX)) + -> Map action (AForm Handler a) + -> Handler (OptionList action) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) +multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do + actsOpts <- liftHandler mActsOpts + let actsOpts' = OptionList + { olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts + , olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts + } + acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts + + (actionRes, actionView) <- minp (selectField $ return actsOpts') fs defAction + results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts' let actionResults = view _1 <$> results + actionViews = Map.foldrWithKey accViews [] results accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] - accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd + accViews act + | Option{..} : _ <- filter ((== act) . optionInternalValue) $ olOptions actsOpts' + = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd + | otherwise + = flip const return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) @@ -247,6 +278,14 @@ multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action) -> Maybe action -> AForm Handler a multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty + +multiActionAOpts :: Ord action + => Map action (AForm Handler a) + -> Handler (OptionList action) + -> FieldSettings UniWorX + -> Maybe action + -> AForm Handler a +multiActionAOpts acts opts fSettings defAction = formToAForm $ multiActionOpts acts opts fSettings defAction mempty multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) @@ -254,6 +293,14 @@ multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) -> Maybe action -> WForm Handler (FormResult a) multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction + +multiActionWOpts :: Ord action + => Map action (AForm Handler a) + -> Handler (OptionList action) + -> FieldSettings UniWorX + -> Maybe action + -> WForm Handler (FormResult a) +multiActionWOpts acts opts fSettings defAction = aFormToWForm $ multiActionAOpts acts opts fSettings defAction multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) @@ -261,6 +308,14 @@ multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction + +multiActionMOpts :: Ord action + => Map action (AForm Handler a) + -> Handler (OptionList action) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, Widget)) +multiActionMOpts acts opts fSettings defAction = renderAForm FormStandard $ multiActionAOpts acts opts fSettings defAction ------------ @@ -1175,32 +1230,33 @@ examResultField :: forall m res. , HandlerSite m ~ UniWorX , PathPiece res ) - => Field m res -> Field m (ExamResult' res) -examResultField innerField = Field + => Maybe (SomeMessage UniWorX) -> Field m res -> Field m (ExamResult' res) +examResultField optMsg innerField = Field { fieldEnctype = UrlEncoded <> fieldEnctype innerField , fieldParse = \ts fs -> if - | [t] <- ts - , Just res <- fromPathPiece t - , is _ExamNoShow res || is _ExamVoided res + | res : _ <- mapMaybe (assertM ((||) <$> is _ExamNoShow <*> is _ExamVoided) . fromPathPiece) ts -> return . Right $ Just res + | null ts || any null ts + -> return $ Right Nothing | otherwise - -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs + -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["", "attended", "no-show", "voided"])) ts) fs , fieldView = \theId name attrs val isReq -> do innerId <- newIdent let - val' :: ExamResult' (Either Text res) - val' = either (ExamAttended . Left) (fmap Right) val innerVal :: Either Text res innerVal = val >>= maybe (Left "") return . preview _ExamAttended [whamlet| $newline never