{-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Exam.Users ( getEUsersR, postEUsersR ) where import Import import Utils.Lens import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Table.Columns import Handler.Utils.Table.Cells import Handler.Utils.Csv 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.Text 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 Control.Arrow (Kleisli(..)) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) 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 ExamResult)) type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult)) 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 4 1) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) queryExamOccurrence = $(sqlLOJproj 4 2) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) queryExamResult = $(sqlLOJproj 4 4) 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 resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _7 . _Just 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 Points , csvEUserExerciseNumPasses :: Maybe Int , csvEUserExercisePointsMax :: Maybe Points , csvEUserExerciseNumPassesMax :: Maybe Int , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) } deriving (Generic) makeLenses_ ''ExamUserTableCsv examUserTableCsvOptions :: Csv.Options examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } instance ToNamedRecord ExamUserTableCsv where toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions instance FromNamedRecord ExamUserTableCsv where parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions instance DefaultOrdered ExamUserTableCsv where headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions instance CsvColumnsExplained ExamUserTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) , ('csvEUserName , MsgCsvColumnExamUserName ) , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) , ('csvEUserField , MsgCsvColumnExamUserField ) , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) , ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses ) , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) ] data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence 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) data ExamUserCsvActionClass = ExamUserCsvCourseRegister | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField | ExamUserCsvDeregister | ExamUserCsvSetResult 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 } | ExamUserCsvSetResultData { examUserCsvActUser :: UserId , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel , fieldLabelModifier = camelToPathPiece' 3 , sumEncoding = TaggedObject "action" "data" } ''ExamUserCsvAction data ExamUserCsvException = ExamUserCsvExceptionNoMatchingUser | ExamUserCsvExceptionNoMatchingStudyFeatures | ExamUserCsvExceptionNoMatchingOccurrence 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 (registrationResult, examUsersTable) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn bonus <- examBonus exam let allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus showPasses = numSheetsPasses allBoni /= 0 showPoints = getSum (numSheetsPoints allBoni) /= 0 resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades let examUsersDBTable = DBTable{..} where dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) E.&&. examResult E.?. ExamResultExam 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.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, examResult) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id $ 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) -> fromMaybe mempty $ do SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) ] dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserMatriclenr queryUser , sortField queryStudyField , sortDegreeShort queryStudyDegree , sortFeaturesSemester queryStudyFeatures , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser , fltrUserMatriclenr queryUser , fltrField queryStudyField , fltrDegree queryStudyDegree , fltrFeaturesSemester queryStudyFeatures , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult)) , ( "result-bool" , FilterColumn $ \row criteria -> if | Set.null criteria -> E.true | otherwise -> let passed :: [ExamResultGrade] passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF criteria' = Set.map (fmap $ review passingGrade) criteria criteria'' | ExamAttended (ExamPassed True) `Set.member` criteria = criteria' `Set.union` Set.fromList passed | otherwise = criteria' in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'') ) ] 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 textField (fslI MsgExamOccurrence) , guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult) , guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult) ] 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 = Map.fromList [ ( ExamUserDeregister , pure ExamUserDeregisterData ) , ( ExamUserAssignOccurrence , ExamUserAssignOccurrenceData <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) ) ] (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } dbtIdent :: Text dbtIdent = "exam-users" dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv dbtCsvEncode = DictJust . C.map $ 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) <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser csv fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid , dbtCsvComputeActions = \case DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey DBCsvDiffNew{dbCsvNewKey = Just _} -> fail "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 <$> pure uid <*> lookupOccurrence dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse when (newFeatures /= oldFeatures) $ yield $ ExamUserCsvSetCourseFieldData cpId newFeatures | otherwise -> yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew when (is _Just $ csvEUserExamResult dbCsvNew) $ yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew DBCsvDiffExisting{..} -> do newOccurrence <- lift $ lookupOccurrence dbCsvNew when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence newFeatures <- lift $ lookupStudyFeatures dbCsvNew when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey yield $ ExamUserCsvSetCourseFieldData cpId newFeatures when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew , dbtCsvClassifyAction = \case ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister ExamUserCsvRegisterData{} -> ExamUserCsvRegister ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetResultData{} -> ExamUserCsvSetResult , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing _other -> DBCsvActionExisting , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do now <- liftIO getCurrentTime insert_ CourseParticipant { courseParticipantCourse = examCourse , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now , courseParticipantField = examUserCsvActCourseField } User{userIdent} <- getJust examUserCsvActUser audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser , examRegistrationOccurrence = examUserCsvActOccurrence , examRegistrationTime = now } ExamUserCsvRegisterData{..} -> do examRegistrationTime <- liftIO getCurrentTime insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser , examRegistrationOccurrence = examUserCsvActOccurrence , .. } ExamUserCsvAssignOccurrenceData{..} -> update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] ExamUserCsvSetCourseFieldData{..} -> update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of Nothing -> deleteBy $ UniqueExamResult eid examUserCsvActUser Just res -> let res' = either (over _examResult $ review passingGrade) id res in void $ upsert (ExamResult eid examUserCsvActUser res') [ ExamResultResult =. res' ] ExamUserCsvDeregisterData{..} -> do ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration User{userIdent} <- getJust examRegistrationUser audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent delete examUserCsvActRegistration return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do (User{..}, occ) <- liftHandlerT . 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) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe ExamOccurrence{examOccurrenceName} <- occ \ (#{examOccurrenceName}) $nothing \ (_{MsgExamNoOccurrence}) |] ExamUserCsvAssignOccurrenceData{..} -> do occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust [whamlet| $newline never ^{registeredUserName' examUserCsvActRegistration} $maybe ExamOccurrence{examOccurrenceName} <- occ \ (#{examOccurrenceName}) $nothing \ (_{MsgExamNoOccurrence}) |] ExamUserCsvSetCourseFieldData{..} -> do User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe features <- examUserCsvActCourseField , ^{studyFeaturesWidget features} $nothing , _{MsgCourseStudyFeatureNone} |] ExamUserCsvSetResultData{..} -> do User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} $maybe newResult <- examUserCsvActExamResult $case newResult $of Left pResult , _{pResult} $of Right gResult , _{gResult} $nothing , _{MsgExamResultNone} |] ExamUserCsvDeregisterData{..} -> registeredUserName' examUserCsvActRegistration , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text } where studyFeaturesWidget :: StudyFeaturesId -> Widget studyFeaturesWidget featId = do (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) [whamlet| $newline never _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} |] 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{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do users <- E.select . E.from $ \user -> do E.where_ . E.and $ catMaybes [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname , (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName ] let isCourseParticipant = E.exists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.limit 2 return $ (isCourseParticipant, user E.^. UserId) case users of (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)]) -> return (isPart, uid) [(E.Value isPart, E.Value uid)] -> return (isPart, uid) _other -> throwM ExamUserCsvExceptionNoMatchingUser 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 studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> 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 E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True E.limit 2 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 -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] & defaultPagesize PagesizeAll postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) postprocess inp = do (First (Just act), regMap) <- inp let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap return (act, regSet) over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case (ExamUserDeregisterData, selectedRegistrations) -> do nrDel <- runDB $ deleteWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] addMessageI Success $ MsgExamUsersDeregistered nrDel redirect $ CExamR tid ssh csh examn EUsersR (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do nrUpdated <- runDB $ updateWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] [ ExamRegistrationOccurrence =. occId ] addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated redirect $ CExamR tid ssh csh examn EUsersR siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading $(widgetFile "exam-users")