{-# 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.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) import Handler.ExamOffice.Exam (examCloseWidget) import qualified Database.Esqueleto 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 (deleteWhereCount, updateWhereCount) import Control.Lens.Indexed ((<.), (.>)) import Jobs.Queue 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 StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) ) ) `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 StudyFeatures) , Maybe (Entity StudyDegree) , Maybe (Entity StudyTerms) , Maybe (Entity ExamBonus) , Maybe (Entity ExamResult) , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) , Maybe (Entity CourseUserNote) ) 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 2 1) . $(sqlLOJproj 6 3) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(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 resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) resultStudyFeatures = _dbrOutput . _4 . _Just resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _5 . _Just resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) resultStudyField = _dbrOutput . _6 . _Just resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus) resultExamBonus = _dbrOutput . _7 . _Just resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _8 . _Just resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) resultExamParts = _dbrOutput . _9 . itraversed -- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart) -- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2 resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) resultExamPartResults = resultExamParts <. _2 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) resultCourseNote = _dbrOutput . _10 . _Just resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> 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 -> 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' let gradeRes = examGrade exam bonus =<< parts' return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes 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 , csvEUserField :: Maybe Text , csvEUserDegree :: Maybe Text , csvEUserSemester :: Maybe Int , 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 Html } 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 , "field" Csv..= csvEUserField , "degree" Csv..= csvEUserDegree , "semester" Csv..= csvEUserSemester , "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 csv = ExamUserTableCsv <$> csv .:?? "surname" <*> csv .:?? "first-name" <*> csv .:?? "name" <*> csv .:?? "matriculation" <*> csv .:?? "field" <*> csv .:?? "degree" <*> csv .:?? "semester" <*> 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 "field" MsgCsvColumnExamUserField , single "degree" MsgCsvColumnExamUserDegree , single "semester" MsgCsvColumnExamUserSemester , 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" , "field", "degree", "semester" , "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, Typeable) 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 :: Bool } data ExamUserCsvActionClass = ExamUserCsvCourseRegister | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField | ExamUserCsvSetPartResult | ExamUserCsvSetBonus | ExamUserCsvOverrideBonus | ExamUserCsvSetResult | ExamUserCsvOverrideResult | ExamUserCsvSetCourseNote | ExamUserCsvDeregister deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id data ExamUserCsvAction = ExamUserCsvCourseRegisterData { examUserCsvActUser :: UserId , examUserCsvActCourseField :: Maybe StudyFeaturesId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvRegisterData { examUserCsvActUser :: UserId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvAssignOccurrenceData { examUserCsvActRegistration :: ExamRegistrationId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvSetCourseFieldData { examUserCsvActCourseParticipant :: CourseParticipantId , examUserCsvActCourseField :: Maybe StudyFeaturesId } | 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 Html } deriving (Eq, Ord, Read, Show, Generic, Typeable) 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, Typeable) 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) <- 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 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 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) csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) let examUsersDBTable = DBTable{..} where dbtSQLQuery = runReaderT $ do examRegistration <- asks queryExamRegistration user <- asks queryUser occurrence <- asks queryExamOccurrence courseParticipant <- asks queryCourseParticipant studyFeatures <- asks queryStudyFeatures studyDegree <- asks queryStudyDegree studyField <- asks queryStudyField 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 $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) 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, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ (,,,,,,,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8 <*> getExamParts <*> view _9 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 $ colField resultStudyField , pure $ colDegreeShort resultStudyDegree , pure $ colFeaturesSemester resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ 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) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts ] , 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 ] dbtSorting = mconcat [ uncurry singletonMap $ sortUserNameLink queryUser , uncurry singletonMap $ sortUserMatriclenr queryUser , uncurry singletonMap $ sortField queryStudyField , uncurry singletonMap $ sortDegreeShort queryStudyDegree , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures , 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 $ 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 , Just $ fltrUserMatriclenrUI mPrev , Just $ fltrFieldUI mPrev , Just $ fltrDegreeUI mPrev , Just $ fltrFeaturesSemesterUI mPrev , 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 { 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 MsgExamOccurrence) (Just Nothing) , singletonMap ExamUserAcceptComputedResult $ pure ExamUserAcceptComputedResultData , singletonMap ExamUserResetToComputedResult $ ExamUserResetToComputedResultData <$> 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 (examResultModeField (Just $ SomeMessage MsgExamResultNone) examGradingMode) (fslI MsgExamResult) 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 MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _2 , dbParamsFormIdent = def } dbtIdent :: Text dbtIdent = "exam-users" dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName = unpack csvName , 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) <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> 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') <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) 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 if | isPart -> do yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse when (newFeatures /= oldFeatures) $ yield $ ExamUserCsvSetCourseFieldData cpId newFeatures | otherwise -> yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> 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 newFeatures <- lift $ lookupStudyFeatures dbCsvNew when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey yield $ ExamUserCsvSetCourseFieldData cpId newFeatures 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 ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult ExamUserCsvSetBonusData{..} | examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus | otherwise -> ExamUserCsvSetBonus ExamUserCsvSetResultData{..} | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult | otherwise -> ExamUserCsvSetResult ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing _other -> DBCsvActionExisting , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do now <- liftIO getCurrentTime void $ upsert CourseParticipant { courseParticipantCourse = examCourse , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now , courseParticipantField = examUserCsvActCourseField , courseParticipantAllocated = Nothing , courseParticipantState = CourseParticipantActive } [ CourseParticipantRegistration =. now , CourseParticipantField =. examUserCsvActCourseField , CourseParticipantAllocated =. Nothing , 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 ] ExamUserCsvSetCourseFieldData{..} -> do update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] CourseParticipant{..} <- getJust examUserCsvActCourseParticipant audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser 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{examRegistrationUser} <- getJust examUserCsvActRegistration audit $ TransactionExamDeregister eid examRegistrationUser delete examUserCsvActRegistration result <- getBy $ UniqueExamResult eid examRegistrationUser forM_ result $ \(Entity erId _) -> do delete erId audit $ TransactionExamResultDeleted eid 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 features <- examUserCsvActCourseField , ^{studyFeaturesWidget features} $nothing , _{MsgCourseStudyFeatureNone} $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}) |] ExamUserCsvSetCourseFieldData{..} -> do User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe features <- examUserCsvActCourseField , ^{studyFeaturesWidget features} $nothing , _{MsgCourseStudyFeatureNone} |] 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 $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $ [ GuessUserMatrikelnummer <$> csvEUserMatriculation , 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 lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId) lookupStudyFeatures csv@ExamUserTableCsv{..} = do uid <- view _2 <$> guessUser' csv oldFeatures <- getBy $ UniqueParticipant uid examCourse studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField) , E.asc (studyFeatures E.^. StudyFeaturesDegree) , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree E.where_ . E.and $ catMaybes [ do field <- csvEUserField return . E.or $ catMaybes [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field ] , do degree <- csvEUserDegree return . E.or $ catMaybes [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree ] , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester ] E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True isActiveOrPrevious = case oldFeatures of Just (Entity _ CourseParticipant{courseParticipantField = Just sfid}) -> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId) _ -> isActive E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)] return $ studyFeatures E.^. StudyFeaturesId case studyFeatures of [E.Value fid] -> return $ Just fid _other | is _Nothing csvEUserField , is _Nothing csvEUserDegree , is _Nothing csvEUserSemester -> return Nothing _other | Just (Entity _ CourseParticipant{..}) <- oldFeatures , Just sfid <- courseParticipantField , E.Value sfid `elem` studyFeatures -> return $ Just sfid _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures 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) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do nrDel <- runDB $ deleteWhereCount [ ExamRegistrationId <-. Set.toList 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 autoBonus <- preview $ resultAutomaticExamBonus examVal bonus 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 () 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 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 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")