-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Exam.Users ( getEUsersR, postEUsersR ) where import Import hiding ((<.), (.>)) import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Users import Handler.Utils.Csv import Handler.Utils.StudyFeatures import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import qualified Data.Csv as Csv import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.HashMap.Lazy as HashMap import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lens as Text import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI import Numeric.Lens (integral) import Database.Persist.Sql (updateWhereCount) import Control.Lens.Indexed ((<.), (.>)) import Jobs.Queue import qualified Control.Monad.State.Class as State type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) type ExamUserTableData = DBRow ( Entity ExamRegistration , Entity User , Maybe (Entity ExamOccurrence) , Maybe (Entity ExamBonus) , Maybe (Entity ExamResult) , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) , Maybe (Entity CourseUserNote) , UserTableStudyFeatures ) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 instance HasUser ExamUserTableData where hasUser = _dbrOutput . _2 . _entityVal _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) queryExamOccurrence = $(sqlLOJproj 6 2) queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant)) queryCourseParticipant = $(sqlLOJproj 6 3) queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus)) queryExamBonus = $(sqlLOJproj 6 4) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) queryExamResult = $(sqlLOJproj 6 5) queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) 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.subSelectUnsafe . 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 = _dbrOutput . _1 resultUser :: Lens' ExamUserTableData (Entity User) resultUser = _dbrOutput . _2 resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus) resultExamBonus = _dbrOutput . _4 . _Just resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _5 . _Just resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) resultExamParts = _dbrOutput . _6 . itraversed -- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart) -- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) resultExamPartResult epId = _dbrOutput . _6 . unsafeSingular (ix epId) . _2 -- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) -- resultExamPartResults = resultExamParts <. _2 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) resultCourseNote = _dbrOutput . _7 . _Just resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures resultStudyFeatures = _dbrOutput . _8 resultAutomaticExamBonus :: Ord epId => Exam -> Map UserId (SheetTypeSummary epId) -> Fold ExamUserTableData Points resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) resultAutomaticExamResult :: Exam -> Map UserId (SheetTypeSummary ExamPartId) -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPassedGrade resultAutomaticExamResult exam@Exam{..} examBonus' resultSheets = folding . runReader $ do parts' <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> runMaybeT $ hoistMaybe (mRes ^? _Just . _entityVal . _examPartResultResult) <|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) resultSheets) ) bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus' let gradeRes = examGrade exam bonus =<< sequence parts' return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes resultAutomaticExamPartResult :: Entity ExamPart -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPoints resultAutomaticExamPartResult epEnt resultSheets = folding . runReader . runMaybeT $ do uid <- view $ resultUser . _entityKey summary <- hoistMaybe $ Map.lookup uid resultSheets hoistMaybe $ sheetExamResult summary epEnt csvExamPartHeader :: Prism' Csv.Name ExamPartNumber csvExamPartHeader = prism' toHeader fromHeader where toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber) fromHeader hdr = do tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr partPrefix = "part-" data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text , csvEUserFirstName :: Maybe Text , csvEUserName :: Maybe Text , csvEUserMatriculation :: Maybe Text , csvEUserEPPN :: Maybe UserEduPersonPrincipalName , csvEUserStudyFeatures :: UserTableStudyFeatures , csvEUserOccurrence :: Maybe (CI Text) , csvEUserExercisePoints :: Maybe (Maybe Points) , csvEUserExerciseNumPasses :: Maybe (Maybe Int) , csvEUserExercisePointsMax :: Maybe (Maybe Points) , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int) , csvEUserBonus :: Maybe (Maybe Points) , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints) , csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserCourseNote :: Maybe StoredMarkup } deriving (Generic) makeLenses_ ''ExamUserTableCsv instance ToNamedRecord ExamUserTableCsv where toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $ [ "surname" Csv..= csvEUserSurname , "first-name" Csv..= csvEUserFirstName , "name" Csv..= csvEUserName , "matriculation" Csv..= csvEUserMatriculation , "eduPersonPrincipalName" Csv..= csvEUserEPPN , "study-features" Csv..= csvEUserStudyFeatures , "occurrence" Csv..= csvEUserOccurrence ] ++ catMaybes [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints , fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses , fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax , fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax , fmap ("bonus" Csv..=) csvEUserBonus ] ++ examPartResults ++ [ "exam-result" Csv..= csvEUserExamResult , "course-note" Csv..= csvEUserCourseNote ] where examPartResults = flip ifoldMap csvEUserExamPartResults $ \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult instance FromNamedRecord ExamUserTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = ExamUserTableCsv <$> csv .:?? "surname" <*> csv .:?? "first-name" <*> csv .:?? "name" <*> csv .:?? "matriculation" <*> csv .:?? "eduPersonPrincipalName" <*> pure mempty <*> csv .:?? "occurrence" <*> fmap Just (csv .:?? "exercise-points") <*> fmap Just (csv .:?? "exercise-num-passes") <*> fmap Just (csv .:?? "exercise-points-max") <*> fmap Just (csv .:?? "exercise-num-passes-max") <*> fmap Just (csv .:?? "bonus") <*> examPartResults <*> csv .:?? "exam-result" <*> csv .:?? "course-note" where examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do pNumber <- pNumber' ^? csvExamPartHeader return . fmap (singletonMap pNumber ) $ csv .:?? pNumber' instance CsvColumnsExplained ExamUserTableCsv where csvColumnsExplanations _ = mconcat [ single "surname" MsgCsvColumnExamUserSurname , single "first-name" MsgCsvColumnExamUserFirstName , single "name" MsgCsvColumnExamUserName , single "matriculation" MsgCsvColumnExamUserMatriculation , single "study-features" MsgCsvColumnUserStudyFeatures , single "occurrence" MsgCsvColumnExamUserOccurrence , single "exercise-points" MsgCsvColumnExamUserExercisePoints , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax , single "bonus" MsgCsvColumnExamUserBonus , single "part-*" MsgCsvColumnExamUserParts , single "exam-result" MsgCsvColumnExamUserResult , single "course-note" MsgCsvColumnExamUserCourseNote ] where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] examUserTableCsvHeader :: ( MonoFoldable mono , Element mono ~ ExamPartNumber ) => SheetGradeSummary -> Bool -> mono -> Csv.Header examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ [ "surname", "first-name", "name" , "matriculation", "eduPersonPrincipalName" , "study-features" , "course-note" , "occurrence" ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints) ++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses) ++ bool mempty ["bonus"] doBonus ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++ [ "exam-result" ] where showPasses = numSheetsPasses allBoni /= 0 showPoints = getSum (numSheetsPoints allBoni) /= 0 data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence | ExamUserSetPartResult | ExamUserSetBonus | ExamUserSetResult | ExamUserAcceptComputedResult | ExamUserResetToComputedResult deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe ExamUserAction instance Finite ExamUserAction nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''ExamUserAction id data ExamUserActionData = ExamUserDeregisterData | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) | ExamUserSetPartResultData ExamPartNumber (Maybe ExamResultPoints) | ExamUserSetBonusData (Maybe Points) | ExamUserSetResultData (Maybe ExamResultPassedGrade) | ExamUserAcceptComputedResultData | ExamUserResetToComputedResultData { examUserResetBonus , examUserResetParts :: Bool } data ExamUserCsvActionClass = ExamUserCsvCourseRegister | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetPartResult | ExamUserCsvSetBonus | ExamUserCsvOverrideBonus | ExamUserCsvSetResult | ExamUserCsvOverrideResult | ExamUserCsvSetCourseNote | ExamUserCsvDeregister deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id data ExamUserCsvAction = ExamUserCsvCourseRegisterData { examUserCsvActUser :: UserId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvRegisterData { examUserCsvActUser :: UserId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvAssignOccurrenceData { examUserCsvActRegistration :: ExamRegistrationId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvDeregisterData { examUserCsvActRegistration :: ExamRegistrationId } | ExamUserCsvSetPartResultData { examUserCsvActUser :: UserId , examUserCsvActExamPart :: ExamPartNumber , examUserCsvActExamPartResult :: Maybe ExamResultPoints } | ExamUserCsvSetBonusData { examUserCsvIsBonusOverride :: Bool , examUserCsvActUser :: UserId , examUserCsvActExamBonus :: Maybe Points } | ExamUserCsvSetResultData { examUserCsvIsResultOverride :: Bool , examUserCsvActUser :: UserId , examUserCsvActExamResult :: Maybe ExamResultPassedGrade } | ExamUserCsvSetCourseNoteData { examUserCsvActUser :: UserId , examUserCsvActCourseNote :: Maybe StoredMarkup } deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel , fieldLabelModifier = camelToPathPiece' 4 , sumEncoding = TaggedObject "action" "data" } ''ExamUserCsvAction data ExamUserCsvException = ExamUserCsvExceptionNoMatchingUser | ExamUserCsvExceptionMultipleMatchingUsers | ExamUserCsvExceptionNoMatchingStudyFeatures | ExamUserCsvExceptionNoMatchingOccurrence | ExamUserCsvExceptionMismatchedGradingMode ExamGradingMode ExamGradingMode deriving (Show, Generic) instance Exception ExamUserCsvException embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, (bonus, resultSheets)) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn Course{..} <- getJust examCourse occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName] examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examRelevantSheets exam True resultSheets <- examRelevantSheets exam False let allBoni :: SheetGradeSummary allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus doBonus = is _Just examBonusRule showPasses = doBonus && numSheetsPasses allBoni /= 0 showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber resultAutomaticExamBonus' :: Fold ExamUserTableData Points resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus resultSheets automaticCell :: forall msg m a b r. ( RenderMessage UniWorX msg , IsDBTable m a , Eq msg , Monoid b , a ~ (Any, b) ) => 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")] & tellCell (Any True, mempty) (Right man : others) | all ((== man) . either id id) others -> i18nCell man | otherwise -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty) let examUsersDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do examRegistration <- asks queryExamRegistration user <- asks queryUser occurrence <- asks queryExamOccurrence courseParticipant <- asks queryCourseParticipant examBonus' <- asks queryExamBonus examResult <- asks queryExamResult courseUserNote <- asks queryCourseNote lift $ do E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) 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 $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) 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, examBonus', examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = dbtProjSimple . runReaderT $ (,,,,,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> getExamParts <*> view _6 <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey)) where getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) getExamParts = do uid <- view $ _2 . _entityKey rawResults <- lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId) E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val uid) E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid return (examPart, examPartResult) return $ Map.fromList [ (epId, (examPart, mbRes)) | (Entity epId examPart, mbRes) <- rawResults ] dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) , pure colUserMatriclenr , pure $ colStudyFeatures resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus in propCell (getSum achievedPasses) (getSum numSheetsPasses) , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left , pure $ mconcat [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt resultSheets . to Left | epEnt@(Entity epId ExamPart{..}) <- sortOn (examPartNumber . entityVal) examParts ] , pure $ sortable (Just "exam-result") (i18nCell MsgTableExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) , pure . sortable (Just "note") (i18nCell MsgExamCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote ] dbtSorting = mconcat [ uncurry singletonMap $ sortUserNameLink queryUser , uncurry singletonMap $ sortUserMatriclenr queryUser , mconcat [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult | Entity epId ExamPart{..} <- examParts ] , singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName) , singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus) , 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 = mconcat [ uncurry singletonMap $ fltrUserNameEmail queryUser , uncurry singletonMap $ fltrUserMatriclenr queryUser , uncurry singletonMap ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult)) , fltrRelevantStudyFeaturesTerms (to $ \t -> ( E.val courseTerm , queryUser t E.^. UserId )) , fltrRelevantStudyFeaturesDegree (to $ \t -> ( E.val courseTerm , queryUser t E.^. UserId )) , fltrRelevantStudyFeaturesSemester (to $ \t -> ( E.val courseTerm , queryUser t E.^. UserId )) ] dbtFilterUI mPrev = mconcat $ catMaybes [ Just $ fltrUserNameEmailUI mPrev , Just $ fltrUserMatriclenrUI mPrev , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgExamNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgTableExamOccurrence) , Just $ fltrExamResultPointsUI mPrev , Just $ fltrRelevantStudyFeaturesTermsUI mPrev , Just $ fltrRelevantStudyFeaturesDegreeUI mPrev , Just $ fltrRelevantStudyFeaturesSemesterUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \csrf -> do let actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) actionMap = mconcat [ singletonMap ExamUserDeregister $ pure ExamUserDeregisterData , singletonMap ExamUserAssignOccurrence $ ExamUserAssignOccurrenceData <$> aopt (examOccurrenceField eid) (fslI MsgTableExamOccurrence) (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 MsgExamUserResetParts) (Just True)) (not $ all (null . examSummary) bonus) , singletonMap ExamUserSetPartResult $ ExamUserSetPartResultData <$> areq (selectField $ optionsPairs (map ((MsgExamPartNumbered &&& id) . examPartNumber . entityVal) examParts)) (fslI MsgExamPart) Nothing <*> (fmap ExamAttended <$> aopt pointsField (fslI MsgExamPoints) Nothing) , singletonMap ExamUserSetBonus $ ExamUserSetBonusData <$> aopt pointsField (fslI MsgExamPoints) Nothing , singletonMap ExamUserSetResult $ ExamUserSetResultData <$> aopt (examResultModeField (Just $ SomeMessage MsgExamResultNone) examGradingMode) (fslI MsgTableExamResult) Nothing ] actionOpts :: Handler (OptionList ExamUserAction) actionOpts = execWriterT $ do tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ] when (is _Just examGradingRule) $ tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ] unless (null examParts) $ tell =<< optionsF [ ExamUserSetPartResult ] when doBonus $ tell =<< optionsF [ ExamUserSetBonus ] tell =<< optionsF [ ExamUserSetResult ] (res, formWgt) <- multiActionMOpts actionMap actionOpts (fslI MsgExamAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _2 , dbParamsFormIdent = def } dbtIdent :: Text dbtIdent = "exam-users" dbtCsvName = MsgExamUserCsvName tid ssh csh examn dbtCsvSheetName = MsgExamUserCsvSheetName tid ssh csh examn dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName, dbtCsvSheetName , dbtCsvNoExportData = Just id , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber , dbtCsvExampleData = Nothing } where doEncode' = ExamUserTableCsv <$> view (resultUser . _entityVal . _userSurname . to Just) <*> view (resultUser . _entityVal . _userFirstName . to Just) <*> view (resultUser . _entityVal . _userDisplayName . to Just) <*> view (resultUser . _entityVal . _userMatrikelnummer) <*> view (resultUser . _entityVal . _userLdapPrimaryKey) <*> view resultStudyFeatures <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) <*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) <*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) <*> fmap (bool (const Nothing) Just doBonus ) (preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') <*> encodePartResults <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) encodePartResults = fmap Map.fromList . forM examParts $ \epEnt@(Entity epId ExamPart{..}) -> (examPartNumber, ) <$> preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt resultSheets) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser' csv fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid , dbtCsvComputeActions = \case DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey DBCsvDiffNew{dbCsvNewKey = Just _} -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do (isPart, uid) <- lift $ guessUser' dbCsvNew yieldM $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> lookupOccurrence dbCsvNew iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> when (epNumber `elem` examPartNumbers) $ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $ yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew whenIsJust (csvEUserExamResult dbCsvNew) $ \res -> do yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew guardResultKind res note <- lift . getBy $ UniqueCourseUserNote uid examCourse when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $ yield . ExamUserCsvSetCourseNoteData uid $ csvEUserCourseNote dbCsvNew DBCsvDiffExisting{..} -> do newOccurrence <- lift $ lookupOccurrence dbCsvNew when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence let uid = dbCsvOld ^. resultUser . _entityKey forM_ examPartNumbers $ \epNumber -> let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes -> when (epRes /= oldPartResult) $ yield $ ExamUserCsvSetPartResultData uid epNumber epRes let newResults :: Maybe (Map ExamPartNumber ExamResultPoints) newResults = sequence (csvEUserExamPartResults dbCsvNew) <|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld) newBonus, oldBonus :: Maybe Points newBonus = join (csvEUserBonus dbCsvNew) oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') newResult, oldResult :: Maybe ExamResultPassedGrade newResult = fmap (fmap $ bool Right (Left . view passingGrade) $ is _ExamGradingGrades examGradingMode) . examGrade examVal (newBonus <|> oldBonus) =<< newResults oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') when doBonus $ case newBonus of _ | newBonus == oldBonus -> return () _ | is _Nothing newBonus -> return () _ | Just ExamBonusManual{} <- examBonusRule -> yield $ ExamUserCsvSetBonusData False uid newBonus Nothing -> yield $ ExamUserCsvSetBonusData False uid newBonus Just _ -> yield $ ExamUserCsvSetBonusData True uid newBonus case newResult of _ | csvEUserExamResult dbCsvNew == oldResult -> return () _ | is _Nothing $ csvEUserExamResult dbCsvNew -> return () Nothing -> do yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew whenIsJust (csvEUserExamResult dbCsvNew) guardResultKind Just _ | csvEUserExamResult dbCsvNew /= newResult -> do yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew whenIsJust (csvEUserExamResult dbCsvNew) guardResultKind | oldResult /= newResult -> do yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew whenIsJust (csvEUserExamResult dbCsvNew) guardResultKind | otherwise -> return () when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $ yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew , dbtCsvClassifyAction = \case ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister ExamUserCsvRegisterData{} -> ExamUserCsvRegister ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult ExamUserCsvSetBonusData{..} | examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus | otherwise -> ExamUserCsvSetBonus ExamUserCsvSetResultData{..} | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult | otherwise -> ExamUserCsvSetResult ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing _other -> DBCsvActionExisting , dbtCsvValidateActions = do selectedActions <- State.get availableActions <- ask let missingExamDataUsers = flip filter examDataUsers $ \uid -> any (isRegisterAction uid) availableActions && none (isRegisterAction uid) selectedActions where examDataUsers = flip mapMaybe selectedActions $ \case ExamUserCsvSetResultData{..} -> Just examUserCsvActUser ExamUserCsvSetBonusData{..} -> Just examUserCsvActUser ExamUserCsvSetPartResultData{..} -> Just examUserCsvActUser _other -> Nothing isRegisterAction uid = \case ExamUserCsvCourseRegisterData{..} -> uid == examUserCsvActUser ExamUserCsvRegisterData{..} -> uid == examUserCsvActUser _other -> False unless (null missingExamDataUsers) $ tellMPoint $ messageI Error MsgExamUsersExamDataRequiresRegistration , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do now <- liftIO getCurrentTime void $ upsert CourseParticipant { courseParticipantCourse = examCourse , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now , courseParticipantState = CourseParticipantActive } [ CourseParticipantRegistration =. now , CourseParticipantState =. CourseParticipantActive ] queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser , examRegistrationOccurrence = examUserCsvActOccurrence , examRegistrationTime = now } audit $ TransactionExamRegister eid examUserCsvActUser ExamUserCsvRegisterData{..} -> do examRegistrationTime <- liftIO getCurrentTime insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser , examRegistrationOccurrence = examUserCsvActOccurrence , .. } audit $ TransactionExamRegister eid examUserCsvActUser ExamUserCsvAssignOccurrenceData{..} -> update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] ExamUserCsvSetPartResultData{..} -> do epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart case examUserCsvActExamPartResult of Nothing -> do deleteBy $ UniqueExamPartResult epid examUserCsvActUser audit $ TransactionExamPartResultDeleted epid examUserCsvActUser Just res -> do now <- liftIO getCurrentTime void $ upsertBy (UniqueExamPartResult epid examUserCsvActUser) (ExamPartResult epid examUserCsvActUser res now) [ ExamPartResultResult =. res , ExamPartResultLastChanged =. now ] 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 Nothing -> do deleteBy $ UniqueExamResult eid examUserCsvActUser audit $ TransactionExamResultDeleted eid examUserCsvActUser Just res -> do now <- liftIO getCurrentTime void $ upsertBy (UniqueExamResult eid examUserCsvActUser) (ExamResult eid examUserCsvActUser res now) [ ExamResultResult =. res , ExamResultLastChanged =. now ] audit $ TransactionExamResultEdit eid examUserCsvActUser ExamUserCsvDeregisterData{..} -> do ExamRegistration{..} <- getJust examUserCsvActRegistration deregisterExamUsers examRegistrationExam $ pure examRegistrationUser ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse whenIsJust noteId $ \nid -> do deleteWhere [CourseUserNoteEditNote ==. nid] delete nid ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do now <- liftIO getCurrentTime uid <- liftHandler requireAuthId Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] insert_ $ CourseUserNoteEdit uid now nid return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe ExamOccurrence{examOccurrenceName} <- occ \ (#{examOccurrenceName}) $nothing \ (_{MsgExamNoOccurrence}) |] ExamUserCsvRegisterData{..} -> do (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe ExamOccurrence{examOccurrenceName} <- occ \ (#{examOccurrenceName}) $nothing \ (_{MsgExamNoOccurrence}) |] ExamUserCsvAssignOccurrenceData{..} -> do occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust [whamlet| $newline never ^{registeredUserName' examUserCsvActRegistration} $maybe ExamOccurrence{examOccurrenceName} <- occ \ (#{examOccurrenceName}) $nothing \ (_{MsgExamNoOccurrence}) |] ExamUserCsvSetPartResultData{..} -> do (User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart) [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe pName <- examPartName , „#{pName}“ $nothing , _{MsgExamPartNumbered examPartNumber} $maybe newResult <- examUserCsvActExamPartResult , _{newResult} $nothing , _{MsgExamResultNone} |] ExamUserCsvSetBonusData{..} -> do User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe newBonus <- examUserCsvActExamBonus , _{newBonus} $nothing , _{MsgExamBonusNone} |] ExamUserCsvSetResultData{..} -> do User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe newResult <- examUserCsvActExamResult , _{newResult} $nothing , _{MsgExamResultNone} |] ExamUserCsvSetCourseNoteData{..} -> do User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $if isn't _Just examUserCsvActCourseNote \ (_{MsgExamUserCsvCourseNoteDeleted}) |] ExamUserCsvDeregisterData{..} -> registeredUserName' examUserCsvActRegistration , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text } where guardResultKind :: MonadThrow m => ExamResultPassedGrade -> m () guardResultKind res | ( is _ExamGradingPass examGradingMode && is (_ExamAttended . _Right) res ) || ( is _ExamGradingGrades examGradingMode && is (_ExamAttended . _Left) res ) = throwM . ExamUserCsvExceptionMismatchedGradingMode examGradingMode $ if | is (_ExamAttended . _Left) res -> ExamGradingPass | otherwise -> ExamGradingGrades | otherwise = return () registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where Entity _ User{..} = view resultUser $ existing ! registration guessUser' :: ExamUserTableCsv -> DB (Bool, UserId) guessUser' ExamUserTableCsv{..} = do let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserEduPersonPrincipalName <$> csvEUserEPPN , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname , GuessUserFirstName <$> csvEUserFirstName ] guess <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria (Just 2) -- we're only interested in at most one match, but want to throw an error on multiple matches pid <- either (const $ throwM ExamUserCsvExceptionMultipleMatchingUsers) (return . entityKey) guess (,) <$> exists [CourseParticipantCourse ==. examCourse, CourseParticipantUser ==. pid, CourseParticipantState ==. CourseParticipantActive] <*> pure pid lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId) lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] [] case occIds of [occId] -> return occId _other -> throwM ExamUserCsvExceptionNoMatchingOccurrence dbtExtraReps = [] examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] & defaultPagesize PagesizeAll postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData) postprocess inp = do (First (Just act), regMap) <- inp let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap return (act, regMap') (, exam, (bonus, resultSheets)) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case (ExamUserDeregisterData, Map.elems -> selectedRegistrations) -> do nrDel <- runDB . setSerializable . deregisterExamUsersCount eId $ map (view $ resultUser . _entityKey) selectedRegistrations addMessageI Success $ MsgExamUsersDeregistered nrDel redirect $ CExamR tid ssh csh examn EUsersR (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do nrUpdated <- runDB $ updateWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] [ ExamRegistrationOccurrence =. occId ] addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated redirect $ CExamR tid ssh csh examn EUsersR (ExamUserAcceptComputedResultData, Map.elems -> rows) -> do nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do now <- liftIO getCurrentTime uid <- view $ resultUser . _entityKey hasResult <- asks $ has resultExamResult hasBonus <- asks $ has resultExamBonus autoResult <- preview $ resultAutomaticExamResult examVal bonus resultSheets autoBonus <- preview $ resultAutomaticExamBonus examVal bonus autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) resultSheets) lift $ if | not hasResult , Just examResultResult <- autoResult -> do if | Just examBonusBonus <- autoBonus , not hasBonus -> do insert_ ExamBonus { examBonusExam = eId , examBonusUser = uid , examBonusLastChanged = now , .. } audit $ TransactionExamBonusEdit eId uid | otherwise -> return () iforM_ (Map.fromList $ catMaybes autoParts) $ \epId autoPartResult -> do insert_ ExamPartResult { examPartResultExamPart = epId , examPartResultUser = uid , examPartResultResult = autoPartResult , examPartResultLastChanged = now } audit $ TransactionExamPartResultEdit epId uid insert_ ExamResult { examResultExam = eId , examResultUser = uid , examResultLastChanged = now , .. } audit $ TransactionExamResultEdit eId uid return $ Sum 1 | otherwise -> return mempty addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted redirect $ CExamR tid ssh csh examn EUsersR (ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do uid <- view $ resultUser . _entityKey lift $ do when examUserResetBonus $ do bonusId' <- getKeyBy $ UniqueExamBonus eId uid whenIsJust bonusId' $ \bonusId -> do delete bonusId audit $ TransactionExamBonusDeleted eId uid when examUserResetParts $ do forM_ (foldMap (Map.keysSet . unMergeMap . examSummary) $ Map.lookup uid bonus) $ \epId -> do partResultId' <- getKeyBy $ UniqueExamPartResult epId uid whenIsJust partResultId' $ \partResultId -> do delete partResultId audit $ TransactionExamPartResultDeleted epId uid result <- getKeyBy $ UniqueExamResult eId uid case result of Just resId -> do delete resId audit $ TransactionExamResultDeleted eId uid return $ Sum 1 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 finishWgt <- examFinishWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading let computedValuesTip = notificationWidget NotificationBroad Warning $(i18nWidgetFile "exam-users/computed-values-tip") $(widgetFile "exam-users")