From 4f9a4f7f44fcf6fa004657afc212e5562972d017 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 25 Aug 2020 14:27:58 +0200 Subject: [PATCH] refactor: remove course-participant-field, course-application-field --- models/courses.model | 2 +- models/courses/applications.model | 2 +- src/Handler/Allocation/Application.hs | 18 +-- src/Handler/Course/Application/List.hs | 155 ++------------------- src/Handler/Course/ParticipantInvite.hs | 39 +----- src/Handler/Course/Register.hs | 22 +-- src/Handler/Course/User.hs | 31 +---- src/Handler/Course/Users.hs | 172 ++++++----------------- src/Handler/Exam/AddUser.hs | 1 - src/Handler/Exam/RegistrationInvite.hs | 13 +- src/Handler/Exam/Users.hs | 175 ++---------------------- src/Handler/ExamOffice/Exam.hs | 67 +-------- src/Handler/Tutorial/Users.hs | 5 +- src/Handler/Utils/Allocation.hs | 4 +- templates/course/user/profile.hamlet | 3 - test/Database/Fill.hs | 41 +++--- 16 files changed, 117 insertions(+), 633 deletions(-) diff --git a/models/courses.model b/models/courses.model index 708064a28..0dfebc12f 100644 --- a/models/courses.model +++ b/models/courses.model @@ -56,7 +56,7 @@ CourseParticipant -- course enrolement course CourseId user UserId registration UTCTime -- time of last enrolement for this course - field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades + field StudyFeaturesId Maybe MigrationOnly allocated AllocationId Maybe -- participant was centrally allocated state CourseParticipantState UniqueParticipant user course diff --git a/models/courses/applications.model b/models/courses/applications.model index b4648a60e..8e7d6c8d5 100644 --- a/models/courses/applications.model +++ b/models/courses/applications.model @@ -1,7 +1,7 @@ CourseApplication course CourseId user UserId - field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades + field StudyFeaturesId Maybe MigrationOnly text Text Maybe -- free text entered by user ratingVeto Bool default=false ratingPoints ExamGrade Maybe diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 7f0a6154e..f48db411e 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -44,7 +44,6 @@ data ApplicationFormView = ApplicationFormView data ApplicationForm = ApplicationForm { afPriority :: Maybe Natural - , afField :: Maybe StudyFeaturesId , afText :: Maybe Text , afFiles :: Maybe FileUploads , afRatingVeto :: Bool @@ -118,12 +117,6 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf (False, _ , _ , _ ) -> pure (FormSuccess Nothing, Nothing) - (fieldRes, fieldView') <- if - | afmApplicantEdit || afmLecturer - -> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp) - | otherwise - -> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal) - let textField' = convertField (Text.strip . unTextarea) Textarea textareaField textFs | is _Just courseApplicationsInstructions @@ -216,7 +209,6 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf return ( ApplicationForm <$> prioRes - <*> fieldRes <*> textRes <*> filesRes <*> vetoRes @@ -226,8 +218,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf , ApplicationFormView { afvPriority = prioView , afvForm = catMaybes $ - [ Just fieldView' - , textView + [ textView , filesLinkView , filesWarningView ] ++ maybe [] (map Just) filesView ++ @@ -274,7 +265,6 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do appId <- insert CourseApplication { courseApplicationCourse = cid , courseApplicationUser = uid - , courseApplicationField = afField , courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints @@ -303,8 +293,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do oldApp <- get404 appId let newApp = oldApp - { courseApplicationField = afField - , courseApplicationText = afText + { courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment @@ -323,8 +312,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do ] appChanged = any (\f -> f oldApp newApp) - [ (/=) `on` courseApplicationField - , (/=) `on` courseApplicationText + [ (/=) `on` courseApplicationText , \_ _ -> not $ Set.null changes ] diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index b2b7200b4..a47d967f7 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -33,18 +33,11 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic `E.InnerJoin` E.SqlExpr (Entity User) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation)) - `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures)) - `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) - `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant)) type CourseApplicationsTableData = DBRow ( Entity CourseApplication , Entity User , Bool -- hasFiles , Maybe (Entity Allocation) - , Maybe (Entity StudyFeatures) - , Maybe (Entity StudyTerms) - , Maybe (Entity StudyDegree) , Bool -- isParticipant ) @@ -52,34 +45,25 @@ courseApplicationsIdent :: Text courseApplicationsIdent = "applications" queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication)) -queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) +queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User)) -queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) +queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) -queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) +queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) where hasFiles appl = E.exists . E.from $ \courseApplicationFile -> E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation))) -queryAllocation = to $(sqlLOJproj 4 2) - -queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) -queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3) - -queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) -queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3) - -queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) -queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3) +queryAllocation = to $(sqlLOJproj 3 2) queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant))) -queryCourseParticipant = to $(sqlLOJproj 4 4) +queryCourseParticipant = to $(sqlLOJproj 3 3) queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool)) -queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4) +queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 3 3) resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication) resultCourseApplication = _dbrOutput . _1 @@ -93,17 +77,8 @@ resultHasFiles = _dbrOutput . _3 resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation) resultAllocation = _dbrOutput . _4 . _Just -resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures) -resultStudyFeatures = _dbrOutput . _5 . _Just - -resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms) -resultStudyTerms = _dbrOutput . _6 . _Just - -resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree) -resultStudyDegree = _dbrOutput . _7 . _Just - resultIsParticipant :: Lens' CourseApplicationsTableData Bool -resultIsParticipant = _dbrOutput . _8 +resultIsParticipant = _dbrOutput . _5 newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool @@ -127,9 +102,6 @@ data CourseApplicationsTableCsv = CourseApplicationsTableCsv , csvCAName :: Maybe Text , csvCAEmail :: Maybe UserEmail , csvCAMatriculation :: Maybe Text - , csvCAField :: Maybe Text - , csvCADegree :: Maybe Text - , csvCASemester :: Maybe Int , csvCAText :: Maybe Text , csvCAHasFiles :: Maybe Bool , csvCAVeto :: Maybe CourseApplicationsTableVeto @@ -152,9 +124,6 @@ instance Csv.FromNamedRecord CourseApplicationsTableCsv where <*> csv .:?? "name" <*> csv .:?? "email" <*> csv .:?? "matriculation" - <*> csv .:?? "field" - <*> csv .:?? "degree" - <*> csv .:?? "semester" <*> csv .:?? "text" <*> csv .:?? "has-files" <*> csv .:?? "veto" @@ -171,9 +140,6 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where , ('csvCAName , MsgCsvColumnApplicationsName ) , ('csvCAEmail , MsgCsvColumnApplicationsEmail ) , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation) - , ('csvCAField , MsgCsvColumnApplicationsField ) - , ('csvCADegree , MsgCsvColumnApplicationsDegree ) - , ('csvCASemester , MsgCsvColumnApplicationsSemester ) , ('csvCAText , MsgCsvColumnApplicationsText ) , ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles ) , ('csvCAVeto , MsgCsvColumnApplicationsVeto ) @@ -182,19 +148,14 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where ] data CourseApplicationsTableCsvActionClass - = CourseApplicationsTableCsvSetField - | CourseApplicationsTableCsvSetVeto + = CourseApplicationsTableCsvSetVeto | CourseApplicationsTableCsvSetRating | CourseApplicationsTableCsvSetComment deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id data CourseApplicationsTableCsvAction - = CourseApplicationsTableCsvSetFieldData - { caCsvActApplication :: CourseApplicationId - , caCsvActField :: Maybe StudyFeaturesId - } - | CourseApplicationsTableCsvSetVetoData + = CourseApplicationsTableCsvSetVetoData { caCsvActApplication :: CourseApplicationId , caCsvActVeto :: Bool } @@ -284,18 +245,12 @@ postCApplicationsR tid ssh csh = do hasFiles <- view queryHasFiles user <- view queryUser allocation <- view queryAllocation - studyFeatures <- view queryStudyFeatures - studyTerms <- view queryStudyTerms - studyDegree <- view queryStudyDegree courseParticipant <- view queryCourseParticipant lift $ do E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid) E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive) - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid @@ -306,14 +261,11 @@ postCApplicationsR tid ssh csh = do , user , hasFiles , allocation - , studyFeatures - , studyTerms - , studyDegree , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId ) dbtProj :: DBRow _ -> DB CourseApplicationsTableData - dbtProj = traverse $ return . over _3 E.unValue . over _8 E.unValue + dbtProj = traverse $ return . over _3 E.unValue . over _5 E.unValue dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId) @@ -325,9 +277,6 @@ postCApplicationsR tid ssh csh = do , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , lmap (view $ resultUser . _entityVal) colUserEmail , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) - , emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms - , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree - , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText) , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles)) , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto) @@ -341,9 +290,6 @@ postCApplicationsR tid ssh csh = do , sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname)) , uncurry singletonMap . sortUserEmail $ view queryUser , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer) - , sortStudyTerms queryStudyTerms - , sortStudyDegree queryStudyDegree - , sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester) , sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText) , sortApplicationFiles queryHasFiles , sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto) @@ -356,9 +302,6 @@ postCApplicationsR tid ssh csh = do , fltrUserName' $ queryUser . to (E.^. UserDisplayName) , uncurry singletonMap . fltrUserEmail $ view queryUser , fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer) - , fltrStudyTerms queryStudyTerms - , fltrStudyDegree queryStudyDegree - , fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester) , fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText) , fltrApplicationFiles queryHasFiles , fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto) @@ -370,9 +313,6 @@ postCApplicationsR tid ssh csh = do , fltrUserNameUI' , fltrUserMatriculationUI , fltrUserEmailUI - , fltrStudyTermsUI - , fltrStudyDegreeUI - , fltrStudyFeaturesSemesterUI , fltrApplicationTextUI , fltrApplicationFilesUI , fltrApplicationVetoUI @@ -391,9 +331,6 @@ postCApplicationsR tid ssh csh = do <*> preview (resultUser . _entityVal . _userDisplayName) <*> preview (resultUser . _entityVal . _userEmail) <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just) - <*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey))) - <*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey))) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just) <*> preview resultHasFiles <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto) @@ -416,10 +353,6 @@ postCApplicationsR tid ssh csh = do DBCsvDiffExisting{..} -> do let appId = dbCsvOld ^. resultCourseApplication . _entityKey - newFeatures <- lift $ lookupStudyFeatures dbCsvNew - when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ - yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures - let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto whenIsJust mVeto $ \veto -> when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $ @@ -431,18 +364,12 @@ postCApplicationsR tid ssh csh = do when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $ yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment) , dbtCsvClassifyAction = \case - CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment , dbtCsvCoarsenActionClass = const DBCsvActionExisting , dbtCsvExecuteActions = do C.mapM_ $ \case - CourseApplicationsTableCsvSetFieldData{..} -> do - CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField - , CourseApplicationTime =. now - ] - audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication CourseApplicationsTableCsvSetVetoData{..} -> do CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto , CourseApplicationRatingTime =. Just now @@ -460,15 +387,6 @@ postCApplicationsR tid ssh csh = do audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication return $ CourseR tid ssh csh CApplicationsR , dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case - CourseApplicationsTableCsvSetFieldData{..} -> - [whamlet| - $newline never - ^{existingApplicantName' caCsvActApplication} - $maybe features <- caCsvActField - , ^{studyFeaturesWidget features} - $nothing - , _{MsgCourseStudyFeatureNone} - |] CourseApplicationsTableCsvSetVetoData{..} -> [whamlet| $newline never @@ -538,59 +456,6 @@ postCApplicationsR tid ssh csh = do where Entity _ User{..} = existing ^. singular (ix appId . resultUser) - lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId) - lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do - appRes <- guessUser csv - (uid, oldFeatures) <- case appRes of - Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] [] - Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId - 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 <- csvCAField - 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 <- csvCADegree - 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 <$> csvCASemester - ] - E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid - let isActiveOrPrevious = E.or - $ (studyFeatures E.^. StudyFeaturesValid) - : [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId - | Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures - ] - 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 csvCAField - , is _Nothing csvCADegree - , is _Nothing csvCASemester - -> return Nothing - _other - | [Entity _ CourseApplication{..}] <- oldFeatures - , Just sfid <- courseApplicationField - , E.Value sfid `elem` studyFeatures - -> return $ Just sfid - _other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures - - dbtIdent = courseApplicationsIdent psValidator :: PSValidator _ _ diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index dab5b62e2..c2e01d7c5 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -40,7 +40,6 @@ instance IsInvitableJunction CourseParticipant where type InvitationFor CourseParticipant = Course data InvitableJunction CourseParticipant = JunctionParticipant { jParticipantRegistration :: UTCTime - , jParticipantField :: Maybe StudyFeaturesId , jParticipantAllocated :: Maybe AllocationId , jParticipantState :: CourseParticipantState } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -53,8 +52,8 @@ instance IsInvitableJunction CourseParticipant where deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso - (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState)) - (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState) -> CourseParticipant{..}) + (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState)) + (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..}) instance ToJSON (InvitableJunction CourseParticipant) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } @@ -92,11 +91,9 @@ participantInvitationConfig = InvitationConfig{..} itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do + invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime - studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) - (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive + return . fmap (, ()) $ JunctionParticipant now <$> pure Nothing <*> pure CourseParticipantActive invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert res <- act -- insertUnique @@ -109,7 +106,6 @@ participantInvitationConfig = InvitationConfig{..} data AddParticipantsResult = AddParticipantsResult { aurAlreadyRegistered - , aurNoUniquePrimaryField , aurSuccess :: Set UserId } deriving (Read, Show, Generic, Typeable) @@ -169,20 +165,14 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => AddParticipantsResult -> ReaderT (YesodPersistBackend UniWorX) m [Message] addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do - (aurAlreadyRegistered', aurNoUniquePrimaryField') <- - (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered) - <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField) + aurAlreadyRegistered' <- + fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered) unless (null aurAlreadyRegistered) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) - unless (null aurNoUniquePrimaryField) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|] - modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - unless (null aurSuccess) $ tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess @@ -200,18 +190,6 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } - features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] - applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] - - let courseParticipantField - | [f] <- features - = Just f - | [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications - , f' `elem` features - = Just f' - | otherwise - = Nothing - courseParticipantRegistration <- liftIO getCurrentTime void . lift . lift $ upsert CourseParticipant @@ -222,7 +200,6 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do , .. } [ CourseParticipantRegistration =. courseParticipantRegistration - , CourseParticipantField =. courseParticipantField , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] @@ -231,9 +208,7 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do void . lift . lift $ setUserSubmissionGroup cid uid mbGrp - return $ case courseParticipantField of - Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid } - Just _ -> mempty { aurSuccess = Set.singleton uid } + return $ mempty { aurSuccess = Set.singleton uid } getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index e0cd7f593..d5e199c46 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -41,8 +41,7 @@ instance Button UniWorX ButtonCourseRegister where data CourseRegisterForm = CourseRegisterForm - { crfStudyFeatures :: Maybe StudyFeaturesId - , crfApplicationText :: Maybe Text + { crfApplicationText :: Maybe Text , crfApplicationFiles :: Maybe FileUploads } @@ -82,17 +81,6 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do | otherwise -> return $ FormSuccess () - fieldRes <- if - | is _Nothing muid - -> return $ FormSuccess Nothing - | is _Just muid - , isRegistered - , Just mFeature <- courseApplicationField . entityVal <$> application - <|> courseParticipantField . entityVal <$> registration - -> wforced (studyFeaturesFieldFor Nothing True (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature - | otherwise - -> wreq (studyFeaturesFieldFor Nothing False [] muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - appTextRes <- let fs | courseApplicationsRequired , is _Just courseApplicationsInstructions = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions @@ -167,7 +155,6 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do return $ CourseRegisterForm <$ secretRes - <*> fieldRes <*> appTextRes <*> appFilesRes @@ -200,7 +187,7 @@ postCRegisterR tid ssh csh = do = void <$> do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] appRes <- case appIds of - [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing + [] -> insertUnique $ CourseApplication cid uid crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing (prevId:ps) -> do forM_ ps $ \appId -> do deleteApplicationFiles appId @@ -208,7 +195,7 @@ postCRegisterR tid ssh csh = do audit $ TransactionCourseApplicationDeleted cid uid appId deleteApplicationFiles prevId - update prevId [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ] + update prevId [ CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ] return $ Just prevId @@ -222,9 +209,8 @@ postCRegisterR tid ssh csh = do mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid entityKey <$> upsert - (CourseParticipant cid uid cTime crfStudyFeatures Nothing CourseParticipantActive) + (CourseParticipant cid uid cTime Nothing CourseParticipantActive) [ CourseParticipantRegistration =. cTime - , CourseParticipantField =. crfStudyFeatures , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index e7ad89d12..6ec813d2a 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -100,29 +100,6 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = return (studyfeat, studydegree, studyterms) return (registration, studies) - ((regFieldRes, regFieldView), regFieldEnctype) <- lift . runFormPost . identifyForm FIDcRegField $ \csrf -> - let currentField :: Maybe (Maybe StudyFeaturesId) - currentField = courseParticipantField . entityVal <$> mRegistration - in over _2 ((toWidget csrf <>) . fvWidget) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField - - let registrationFieldFrag :: Text - registrationFieldFrag = "registration-field" - regFieldWidget = wrapForm regFieldView FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag - , formEncoding = regFieldEnctype - , formAttrs = [] - , formSubmit = FormAutoSubmit - , formAnchor = Just registrationFieldFrag - } - for_ mRegistration $ \(Entity pId CourseParticipant{}) -> - formResult regFieldRes $ \courseParticipantField' -> do - lift . runDB $ do - update pId [ CourseParticipantField =. courseParticipantField' ] - audit $ TransactionCourseParticipantEdit cid uid - addMessageI Success MsgCourseStudyFeatureUpdated - redirect $ currentRoute :#: registrationFieldFrag - mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR let regButton | is _Just mRegistration = BtnCourseDeregister @@ -179,16 +156,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = -> invalidArgs ["User not registered"] (BtnCourseRegister, _) -> do now <- liftIO getCurrentTime - let field - | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies - = Just featId - | otherwise - = Nothing lift . runDBJobs $ do void $ upsert - (CourseParticipant cid uid now field Nothing CourseParticipantActive) + (CourseParticipant cid uid now Nothing CourseParticipantActive) [ CourseParticipantRegistration =. now - , CourseParticipantField =. field , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index f12e7993d..0df3cf49b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -4,7 +4,7 @@ module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR - , colUserDegreeShort, colUserField, colUserSemester, colUserSex' + , colUserSex' ) where import Import @@ -39,10 +39,6 @@ type UserTableExpr = ( E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) - `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 SubmissionGroup)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser)) ) @@ -53,50 +49,38 @@ type UserTableExpr = ( E.SqlExpr (Entity User) -- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions) -- This ought to ease refactoring the query queryUser :: UserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) +queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant) -queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) +queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) -queryUserNote = $(sqlLOJproj 4 2) - -queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 4 3) - -queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 4 3) - -queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 4 3) +queryUserNote = $(sqlLOJproj 3 2) querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup)) -querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4) +querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 3 3) userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) , E.SqlExpr (Entity CourseParticipant) , E.SqlExpr (E.Value (Maybe (Key CourseUserNote))) - , StudyFeaturesDescription' , E.SqlExpr (Maybe (Entity SubmissionGroup)) ) -userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do +userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis E.on $ subGroup E.?. SubmissionGroupId E.==. subGroupUser E.?. SubmissionGroupUserSubmissionGroup E.on $ subGroupUser E.?. SubmissionGroupUserUser E.==. E.just (user E.^. UserId) E.&&. subGroup E.?. SubmissionGroupCourse E.==. E.just (E.val cid) - features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser)) E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid)) E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid - return (user, participant, note E.?. CourseUserNoteId, features, subGroup) + return (user, participant, note E.?. CourseUserNoteId, subGroup) type UserTableData = DBRow ( Entity User , Entity CourseParticipant , Maybe CourseUserNoteId - , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) , [Entity Exam] , Maybe (Entity SubmissionGroup) @@ -118,23 +102,17 @@ _userTableRegistration = _userTableParticipant . _entityVal . _courseParticipant _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote = _dbrOutput . _3 -_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) -_userTableFeatures = _dbrOutput . _4 - -_rowUserSemester :: Traversal' UserTableData Int -_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester - _userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial))) -_userTutorials = _dbrOutput . _5 +_userTutorials = _dbrOutput . _4 _userExams :: Lens' UserTableData [Entity Exam] -_userExams = _dbrOutput . _6 +_userExams = _dbrOutput . _5 _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup) -_userSubmissionGroup = _dbrOutput . _7 . _Just +_userSubmissionGroup = _dbrOutput . _6 . _Just _userSheets :: Lens' UserTableData (Map SheetName (SheetType, Maybe Points)) -_userSheets = _dbrOutput . _8 +_userSheets = _dbrOutput . _7 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) @@ -161,26 +139,6 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams) (\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR) (examName . entityVal) -colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $ - foldMap numCell . preview _rowUserSemester - -colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $ - foldMap i18nCell . view (_userTableFeatures . _3) - --- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) --- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $ --- foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3) - --- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) --- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $ --- foldMap i18nCell . preview (_userTableFeatures . _2 . _Just) - -colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) -colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ - foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) - colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSex' = colUserSex $ hasUser . _userSex @@ -216,7 +174,7 @@ data UserTableCsv = UserTableCsv , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe Text , csvUserEmail :: CI Email - , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature) + , csvUserStudyFeatures :: Set UserTableCsvStudyFeature , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime , csvUserNote :: Maybe Html @@ -232,18 +190,11 @@ instance Csv.ToNamedRecord UserTableCsv where , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail - ] ++ case csvUserStudyFeatures of - Left feats - -> [ "field" Csv..= (csvUserField <$> feats) - , "degree" Csv..= (csvUserDegree <$> feats) - , "semester" Csv..= (csvUserSemester <$> feats) - ] - Right feats - -> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..} - -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType - in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|] - in [ "study-features" Csv..= featsStr - ] + ] ++ let featsStr = Text.intercalate "; " . flip map (Set.toList csvUserStudyFeatures) $ \UserTableCsvStudyFeature{..} + -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType + in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|] + in [ "study-features" Csv..= featsStr + ] ++ [ "submission-group" Csv..= csvUserSubmissionGroup ] ++ @@ -270,9 +221,6 @@ instance CsvColumnsExplained UserTableCsv where , single "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail , single "study-features" MsgCsvColumnUserStudyFeatures - , single "field" MsgCsvColumnUserField - , single "degree" MsgCsvColumnUserDegree - , single "semester" MsgCsvColumnUserSemester , single "submission-group" MsgCsvColumnUserSubmissionGroup , single "tutorial" MsgCsvColumnUserTutorial , single "exams" MsgCsvColumnUserExam @@ -284,18 +232,18 @@ instance CsvColumnsExplained UserTableCsv where single k v = singletonMap k [whamlet|_{v}|] data UserCsvExportData = UserCsvExportData - { csvUserSimplifiedFeaturesOfStudy :: Bool - , csvUserIncludeSheets :: Bool + { csvUserIncludeSheets :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default UserCsvExportData where - def = UserCsvExportData True False + def = UserCsvExportData False userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ [ "name" ] ++ [ "sex" | showSex ] ++ [ "matriculation", "email" - ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++ + ] ++ + ["study-features"] ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "exams", "registration" ] ++ @@ -376,7 +324,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do + dbtProj = traverse $ \(user, participant, E.Value userNoteId, subGroup) -> do tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do @@ -395,7 +343,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' - return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup, subs) + return (user, participant, userNoteId, tuts, exs, subGroup, subs) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -404,11 +352,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , sortUserSex (to queryUser . to (E.^. UserSex)) - , single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) - , single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) - , single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) - , single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) , single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date E.subSelectMaybe . E.from $ \edit -> do @@ -450,20 +393,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , single $ fltrUserMatriclenr queryUser , single $ fltrUserNameEmail queryUser , fltrUserSex (to queryUser . to (E.^. UserSex)) - , single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) - , single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) - , single ("field" , FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) - , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) - , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) - ] ) - , single ("degree" , FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) - , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) - , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) - ] ) - , single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial @@ -497,9 +426,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , fltrUserMatriclenrUI mPrev ] ++ [ fltrUserSexUI mPrev | showSex ] ++ - [ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree) - , prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature) - , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup) + [ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) ] ++ @@ -523,44 +450,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do csvColumns' <- csvColumns return $ DBTCsvEncode { dbtCsvExportForm = UserCsvExportData - <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def) - <*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) - , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ + <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) + , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userEmail) - <*> if - | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $ + <*> (do + feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do + E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree + E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField + E.where_ $ feat E.^. StudyFeaturesValid + E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid + return (terms, degree, feat) + return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableCsvStudyFeature - <$> MaybeT (preview $ _userTableFeatures . _3 . _Just . _studyTermsName . _Just - <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow - ) - <*> MaybeT (preview $ _userTableFeatures . _2 . _Just . _studyDegreeName . _Just - <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow - ) - <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester) - <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType) - | otherwise -> Right <$> do - feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do - E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree - E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField - let registered = E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid - E.&&. participant E.^. CourseParticipantUser E.==. E.val uid - E.&&. participant E.^. CourseParticipantField E.==. E.just (feat E.^. StudyFeaturesId) - E.where_ $ registered - E.||. feat E.^. StudyFeaturesValid - E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid - return (terms, degree, feat) - return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> - UserTableCsvStudyFeature - { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName - , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName - , csvUserSemester = studyFeaturesSemester - , csvUserType = studyFeaturesType - } + { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName + , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName + , csvUserSemester = studyFeaturesSemester + , csvUserType = studyFeaturesType + } + ) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> userNote @@ -636,9 +547,6 @@ postCUsersR tid ssh csh = do , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr - , pure . cap' $ colUserDegreeShort - , pure . cap' $ colUserField - , pure . cap' $ colUserSemester , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 912e52054..b59a39977 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -154,7 +154,6 @@ postEAddUserR tid ssh csh examn = do } [ CourseParticipantRegistration =. now , CourseParticipantAllocated =. Nothing - , CourseParticipantField =. courseParticipantField , CourseParticipantState =. CourseParticipantActive ] lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 05703e42a..3b721ec26 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -95,16 +95,13 @@ examRegistrationInvitationConfig = InvitationConfig{..} case (isRegistered, invDBExamRegistrationCourseRegister) of (False, False) -> permissionDeniedI MsgUnauthorizedParticipant - (False, True ) -> do - fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing - return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes - (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) - invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do - whenIsJust mField $ \cpField -> do + (False, True ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, True) + (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, False) + invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} doReg act = do + when doReg $ do void $ upsert - (CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive) + (CourseParticipant examCourse examRegistrationUser examRegistrationTime Nothing CourseParticipantActive) [ CourseParticipantRegistration =. examRegistrationTime - , CourseParticipantField =. cpField , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 9fcf76c04..a5b966ace 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -47,21 +47,13 @@ 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 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 StudyFeatures) - , Maybe (Entity StudyDegree) - , Maybe (Entity StudyTerms) , Maybe (Entity ExamBonus) , Maybe (Entity ExamResult) , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) @@ -87,16 +79,7 @@ queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurre 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) +queryCourseParticipant = $(sqlLOJproj 6 3) queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus)) queryExamBonus = $(sqlLOJproj 6 4) @@ -130,38 +113,29 @@ 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 +resultExamBonus = _dbrOutput . _4 . _Just resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) -resultExamResult = _dbrOutput . _8 . _Just +resultExamResult = _dbrOutput . _5 . _Just resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) -resultExamParts = _dbrOutput . _9 . itraversed +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 . _9 . unsafeSingular (ix epId) . _2 +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 . _10 . _Just +resultCourseNote = _dbrOutput . _7 . _Just resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points @@ -191,9 +165,6 @@ data ExamUserTableCsv = ExamUserTableCsv , 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) @@ -213,9 +184,6 @@ instance ToNamedRecord ExamUserTableCsv where , "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 @@ -240,9 +208,6 @@ instance FromNamedRecord ExamUserTableCsv where <*> 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") @@ -263,9 +228,6 @@ instance CsvColumnsExplained ExamUserTableCsv where , 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 @@ -287,7 +249,6 @@ examUserTableCsvHeader :: ( MonoFoldable mono 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) @@ -329,7 +290,6 @@ data ExamUserCsvActionClass = ExamUserCsvCourseRegister | ExamUserCsvRegister | ExamUserCsvAssignOccurrence - | ExamUserCsvSetCourseField | ExamUserCsvSetPartResult | ExamUserCsvSetBonus | ExamUserCsvOverrideBonus @@ -343,7 +303,6 @@ embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id data ExamUserCsvAction = ExamUserCsvCourseRegisterData { examUserCsvActUser :: UserId - , examUserCsvActCourseField :: Maybe StudyFeaturesId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } | ExamUserCsvRegisterData @@ -354,10 +313,6 @@ data ExamUserCsvAction { examUserCsvActRegistration :: ExamRegistrationId , examUserCsvActOccurrence :: Maybe ExamOccurrenceId } - | ExamUserCsvSetCourseFieldData - { examUserCsvActCourseParticipant :: CourseParticipantId - , examUserCsvActCourseField :: Maybe StudyFeaturesId - } | ExamUserCsvDeregisterData { examUserCsvActRegistration :: ExamRegistrationId } @@ -453,9 +408,6 @@ postEUsersR tid ssh csh examn = do 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 @@ -467,9 +419,6 @@ postEUsersR tid ssh csh examn = do 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) @@ -479,13 +428,13 @@ postEUsersR tid ssh csh examn = do E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote) + return (examRegistration, user, occurrence, 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 + (,,,,,,) + <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> getExamParts - <*> view _9 + <*> view _6 where getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) getExamParts = do @@ -504,9 +453,6 @@ postEUsersR tid ssh csh examn = do [ 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 @@ -528,9 +474,6 @@ postEUsersR tid ssh csh examn = do 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 @@ -546,18 +489,12 @@ postEUsersR tid ssh csh examn = do 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 ] @@ -627,9 +564,6 @@ postEUsersR tid ssh csh examn = do <*> 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) @@ -650,15 +584,8 @@ postEUsersR tid ssh csh examn = do -> 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 + unless isPart $ + yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> when (epNumber `elem` examPartNumbers) $ @@ -679,11 +606,6 @@ postEUsersR tid ssh csh examn = do 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 -> @@ -742,7 +664,6 @@ postEUsersR tid ssh csh examn = do ExamUserCsvRegisterData{} -> ExamUserCsvRegister ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence - ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult ExamUserCsvSetBonusData{..} | examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus @@ -765,12 +686,10 @@ postEUsersR tid ssh csh examn = do { courseParticipantCourse = examCourse , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now - , courseParticipantField = examUserCsvActCourseField , courseParticipantAllocated = Nothing , courseParticipantState = CourseParticipantActive } [ CourseParticipantRegistration =. now - , CourseParticipantField =. examUserCsvActCourseField , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] @@ -794,10 +713,6 @@ postEUsersR tid ssh csh examn = do 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 @@ -864,10 +779,6 @@ postEUsersR tid ssh csh examn = do [whamlet| $newline never ^{nameWidget userDisplayName userSurname} - $maybe features <- examUserCsvActCourseField - , ^{studyFeaturesWidget features} - $nothing - , _{MsgCourseStudyFeatureNone} $maybe ExamOccurrence{examOccurrenceName} <- occ \ (#{examOccurrenceName}) $nothing @@ -893,16 +804,6 @@ postEUsersR tid ssh csh examn = do $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 @@ -990,56 +891,6 @@ postEUsersR tid ssh csh examn = do [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 diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index e5be277ea..209da69f2 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -68,18 +68,10 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration)) `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 CourseParticipant)) type ExamUserTableData = DBRow ( Entity ExamResult , Entity User , Maybe (Entity ExamOccurrence) - , Maybe (Entity StudyFeatures) - , Maybe (Entity StudyDegree) - , Maybe (Entity StudyTerms) , Maybe (Entity ExamRegistration) , Bool , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] @@ -95,16 +87,7 @@ queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOc queryExamOccurrence = to $(E.sqlLOJproj 4 3) queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant))) -queryCourseParticipant = to $ $(E.sqlLOJproj 2 1) . $(E.sqlLOJproj 4 4) - -queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) -queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4) - -queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) -queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4) - -queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) -queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4) +queryCourseParticipant = to $(E.sqlLOJproj 4 4) queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult)) queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1) @@ -118,15 +101,6 @@ queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult 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 @@ -134,19 +108,16 @@ resultExamResult :: Lens' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _1 resultIsSynced :: Lens' ExamUserTableData Bool -resultIsSynced = _dbrOutput . _8 +resultIsSynced = _dbrOutput . _5 resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand) -resultSynchronised = _dbrOutput . _9 . traverse +resultSynchronised = _dbrOutput . _6 . traverse data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Text , csvEUserFirstName :: Text , csvEUserName :: Text , csvEUserMatriculation :: Maybe Text - , csvEUserField :: Maybe Text - , csvEUserDegree :: Maybe Text - , csvEUserSemester :: Maybe Int , csvEUserOccurrenceStart :: Maybe ZonedTime , csvEUserExamResult :: ExamResultPassedGrade } @@ -168,9 +139,6 @@ instance CsvColumnsExplained ExamUserTableCsv where , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) , ('csvEUserName , MsgCsvColumnExamUserName ) , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) , ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart ) , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) ] @@ -249,16 +217,10 @@ postEGradesR tid ssh csh examn = do examRegistration <- view queryExamRegistration occurrence <- view queryExamOccurrence courseParticipant <- view queryCourseParticipant - studyFeatures <- view queryStudyFeatures - studyDegree <- view queryStudyDegree - studyField <- view queryStudyField isSynced <- view . queryIsSynced $ E.val uid lift $ do - 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) @@ -274,13 +236,13 @@ postEGradesR tid ssh csh examn = do unless isLecturer $ E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult - return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced) + return (examResult, user, occurrence, examRegistration, isSynced) dbtRowKey = views queryExamResult (E.^. ExamResultId) dbtProj :: DBRow _ -> DB ExamUserTableData dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ - (,,,,,,,,) - <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value) + (,,,,,) + <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value) <*> getSynchronised where getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] @@ -335,9 +297,6 @@ postEGradesR tid ssh csh examn = do , colSynced , imapColonnade participantAnchor . anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) - , emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms - , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree - , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester , Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just @@ -347,9 +306,6 @@ postEGradesR tid ssh csh examn = do dbtSorting = mconcat [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname))) , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) - , sortStudyTerms queryStudyField - , sortStudyDegree queryStudyDegree - , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester)) , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart))) , maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult)) , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid) @@ -357,18 +313,12 @@ postEGradesR tid ssh csh examn = do dbtFilter = mconcat [ fltrUserName' (queryUser . to (E.^. UserDisplayName)) , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) - , fltrStudyTerms queryStudyField - , fltrStudyDegree queryStudyDegree - , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester)) , fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just) , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid) ] dbtFilterUI = mconcat [ fltrUserNameUI' , fltrUserMatriculationUI - , fltrStudyTermsUI - , fltrStudyDegreeUI - , fltrStudyFeaturesSemesterUI , fltrExamResultPointsUI , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised) ] @@ -405,9 +355,6 @@ postEGradesR tid ssh csh examn = do (row ^. resultUser . _entityVal . _userFirstName) (row ^. resultUser . _entityVal . _userDisplayName) (row ^. resultUser . _entityVal . _userMatrikelnummer) - (row ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand)) - (row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand)) - (row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester) (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime) (row ^. resultExamResult . _entityVal . _examResultResult) , dbtCsvName = unpack csvName diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 90a0cb1d2..6e7c9184f 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -41,9 +41,6 @@ postTUsersR tid ssh csh tutn = do , guardOn showSex colUserSex' , pure colUserEmail , pure colUserMatriclenr - , pure colUserDegreeShort - , pure colUserField - , pure colUserSemester ] psValidator = def & defaultSortingByName @@ -51,7 +48,7 @@ postTUsersR tid ssh csh tutn = do isInTut q = E.exists . E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid - csvColChoices = flip elem ["name", "matriculation", "email", "field", "degree", "semester", "study-features"] + csvColChoices = flip elem ["name", "matriculation", "email", "study-features"] cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator (Just csvColChoices) diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index be5ef5a57..510e9fc70 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -244,11 +244,9 @@ doAllocation :: AllocationId -> DB () doAllocation allocId now regs = forM_ regs $ \(uid, cid) -> do - mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] void $ upsert - (CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive) + (CourseParticipant cid uid now (Just allocId) CourseParticipantActive) [ CourseParticipantRegistration =. now - , CourseParticipantField =. mField , CourseParticipantAllocated =. Just allocId , CourseParticipantState =. CourseParticipantActive ] diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet index 2b375a22d..7fb7dee81 100644 --- a/templates/course/user/profile.hamlet +++ b/templates/course/user/profile.hamlet @@ -56,6 +56,3 @@ $newline never ^{formatTimeRangeW SelFormatDate fObs $ Just studyFeaturesLastObserved} $nothing ^{formatTimeW SelFormatDate studyFeaturesLastObserved} - $maybe _ <- mRegistration -
_{MsgCourseStudyFeature} -
^{regFieldWidget} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b1a49ec07..1543441d8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -473,58 +473,64 @@ fillDb = do void . insert $ StudyTermNameCandidate incidence12 21 "Deutsch" void . insert $ StudyTermNameCandidate incidence12 21 "Betriebswirtschaftslehre" - sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here + insert_ $ StudyFeatures -- keyword type prevents record syntax here maxMuster sdBsc sdInf Nothing FieldPrimary 2 + (Just now) now True - sfMMs <- insert $ StudyFeatures + insert_ $ StudyFeatures maxMuster sdBsc sdMath Nothing FieldSecondary 2 + (Just now) now True - _sfTTa <- insert $ StudyFeatures + insert_ $ StudyFeatures tinaTester sdBsc sdInf Nothing FieldPrimary 4 + (Just now) now False - sfTTb <- insert $ StudyFeatures + insert_ $ StudyFeatures tinaTester sdLAG sdPhys Nothing FieldPrimary 1 + (Just now) now True - sfTTc <- insert $ StudyFeatures + insert_ $ StudyFeatures tinaTester sdLAR sdMedi Nothing FieldPrimary 7 + (Just now) now True - _sfTTd <- insert $ StudyFeatures + insert_ $ StudyFeatures tinaTester sdMst sdMath Nothing FieldPrimary 3 + (Just now) now True @@ -626,10 +632,10 @@ fillDb = do , sheetAllowNonPersonalisedSubmission = True } insert_ $ SheetEdit gkleen now keine - void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing CourseParticipantActive) - [(fhamann , Nothing) - ,(maxMuster , Just sfMMs) - ,(tinaTester, Just sfTTc) + void . insertMany $ map (\u -> CourseParticipant ffp u now Nothing CourseParticipantActive) + [ fhamann + , maxMuster + , tinaTester ] examFFP <- insert' $ Exam @@ -762,10 +768,10 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo CourseAssistant - void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing CourseParticipantActive) - [(fhamann , Nothing) - ,(maxMuster , Just sfMMp) - ,(tinaTester, Just sfTTb) + void . insertMany $ map (\u -> CourseParticipant pmo u now Nothing CourseParticipantActive) + [ fhamann + , maxMuster + , tinaTester ] let shTypes = NotGraded : [ shType g | g <- shGradings, shType <- [ Normal, Bonus, Informational ] ] @@ -1032,7 +1038,7 @@ fillDb = do insert_ $ AllocationCourse funAlloc pmo 100 insert_ $ AllocationCourse funAlloc ffp 2 - void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now Nothing (Just funAlloc) pState) + void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState) [ (svaupel, CourseParticipantInactive False) , (jost, CourseParticipantActive) ] @@ -1066,7 +1072,7 @@ fillDb = do void . insert' $ Lecturer gkleen bs CourseLecturer void . insertMany $ do uid <- take 1024 manyUsers - return $ CourseParticipant bs uid now Nothing Nothing CourseParticipantActive + return $ CourseParticipant bs uid now Nothing CourseParticipantActive forM_ [1..14] $ \shNr -> do shId <- insert Sheet { sheetCourse = bs @@ -1141,7 +1147,7 @@ fillDb = do participants <- getRandomR (0, 50) manyUsers' <- shuffleM $ take 1024 manyUsers forM_ (take participants manyUsers') $ \uid -> - void . insertUnique $ CourseParticipant cid uid now Nothing Nothing CourseParticipantActive + void . insertUnique $ CourseParticipant cid uid now Nothing CourseParticipantActive aSeedBig <- liftIO $ getRandomBytes 40 bigAlloc <- insert' Allocation @@ -1223,7 +1229,6 @@ fillDb = do void $ insert CourseApplication { courseApplicationCourse = cid , courseApplicationUser = uid - , courseApplicationField = Nothing , courseApplicationText = Nothing , courseApplicationRatingVeto = maybe False (view _1) rating , courseApplicationRatingPoints = view _2 <$> rating