From dcb83d96fc0e52c0c322e50d9467d9a2bed90359 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 25 Aug 2020 12:27:40 +0200 Subject: [PATCH 01/48] feat(study-features): add study-features-first-observed --- models/users.model | 5 +++-- src/Foundation/Yesod/Auth.hs | 27 ++++++--------------------- src/Handler/Utils/StudyFeatures.hs | 4 +++- src/Model/Migration.hs | 8 ++++++++ templates/course/user/profile.hamlet | 8 ++++++-- templates/profileData.hamlet | 8 ++++++-- 6 files changed, 32 insertions(+), 28 deletions(-) diff --git a/models/users.model b/models/users.model index 657669910..740de8186 100644 --- a/models/users.model +++ b/models/users.model @@ -58,8 +58,9 @@ StudyFeatures -- multiple entries possible for students pursuing several degree superField StudyTermsId Maybe type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach semester Int - updated UTCTime default=now() -- last update from LDAP - valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets) + firstObserved UTCTime Maybe + lastObserved UTCTime default=now() -- last update from LDAP + valid Bool default=true UniqueStudyFeatures user degree field type semester deriving Eq Show -- UniqueUserSubject ubuser degree field -- There exists a counterexample diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 66941c9f6..8be3e80b9 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -321,7 +321,7 @@ upsertCampusUser plugin ldapData = do , Just defType <- studyTermsDefaultType -> do $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|] - (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats + (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester (Just now) now True) <$> assimilateSubTerms subterms unusedFeats Nothing | [] <- unusedFeats -> do $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] @@ -389,26 +389,11 @@ upsertCampusUser plugin ldapData = do forM_ fs $ \f@StudyFeatures{..} -> do insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing - oldFs <- selectKeysList - [ StudyFeaturesUser ==. studyFeaturesUser - , StudyFeaturesDegree ==. studyFeaturesDegree - , StudyFeaturesField ==. studyFeaturesField - , StudyFeaturesType ==. studyFeaturesType - , StudyFeaturesSemester ==. studyFeaturesSemester - ] - [] - case oldFs of - [oldF] -> update oldF - [ StudyFeaturesUpdated =. now - , StudyFeaturesValid =. True - , StudyFeaturesField =. studyFeaturesField - , StudyFeaturesSuperField =. studyFeaturesSuperField - ] - _other -> void $ upsert f - [ StudyFeaturesUpdated =. now - , StudyFeaturesValid =. True - , StudyFeaturesSuperField =. studyFeaturesSuperField - ] + void $ upsert f + [ StudyFeaturesLastObserved =. now + , StudyFeaturesValid =. True + , StudyFeaturesSuperField =. studyFeaturesSuperField + ] associateUserSchoolsByTerms userId let diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 52d59082f..80d7d1681 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -24,7 +24,7 @@ parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] -pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do +pStudyFeatures studyFeaturesUser now = do studyFeaturesDegree <- StudyDegreeKey' <$> pKey void $ string "$$" @@ -41,6 +41,8 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do studyFeaturesSemester <- decimal let studyFeaturesValid = True studyFeaturesSuperField = Nothing + studyFeaturesFirstObserved = Just now + studyFeaturesLastObserved = now return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 5ebd46b6f..6b74de437 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -913,6 +913,14 @@ customMigrations = Map.fromListWith (>>) insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationUnratedApplications{..}, .. } ) + , ( AppliedMigrationKey [migrationVersion|39.0.0|] [version|40.0.0|] + , whenM (tableExists "study_features") $ do + [executeQQ| + ALTER TABLE study_features RENAME updated TO last_observed; + ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone; + UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1); + |] + ) ] diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet index 20b3417e0..2b375a22d 100644 --- a/templates/course/user/profile.hamlet +++ b/templates/course/user/profile.hamlet @@ -44,14 +44,18 @@ $newline never _{MsgStudyFeatureAge} _{MsgStudyFeatureValid} _{MsgStudyFeatureUpdate} - $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies + $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesFirstObserved, studyFeaturesLastObserved}), (Entity _ degree), (Entity _ field)) <- studies _{field} _{degree} _{studyFeaturesType} #{studyFeaturesSemester} #{hasTickmark studyFeaturesValid} - ^{formatTimeW SelFormatDate studyFeaturesUpdated} + + $maybe fObs <- studyFeaturesFirstObserved + ^{formatTimeRangeW SelFormatDate fObs $ Just studyFeaturesLastObserved} + $nothing + ^{formatTimeW SelFormatDate studyFeaturesLastObserved} $maybe _ <- mRegistration
_{MsgCourseStudyFeature}
^{regFieldWidget} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index fe327abe3..231082dbc 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -43,14 +43,18 @@ $newline never _{MsgStudyFeatureValid} _{MsgStudyFeatureUpdate} - $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies + $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesFirstObserved, studyFeaturesLastObserved}), (Entity _ degree), (Entity _ field)) <- studies _{field} _{degree} _{studyFeaturesType} #{studyFeaturesSemester} #{hasTickmark studyFeaturesValid} - ^{formatTimeW SelFormatDateTime studyFeaturesUpdated} + + $maybe fObs <- studyFeaturesFirstObserved + ^{formatTimeRangeW SelFormatDateTime fObs $ Just studyFeaturesLastObserved} + $nothing + ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
$if hasRows From 4f9a4f7f44fcf6fa004657afc212e5562972d017 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 25 Aug 2020 14:27:58 +0200 Subject: [PATCH 02/48] 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 From 06375f8cd8608ce2bddb4d56debe39e75486f7e8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 13:29:03 +0200 Subject: [PATCH 03/48] style(dbtable): add rowspan to number column header --- src/Handler/Utils/Table/Pagination.hs | 32 ++++++++++++++++----------- templates/table/header.hamlet | 5 +++-- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index ce1767303..c0ad787ca 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -74,7 +74,6 @@ import Control.Monad.State (evalStateT, execStateT) import Control.Monad.Trans.Maybe import Control.Monad.State.Class (modify) import qualified Control.Monad.State.Class as State -import Control.Monad.Trans.Writer.Lazy (censor) import Data.Map ((!)) import qualified Data.Map as Map @@ -1277,22 +1276,22 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db _other -> False genHeaders :: forall h. Cornice h _ _ (DBCell m x) -> SortableP h -> WriterT x m Widget - genHeaders cornice SortableP{..} = execWriterT . go mempty $ annotate cornice + genHeaders cornice SortableP{..} = fmap wrap' . execWriterT . go mempty $ annotate cornice where go :: forall (p' :: Pillar) r'. [(Int, Int, Int)] -> AnnotatedCornice (Maybe Int) h p' r' (DBCell m x) - -> WriterT Widget (WriterT x m) () - go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = censor wrap . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do + -> WriterT (Seq (Seq (Widget, Int))) (WriterT x m) () + go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = mapWriterT (over (mapped . _2) pure) . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do let (_, cellSize') = compCellSize rowspanAcc (map oneColonnadeHead before) Sized{..} - whenIsJust cellSize' $ \cellSize -> tellM $ fromContent Sized { sizedSize = cellSize, sizedContent } + whenIsJust cellSize' $ \cellSize -> tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent } go rowspanAcc (AnnotatedCorniceCap _ v@(toList -> oneCornices)) = do - rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (censor wrap) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do + rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (mapWriterT $ over (mapped . _2) pure) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do let sz = Sized sz' h let (beforeSize, cellSize') = compCellSize rowspanAcc (concatMap (map oneColonnadeHead . toList . getColonnade . uncapAnnotated . oneCorniceBody) before) sz whenIsJust cellSize' $ \cellSize -> do let Sized{..} = sz - lift . tellM $ fromContent Sized { sizedSize = cellSize, sizedContent } + lift . tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent } if | [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) (toSortable sizedContent ^. _sortableContent . cellAttrs) -> State.modify $ (:) (n, beforeSize, cellSize) | otherwise -> return () @@ -1309,11 +1308,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db guard $ beforeSize < firstCol + sz return . Sum $ sz - (beforeSize - firstCol) - wrap :: Widget -> Widget - wrap row = case dbsTemplate of + wrap' :: Seq (Seq (Widget, Int)) -> Widget + wrap' wRows = view _2 $ Foldable.foldl (\(stackHeight', acc) row -> (Nothing, (acc <>) . wrap stackHeight' $ foldOf (folded . _1) row)) (stackHeight, mempty) wRows + where stackHeight = maximumOf (folded . to (ala Sum foldMap . fmap (view _2))) wRows + wrap :: Maybe Int -> Widget -> Widget + wrap stackHeight row = case dbsTemplate of DBSTCourse{} -> row DBSTDefault{} -> $(widgetFile "table/header") - fromContent :: Sized Int h (DBCell m x) -> WriterT x m Widget + fromContent :: Sized Int h (DBCell m x) -> WriterT x m (Widget, Int) fromContent Sized{ sizedSize = cellSize, sizedContent = toSortable -> Sortable{..} } = do widget <- sortableContent ^. cellContents let @@ -1322,9 +1324,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db isSorted dir = fromMaybe False $ (==) <$> (SortingSetting <$> sortableKey <*> pure dir) <*> listToMaybe psSorting attrs = sortableContent ^. cellAttrs piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ] - case dbsTemplate of - DBSTCourse{} -> return $(widgetFile "table/course/header") - DBSTDefault{} -> return $(widgetFile "table/cell/header") + rowspan = preview _head $ do + (key, val) <- attrs + guard $ is _Rowspan key + hoistMaybe $ readMay val + return . (, fromMaybe 1 rowspan) $ case dbsTemplate of + DBSTCourse{} -> $(widgetFile "table/course/header") + DBSTDefault{} -> $(widgetFile "table/cell/header") in do wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable now <- liftIO getCurrentTime diff --git a/templates/table/header.hamlet b/templates/table/header.hamlet index 200126344..c2882f1b3 100644 --- a/templates/table/header.hamlet +++ b/templates/table/header.hamlet @@ -1,6 +1,7 @@ $newline never - $if numberColumn - + $maybe rowspan <- stackHeight + $if numberColumn + $# cell/header.hamlet ^{row} From f8ec31eaa868c00427d66f8c770fb20d849396fa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 13:42:46 +0200 Subject: [PATCH 04/48] chore(release): 19.2.1 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 452d377d4..595777f14 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [19.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.0...v19.2.1) (2020-08-26) + + +### Bug Fixes + +* improve hidecolumns behaviour ([9a4f30b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9a4f30b811fdf8c58ec5c50c185628eb3158931a)) + ## [19.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.1.5...v19.2.0) (2020-08-24) diff --git a/package-lock.json b/package-lock.json index 756462fda..cc7596947 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "19.2.0", + "version": "19.2.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2b75424df..6567585ed 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "19.2.0", + "version": "19.2.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 513b569a9..f7811ab83 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 19.2.0 +version: 19.2.1 dependencies: - base From 24f428b13bb181bec99417b4e69fc538e35acbcf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 16:03:54 +0200 Subject: [PATCH 05/48] fix: have exam deregistration always delete stored grades --- src/Handler/Course/Register.hs | 6 +++--- src/Handler/Exam/Show.hs | 4 +++- src/Handler/Exam/Users.hs | 18 ++++++------------ src/Handler/Utils/Exam.hs | 32 ++++++++++++++++++++++++++++++++ templates/exam-show.hamlet | 4 ++-- 5 files changed, 46 insertions(+), 18 deletions(-) diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index e0cd7f593..08f3c1503 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -9,6 +9,7 @@ module Handler.Course.Register import Import import Handler.Utils +import Handler.Utils.Exam import Utils.Course @@ -297,9 +298,8 @@ deregisterParticipant uid cid = do E.where_ $ exam E.^. ExamCourse E.==. E.val cid E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid return examRegistration - forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do - delete erId - audit $ TransactionExamDeregister examRegistrationExam uid + forM_ examRegistrations $ \(Entity _ ExamRegistration{..}) -> do + deregisterExamUsers examRegistrationExam $ pure examRegistrationUser E.delete . E.from $ \tutorialParticipant -> do let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse) diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index e8b306d85..e206bc17b 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -124,6 +124,7 @@ getEShowR tid ssh csh examn = do , mayRegister' (entityKey <$> mOcc) = Just $ do (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered [whamlet| + $newline never

$if isRegistered _{MsgExamRegistered} @@ -147,11 +148,12 @@ getEShowR tid ssh csh examn = do } | is _Nothing mOcc , is _Nothing registered - = Just [whamlet|_{MsgExamLoginToRegister}|] + = Just $ i18n MsgExamLoginToRegister | is _Nothing mOcc , isRegistered <- is _Just $ join registered = Just [whamlet| + $newline never

$if isRegistered _{MsgExamRegistered} diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 9fcf76c04..23b296d64 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -36,7 +36,7 @@ import qualified Data.CaseInsensitive as CI import Numeric.Lens (integral) -import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Database.Persist.Sql (updateWhereCount) import Control.Lens.Indexed ((<.), (.>)) @@ -840,13 +840,8 @@ postEUsersR tid ssh csh examn = do ] audit $ TransactionExamResultEdit eid examUserCsvActUser ExamUserCsvDeregisterData{..} -> do - ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration - audit $ TransactionExamDeregister eid examRegistrationUser - delete examUserCsvActRegistration - result <- getBy $ UniqueExamResult eid examRegistrationUser - forM_ result $ \(Entity erId _) -> do - delete erId - audit $ TransactionExamResultDeleted eid examRegistrationUser + ExamRegistration{..} <- getJust examUserCsvActRegistration + deregisterExamUsers examRegistrationExam $ pure examRegistrationUser ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse whenIsJust noteId $ \nid -> do @@ -1051,10 +1046,9 @@ postEUsersR tid ssh csh examn = do (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case - (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do - nrDel <- runDB $ deleteWhereCount - [ ExamRegistrationId <-. Set.toList selectedRegistrations - ] + (ExamUserDeregisterData, Map.elems -> selectedRegistrations) -> do + nrDel <- runDB . setSerializable . deregisterExamUsersCount eId $ map (view $ resultUser . _entityKey) selectedRegistrations + addMessageI Success $ MsgExamUsersDeregistered nrDel redirect $ CExamR tid ssh csh examn EUsersR (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index e192dc688..54632cde6 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -10,6 +10,7 @@ module Handler.Utils.Exam , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize , examAutoOccurrence + , deregisterExamUsersCount, deregisterExamUsers ) where import Import @@ -609,3 +610,34 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res | otherwise = res + + +deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64 +deregisterExamUsersCount eId uids = do + partResults <- E.select . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do + E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart + E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId + E.&&. examPartResult E.^. ExamPartResultUser `E.in_` E.valList uids + return examPartResult + forM_ partResults $ \(Entity resId ExamPartResult{..}) -> do + delete resId + audit $ TransactionExamPartResultDeleted examPartResultExamPart examPartResultUser + + results <- selectList [ ExamResultExam ==. eId, ExamResultUser <-. uids ] [] + forM_ results $ \(Entity resId ExamResult{..}) -> do + delete resId + audit $ TransactionExamResultDeleted examResultExam examResultUser + + boni <- selectList [ ExamBonusExam ==. eId, ExamBonusUser <-. uids ] [] + forM_ boni $ \(Entity bonusId ExamBonus{..}) -> do + delete bonusId + audit $ TransactionExamBonusDeleted examBonusExam examBonusUser + + regs <- selectList [ ExamRegistrationExam ==. eId, ExamRegistrationUser <-. uids ] [] + fmap (ala Sum foldMap) . forM regs $ \(Entity regId ExamRegistration{..}) -> do + delete regId + audit $ TransactionExamDeregister examRegistrationExam examRegistrationUser + return 1 + +deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m () +deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index efb7f534d..176cf01fd 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -87,8 +87,8 @@ $maybe desc <- examDescription $maybe registerWdgt <- registerWidget Nothing

_{MsgExamRegistration} - \ ^{isVisible False} -
^{registerWdgt} +
+ ^{registerWdgt} $if showCloseWidget && is _Nothing examClosed
From ff759518b729ba85cd8127a5079c1fba962aab26 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 16:43:51 +0200 Subject: [PATCH 06/48] chore(release): 19.2.2 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 595777f14..71ffcc931 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +### [19.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.1...v19.2.2) (2020-08-26) + + +### Bug Fixes + +* have exam deregistration always delete stored grades ([24f428b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/24f428b13bb181bec99417b4e69fc538e35acbcf)) + ### [19.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v19.2.0...v19.2.1) (2020-08-26) diff --git a/package-lock.json b/package-lock.json index cc7596947..220155f3f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "19.2.1", + "version": "19.2.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 6567585ed..06e071f99 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "19.2.1", + "version": "19.2.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f7811ab83..b060e394e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 19.2.1 +version: 19.2.2 dependencies: - base From f7a9bc831a3b0ef58fcbf7918be9f5e3b262641e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 20:54:21 +0200 Subject: [PATCH 07/48] feat(study-features): further restriction by course --- src/Database/Esqueleto/Utils.hs | 5 + src/Handler/Course/User.hs | 8 +- src/Handler/Course/Users.hs | 49 ++---- src/Handler/Exam/AddUser.hs | 15 +- src/Handler/Utils/ExamOffice/Exam.hs | 16 +- src/Handler/Utils/ExamOffice/ExternalExam.hs | 5 +- src/Handler/Utils/StudyFeatures.hs | 150 ++++++++++++------- src/Handler/Utils/StudyFeatures/Parse.hs | 70 +++++++++ src/Model/Types/Misc.hs | 7 +- 9 files changed, 209 insertions(+), 116 deletions(-) create mode 100644 src/Handler/Utils/StudyFeatures/Parse.hs diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index b31708c48..e633cd1b1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -26,6 +26,7 @@ module Database.Esqueleto.Utils , fromSqlKey , selectCountRows , selectMaybe + , day , module Database.Esqueleto.Utils.TH ) where @@ -325,3 +326,7 @@ selectCountRows q = do selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) + + +day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) +day = E.unsafeSqlCastAs "date" diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 6ec813d2a..211b9b524 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -22,6 +22,8 @@ import Jobs.Queue import Handler.Submission.List +import Handler.Utils.StudyFeatures + import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -93,10 +95,12 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = (mRegistration, studies) <- lift . runDB $ do registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + studies <- E.select $ E.from $ \(course `E.InnerJoin` studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do + E.on $ isCourseStudyFeature course studyfeat E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + E.where_ $ course E.^. CourseId E.==. E.val cid return (studyfeat, studydegree, studyterms) return (registration, studies) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 0df3cf49b..a948e0bef 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -16,6 +16,7 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) +import Handler.Utils.StudyFeatures import qualified Data.Set as Set import qualified Data.Map as Map @@ -85,6 +86,7 @@ type UserTableData = DBRow ( Entity User , [Entity Exam] , Maybe (Entity SubmissionGroup) , Map SheetName (SheetType, Maybe Points) + , UserTableStudyFeatures ) instance HasEntity UserTableData User where @@ -114,6 +116,9 @@ _userSubmissionGroup = _dbrOutput . _6 . _Just _userSheets :: Lens' UserTableData (Map SheetName (SheetType, Maybe Points)) _userSheets = _dbrOutput . _7 +_userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures +_userStudyFeatures = _dbrOutput . _8 + colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = @@ -161,20 +166,12 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns _other -> mempty -data UserTableCsvStudyFeature = UserTableCsvStudyFeature - { csvUserField :: Text - , csvUserDegree :: Text - , csvUserSemester :: Int - , csvUserType :: StudyFieldType - } deriving (Eq, Ord, Read, Show, Generic, Typeable) -makeLenses_ ''UserTableCsvStudyFeature - data UserTableCsv = UserTableCsv { csvUserName :: Text , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe Text , csvUserEmail :: CI Email - , csvUserStudyFeatures :: Set UserTableCsvStudyFeature + , csvUserStudyFeatures :: UserTableStudyFeatures , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime , csvUserNote :: Maybe Html @@ -190,13 +187,8 @@ instance Csv.ToNamedRecord UserTableCsv where , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation , "email" Csv..= csvUserEmail - ] ++ 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 + , "study-features" Csv..= csvUserStudyFeatures + , "submission-group" Csv..= csvUserSubmissionGroup ] ++ [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1 in "tutorial" Csv..= tutsStr @@ -241,9 +233,7 @@ userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExpo userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ [ "name" ] ++ [ "sex" | showSex ] ++ - [ "matriculation", "email" - ] ++ - ["study-features"] ++ + [ "matriculation", "email", "study-features"] ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "exams", "registration" ] ++ @@ -337,13 +327,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , submission ) ) + feats <- courseUserStudyFeatures (participant ^. _entityVal . _courseParticipantCourse) (participant ^. _entityVal . _courseParticipantUser) let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials 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, tuts, exs, subGroup, subs) + return (user, participant, userNoteId, tuts, exs, subGroup, subs, feats) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -451,27 +442,13 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do return $ DBTCsvEncode { dbtCsvExportForm = UserCsvExportData <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) - , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ + , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userEmail) - <*> (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 - { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName - , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName - , csvUserSemester = studyFeaturesSemester - , csvUserType = studyFeaturesType - } - ) + <*> view _userStudyFeatures <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> userNote diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index b59a39977..a833073f6 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -22,7 +22,6 @@ import Generics.Deriving.Monoid data AddRecipientsResult = AddRecipientsResult { aurAlreadyRegistered - , aurNoUniquePrimaryField , aurNoCourseRegistration , aurSuccess , aurSuccessCourse :: [UserEmail] @@ -101,11 +100,6 @@ postEAddUserR tid ssh csh examn = do unless (null aurSuccess) $ tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess - unless (null aurNoUniquePrimaryField) $ do - let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|] - modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - unless (null aurNoCourseRegistration) $ do let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|] modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse") @@ -137,11 +131,6 @@ postEAddUserR tid ssh csh examn = do guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True) - features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] - - let courseParticipantField - | [f] <- features = Just f - | otherwise = Nothing lift . lift . void $ upsert CourseParticipant @@ -160,8 +149,6 @@ postEAddUserR tid ssh csh examn = do lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid lift $ lift examRegister - return $ case courseParticipantField of - Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } - Just _ -> mempty { aurSuccessCourse = pure userEmail } + return $ mempty { aurSuccessCourse = pure userEmail } diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index 2a21e24c7..272a9771f 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -5,6 +5,8 @@ module Handler.Utils.ExamOffice.Exam import Import.NoFoundation +import Handler.Utils.StudyFeatures + import qualified Database.Esqueleto as E resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office @@ -33,7 +35,9 @@ examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (E.Value Bool) examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool where - authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do + authByField = E.exists . E.from $ \(course `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ isCourseStudyFeature course studyFeatures + E.&&. course E.^. CourseId E.==. E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. examResult E.^. ExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId @@ -42,12 +46,10 @@ examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. E.||. E.exists (E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. authId E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice - E.&&. E.not_ (E.exists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` courseUserExamOfficeOptOut) -> do - E.on $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam - E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser - E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool + E.&&. E.not_ (E.exists . E.from $ \courseUserExamOfficeOptOut -> + E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId + E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser + E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool ) ) diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index 9dcac4d84..c509516a4 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -4,6 +4,7 @@ module Handler.Utils.ExamOffice.ExternalExam ) where import Import.NoFoundation +import Handler.Utils.StudyFeatures import qualified Database.Esqueleto as E @@ -34,7 +35,9 @@ examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (E.Value Bool) examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool where - authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do + authByField = E.exists . E.from $ \(externalExam `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ isExternalExamStudyFeature externalExam studyFeatures + E.&&. externalExam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. eexamResult E.^. ExternalExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 80d7d1681..10dffa21e 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -1,70 +1,112 @@ module Handler.Utils.StudyFeatures - ( parseStudyFeatures - , parseSubTermsSemester + ( module Handler.Utils.StudyFeatures.Parse + , UserTableStudyFeature(..) + , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType + , UserTableStudyFeatures(..) + , isCourseStudyFeature, courseUserStudyFeatures + , isExternalExamStudyFeature, externalExamUserStudyFeatures ) where -import Import.NoFoundation hiding (try, (<|>)) +import Import.NoFoundation +import Foundation.Type +import Foundation.I18n -import Text.Parsec -import Text.Parsec.Text +import Handler.Utils.StudyFeatures.Parse -import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures) -import qualified Ldap.Client as Ldap +import qualified Data.Csv as Csv + +import qualified Data.ByteString as ByteString + +import qualified Data.Set as Set + +import Data.RFC5051 (compareUnicode) + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E -parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures] -parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key) - where - Ldap.Attr key = ldapUserStudyFeatures +data UserTableStudyFeature = UserTableStudyFeature + { userTableField + , userTableDegree :: Text + , userTableSemester :: Int + , userTableFieldType :: StudyFieldType + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +makeLenses_ ''UserTableStudyFeature -parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int) -parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) - where - Ldap.Attr key = ldapUserSubTermsSemester +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''UserTableStudyFeature +newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature) + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON) +makeWrapped ''UserTableStudyFeatures -pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] -pStudyFeatures studyFeaturesUser now = do - studyFeaturesDegree <- StudyDegreeKey' <$> pKey - void $ string "$$" +instance Csv.ToField UserTableStudyFeature where + toField UserTableStudyFeature{..} = encodeUtf8 + [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|] + where userTableFieldType' = renderMessage + (error "Foundation inspected during renderMessage" :: UniWorX) + [] $ ShortStudyFieldType userTableFieldType - let - pStudyFeature = do - _ <- pKey -- "Fächergruppe" - void $ char '!' - _ <- pKey -- "Studienbereich" - void $ char '!' - studyFeaturesField <- StudyTermsKey' <$> pKey - void $ char '!' - studyFeaturesType <- pType - void $ char '!' - studyFeaturesSemester <- decimal - let studyFeaturesValid = True - studyFeaturesSuperField = Nothing - studyFeaturesFirstObserved = Just now - studyFeaturesLastObserved = now - return StudyFeatures{..} +instance Csv.ToField UserTableStudyFeatures where + toField = ByteString.intercalate "; " . map Csv.toField . sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped - pStudyFeature `sepBy1` char '#' +userTableStudyFeatureSort :: UserTableStudyFeature + -> UserTableStudyFeature + -> Ordering +userTableStudyFeatureSort = mconcat + [ compareUnicode `on` userTableDegree + , comparing userTableSemester + , comparing userTableFieldType + , compareUnicode `on` userTableField + ] + -pKey :: Parser Int -pKey = decimal +isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isCourseStudyFeature course studyFeatures + = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) + E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart + where termEnd = E.subSelectForeign course CourseTerm (E.^. TermEnd) + termStart = E.subSelectForeign course CourseTerm (E.^. TermStart) -pType :: Parser StudyFieldType -pType = FieldPrimary <$ try (string "HF") - <|> FieldSecondary <$ try (string "NF") +courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures +courseUserStudyFeatures cId uid = do + feats <- E.select . E.from $ \(course `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do + E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ isCourseStudyFeature course studyFeatures + E.where_ $ course E.^. CourseId E.==. E.val cId + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + return (terms, degree, studyFeatures) + return . UserTableStudyFeatures . Set.fromList . flip map feats $ + \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature + { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName + , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName + , userTableSemester = studyFeaturesSemester + , userTableFieldType = studyFeaturesType + } -decimal :: Parser Int -decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' - where - digit' = dVal <$> digit - dVal c = fromEnum c - fromEnum '0' +isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isExternalExamStudyFeature externalExam studyFeatures + = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) + E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart + where termEnd = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermEnd) + termStart = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermStart) - -pLMUTermsSemester :: Parser (StudyTermsId, Int) -pLMUTermsSemester = do - subTermsKey <- StudyTermsKey' <$> pKey - void $ char '$' - semester <- decimal - - return (subTermsKey, semester) +externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures +externalExamUserStudyFeatures eeId uid = do + feats <- E.select . E.from $ \(externalExam `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do + E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ isExternalExamStudyFeature externalExam studyFeatures + E.where_ $ externalExam E.^. ExternalExamId E.==. E.val eeId + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + return (terms, degree, studyFeatures) + return . UserTableStudyFeatures . Set.fromList . flip map feats $ + \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature + { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName + , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName + , userTableSemester = studyFeaturesSemester + , userTableFieldType = studyFeaturesType + } diff --git a/src/Handler/Utils/StudyFeatures/Parse.hs b/src/Handler/Utils/StudyFeatures/Parse.hs new file mode 100644 index 000000000..3001c258f --- /dev/null +++ b/src/Handler/Utils/StudyFeatures/Parse.hs @@ -0,0 +1,70 @@ +module Handler.Utils.StudyFeatures.Parse + ( parseStudyFeatures + , parseSubTermsSemester + ) where + +import Import.NoFoundation hiding (try, (<|>)) + +import Text.Parsec +import Text.Parsec.Text + +import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures) +import qualified Ldap.Client as Ldap + + +parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures] +parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key) + where + Ldap.Attr key = ldapUserStudyFeatures + +parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int) +parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) + where + Ldap.Attr key = ldapUserSubTermsSemester + + +pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures] +pStudyFeatures studyFeaturesUser now = do + studyFeaturesDegree <- StudyDegreeKey' <$> pKey + void $ string "$$" + + let + pStudyFeature = do + _ <- pKey -- "Fächergruppe" + void $ char '!' + _ <- pKey -- "Studienbereich" + void $ char '!' + studyFeaturesField <- StudyTermsKey' <$> pKey + void $ char '!' + studyFeaturesType <- pType + void $ char '!' + studyFeaturesSemester <- decimal + let studyFeaturesValid = True + studyFeaturesSuperField = Nothing + studyFeaturesFirstObserved = Just now + studyFeaturesLastObserved = now + return StudyFeatures{..} + + pStudyFeature `sepBy1` char '#' + +pKey :: Parser Int +pKey = decimal + +pType :: Parser StudyFieldType +pType = FieldPrimary <$ try (string "HF") + <|> FieldSecondary <$ try (string "NF") + +decimal :: Parser Int +decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit' + where + digit' = dVal <$> digit + dVal c = fromEnum c - fromEnum '0' + + +pLMUTermsSemester :: Parser (StudyTermsId, Int) +pLMUTermsSemester = do + subTermsKey <- StudyTermsKey' <$> pKey + void $ char '$' + semester <- decimal + + return (subTermsKey, semester) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index bc8e1c23d..916bd2df9 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -34,10 +34,13 @@ import Web.HttpApiData data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) + deriving anyclass (Universe, Finite) + derivePersistField "StudyFieldType" -instance Universe StudyFieldType -instance Finite StudyFieldType nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1 +pathPieceJSON ''StudyFieldType +pathPieceJSONKey ''StudyFieldType + data Theme From f44f1507471a9310a9c88738ca5b3d8268afc136 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 21:55:44 +0200 Subject: [PATCH 08/48] fix: order of on in exam office auth --- src/Handler/Utils/ExamOffice/Exam.hs | 2 +- src/Handler/Utils/ExamOffice/ExternalExam.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index 272a9771f..32248dc7b 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -36,9 +36,9 @@ examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool where authByField = E.exists . E.from $ \(course `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.on $ isCourseStudyFeature course studyFeatures E.&&. course E.^. CourseId E.==. E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) - E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. examResult E.^. ExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index c509516a4..7d9c177d3 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -36,9 +36,9 @@ examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool where authByField = E.exists . E.from $ \(externalExam `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.on $ isExternalExamStudyFeature externalExam studyFeatures E.&&. externalExam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam - E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. eexamResult E.^. ExternalExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField From 51a98f067086bcef3daff601b53d5eb45f4a27f0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Aug 2020 23:46:21 +0200 Subject: [PATCH 09/48] feat: reduce number of study features for courses --- messages/uniworx/de-de-formal.msg | 2 + src/Database/Esqueleto/Utils.hs | 16 ++++++- src/Handler/Course/User.hs | 4 +- src/Handler/Course/Users.hs | 1 + src/Handler/Utils/StudyFeatures.hs | 45 ++++++++++++++----- src/Handler/Utils/Table/Columns.hs | 8 ++++ .../table/cell/user-study-feature.hamlet | 2 + 7 files changed, 62 insertions(+), 16 deletions(-) create mode 100644 templates/table/cell/user-study-feature.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index fcd767b01..98a0788b5 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -879,6 +879,8 @@ SubmissionReplace: Abgabe ersetzen SubmissionCreated: Abgabe erfolgreich angelegt SubmissionUpdated: Abgabe erfolgreich ersetzt +ColumnStudyFeatures: Studiendaten + AdminFeaturesHeading: Studiengänge StudyTerms: Studiengänge StudyTerm: Studiengang diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index e633cd1b1..26d29a2f9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -21,17 +21,18 @@ module Database.Esqueleto.Utils , maybe, maybeEq, unsafeCoalesce , bool , max, min + , abs , SqlProject(..) , (->.) , fromSqlKey , selectCountRows , selectMaybe - , day + , day, diffDays , module Database.Esqueleto.Utils.TH ) where -import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min) +import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min, abs) import Data.Universe import qualified Data.Set as Set import qualified Data.List as List @@ -290,6 +291,11 @@ max, min :: PersistField a max a b = bool a b $ b E.>. a min a b = bool a b $ b E.<. a +abs :: (PersistField a, Num a) + => E.SqlExpr (E.Value a) + -> E.SqlExpr (E.Value a) +abs x = bool (E.val 0 E.-. x) x $ x E.>. E.val 0 + unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a) unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce @@ -330,3 +336,9 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day) day = E.unsafeSqlCastAs "date" + +infixl 6 `diffDays` + +diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) +-- ^ PostgreSQL is weird. +diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 211b9b524..de8747fc4 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -95,10 +95,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = (mRegistration, studies) <- lift . runDB $ do registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - studies <- E.select $ E.from $ \(course `E.InnerJoin` studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.on $ isCourseStudyFeature course studyfeat + studies <- E.select $ E.from $ \(course `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + E.on $ isCourseStudyFeature course studyfeat E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.where_ $ course E.^. CourseId E.==. E.val cid return (studyfeat, studydegree, studyterms) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index a948e0bef..2a74a8d0b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -524,6 +524,7 @@ postCUsersR tid ssh csh = do , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr + , pure . cap' $ colStudyFeatures _userStudyFeatures , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 10dffa21e..5e4a0ee59 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -3,6 +3,7 @@ module Handler.Utils.StudyFeatures , UserTableStudyFeature(..) , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType , UserTableStudyFeatures(..) + , _UserTableStudyFeatures , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures ) where @@ -42,6 +43,9 @@ newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeatu deriving newtype (ToJSON, FromJSON) makeWrapped ''UserTableStudyFeatures +_UserTableStudyFeatures :: Iso' UserTableStudyFeatures [UserTableStudyFeature] +_UserTableStudyFeatures = iso (sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped) (UserTableStudyFeatures . Set.fromList) + instance Csv.ToField UserTableStudyFeature where toField UserTableStudyFeature{..} = encodeUtf8 [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|] @@ -50,7 +54,7 @@ instance Csv.ToField UserTableStudyFeature where [] $ ShortStudyFieldType userTableFieldType instance Csv.ToField UserTableStudyFeatures where - toField = ByteString.intercalate "; " . map Csv.toField . sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped + toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures userTableStudyFeatureSort :: UserTableStudyFeature -> UserTableStudyFeature @@ -61,14 +65,35 @@ userTableStudyFeatureSort = mconcat , comparing userTableFieldType , compareUnicode `on` userTableField ] - + + +isRelevantStudyFeature :: PersistEntity record + => EntityField record TermId + -> E.SqlExpr (Entity record) + -> E.SqlExpr (Entity StudyFeatures) + -> E.SqlExpr (E.Value Bool) +isRelevantStudyFeature termField record studyFeatures + = overlap studyFeatures E.>. E.val 0 + E.&&. E.not_ (E.exists betterOverlap) + where termEnd = E.subSelectForeign record termField (E.^. TermEnd) + termStart = E.subSelectForeign record termField (E.^. TermStart) + + overlap :: E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Int) + overlap studyFeatures' + = E.min (E.day $ studyFeatures' E.^. StudyFeaturesLastObserved) termEnd + `E.diffDays` E.maybe termStart (E.max termStart . E.day) (studyFeatures' E.^. StudyFeaturesFirstObserved) + + betterOverlap = E.from $ \studyFeatures' -> do + E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser + E.&&. studyFeatures' E.^. StudyFeaturesDegree E.==. studyFeatures E.^. StudyFeaturesDegree + E.&&. studyFeatures' E.^. StudyFeaturesField E.==. studyFeatures E.^. StudyFeaturesField + E.&&. studyFeatures' E.^. StudyFeaturesSuperField `E.maybeEq` studyFeatures E.^. StudyFeaturesSuperField + E.&&. studyFeatures' E.^. StudyFeaturesType E.==. studyFeatures E.^. StudyFeaturesType + E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1 + E.&&. overlap studyFeatures' E.>. overlap studyFeatures isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isCourseStudyFeature course studyFeatures - = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) - E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart - where termEnd = E.subSelectForeign course CourseTerm (E.^. TermEnd) - termStart = E.subSelectForeign course CourseTerm (E.^. TermStart) +isCourseStudyFeature = isRelevantStudyFeature CourseTerm courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures courseUserStudyFeatures cId uid = do @@ -88,11 +113,7 @@ courseUserStudyFeatures cId uid = do } isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isExternalExamStudyFeature externalExam studyFeatures - = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved) - E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart - where termEnd = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermEnd) - termStart = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermStart) +isExternalExamStudyFeature = isRelevantStudyFeature ExternalExamTerm externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures externalExamUserStudyFeatures eeId uid = do diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index b3329f0c5..41483756f 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -24,6 +24,7 @@ import Handler.Utils.Table.Pagination import Handler.Utils.Form import Handler.Utils.Widgets import Handler.Utils.DateTime +import Handler.Utils.StudyFeatures import qualified Data.CaseInsensitive as CI @@ -778,6 +779,13 @@ fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map Fil fltrDegreeUI mPrev = prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName) + +colStudyFeatures :: OpticColonnade UserTableStudyFeatures +colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body + where + header = Sortable Nothing (i18nCell MsgColumnStudyFeatures) + body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature") + ----------------- -- Allocations -- ----------------- diff --git a/templates/table/cell/user-study-feature.hamlet b/templates/table/cell/user-study-feature.hamlet new file mode 100644 index 000000000..94cd12b61 --- /dev/null +++ b/templates/table/cell/user-study-feature.hamlet @@ -0,0 +1,2 @@ +$newline never +#{userTableField} #{userTableDegree} (_{userTableFieldType} #{userTableSemester}) From 96d0ba8f7a1c8d8d4e895541b66e36d35392fb25 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 11:51:16 +0200 Subject: [PATCH 10/48] feat: study feature filtering --- src/Database/Esqueleto/Utils.hs | 5 +++ src/Handler/Course/Users.hs | 15 +++++++++ src/Handler/Utils/StudyFeatures.hs | 1 + src/Handler/Utils/Table/Columns.hs | 51 ++++++++++++++++++++++++++++++ 4 files changed, 72 insertions(+) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 26d29a2f9..23daf5679 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -8,6 +8,7 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , or, and , any, all + , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith , mkContainsFilter, mkContainsFilterWith , mkExistsFilter @@ -109,6 +110,10 @@ any test = or . map test . otoList all :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool) all test = and . map test . otoList +subSelectAnd, subSelectOr :: E.SqlQuery (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) +subSelectAnd q = E.subSelectUnsafe $ E.unsafeSqlFunction "bool_and" <$> q +subSelectOr q = E.subSelectUnsafe $ E.unsafeSqlFunction "bool_or" <$> q + -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples $(sqlInTuples [2..16]) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 2a74a8d0b..8db6e791c 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -409,6 +409,18 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.&&. sheet E.^. SheetName E.==. E.val shn ) + , fltrRelevantStudyFeaturesTerms (to $ + \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + , queryUser t E.^. UserId + )) + , fltrRelevantStudyFeaturesDegree (to $ + \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + , queryUser t E.^. UserId + )) + , fltrRelevantStudyFeaturesSemester (to $ + \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + , queryUser t E.^. UserId + )) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ @@ -420,6 +432,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do [ 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) + , fltrRelevantStudyFeaturesDegreeUI mPrev + , fltrRelevantStudyFeaturesTermsUI mPrev + , fltrRelevantStudyFeaturesSemesterUI mPrev ] ++ [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter) | not $ null personalisedSheets diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 5e4a0ee59..359f6780a 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -4,6 +4,7 @@ module Handler.Utils.StudyFeatures , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType , UserTableStudyFeatures(..) , _UserTableStudyFeatures + , isRelevantStudyFeature , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures ) where diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 41483756f..3d66fcace 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -786,6 +786,57 @@ colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body header = Sortable Nothing (i18nCell MsgColumnStudyFeatures) body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature") +fltrRelevantStudyFeaturesTerms :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) +fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . FilterColumn $ \t criterias -> + E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do + E.on $ isRelevantStudyFeature TermId term studyFeatures + + let (tid, uid) = t ^. queryTermUser + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid + E.&&. term E.^. TermId E.==. tid + + return $ anyFilter + [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsName) + , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsShorthand) + , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesField $ E.just . (E.^. StudyTermsKey) + ] studyFeatures criterias + +fltrRelevantStudyFeaturesTermsUI :: DBFilterUI +fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI + +fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) +fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias -> + E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do + E.on $ isRelevantStudyFeature TermId term studyFeatures + + let (tid, uid) = t ^. queryTermUser + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid + E.&&. term E.^. TermId E.==. tid + + return $ anyFilter + [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeName) + , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeShorthand) + , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesDegree $ E.just . (E.^. StudyDegreeKey) + ] studyFeatures criterias + +fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrRelevantStudyFeaturesDegreeUI mPrev = + prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgDegreeName) + +fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) +fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias -> + E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do + E.on $ isRelevantStudyFeature TermId term studyFeatures + + let (tid, uid) = t ^. queryTermUser + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid + E.&&. term E.^. TermId E.==. tid + + return $ mkExactFilterWith (readMay :: Text -> Maybe Int) (E.just . (E.^. StudyFeaturesSemester)) studyFeatures criterias + +fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI +fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI + ----------------- -- Allocations -- ----------------- From 44eeffcc70a8b4c119e1a88a9ef01c687fe2e10a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 13:14:18 +0200 Subject: [PATCH 11/48] feat: course applications study features --- messages/uniworx/de-de-formal.msg | 4 ++ src/Handler/Course/Application/List.hs | 40 +++++++++++++------- src/Handler/Utils/ExamOffice/Exam.hs | 14 ++++--- src/Handler/Utils/ExamOffice/ExternalExam.hs | 8 ++-- src/Handler/Utils/StudyFeatures.hs | 18 ++++++++- 5 files changed, 61 insertions(+), 23 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 98a0788b5..22f213807 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2025,6 +2025,10 @@ CsvColumnApplicationsVeto: Bewerber mit Veto werden garantiert nicht dem Kurs zu CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., "4.0", "5.0" (Leer wird behandelt wie eine Note zwischen 2.3 und 2.7) CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber +ApplicationGeneratedColumns: Stammdaten +ApplicationUserColumns: Bewerbung +ApplicationRatingColumns: Bewertung + Action: Aktion ActionNoUsersSelected: Keine Benutzer ausgewählt diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index a47d967f7..426c519d8 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -25,6 +25,7 @@ import qualified Data.Map as Map import qualified Data.Conduit.List as C import Handler.Course.ParticipantInvite +import Handler.Utils.StudyFeatures import Jobs.Queue @@ -39,6 +40,7 @@ type CourseApplicationsTableData = DBRow ( Entity CourseApplication , Bool -- hasFiles , Maybe (Entity Allocation) , Bool -- isParticipant + , UserTableStudyFeatures ) courseApplicationsIdent :: Text @@ -80,6 +82,9 @@ resultAllocation = _dbrOutput . _4 . _Just resultIsParticipant :: Lens' CourseApplicationsTableData Bool resultIsParticipant = _dbrOutput . _5 +resultStudyFeatures :: Lens' CourseApplicationsTableData UserTableStudyFeatures +resultStudyFeatures = _dbrOutput . _6 + newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -265,23 +270,32 @@ postCApplicationsR tid ssh csh = do ) dbtProj :: DBRow _ -> DB CourseApplicationsTableData - dbtProj = traverse $ return . over _3 E.unValue . over _5 E.unValue + dbtProj = traverse $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do + feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey) + return (application, user, hasFiles, allocation, isParticipant, feats) dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId) - dbtColonnade :: Colonnade Sortable _ _ + dbtColonnade :: Cornice Sortable ('Cap 'Base) _ _ dbtColonnade = mconcat - [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant - , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) - , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey) - , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) - , lmap (view $ resultUser . _entityVal) colUserEmail - , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) - , 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) - , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints) - , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment) + [ cap (Sortable Nothing $ i18nCell MsgApplicationGeneratedColumns) $ mconcat + [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant + , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) + , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey) + , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) + , lmap (view $ resultUser . _entityVal) colUserEmail + , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) + , colStudyFeatures resultStudyFeatures + ] + , cap (Sortable Nothing $ i18nCell MsgApplicationUserColumns) $ mconcat + [ colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText) + , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles)) + ] + , cap (Sortable Nothing $ i18nCell MsgApplicationRatingColumns) $ mconcat + [ colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto) + , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints) + , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment) + ] ] dbtSorting = mconcat diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index 32248dc7b..9d8d1b50c 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -8,6 +8,7 @@ import Import.NoFoundation import Handler.Utils.StudyFeatures import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (Entity ExamResult) @@ -35,10 +36,13 @@ examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (E.Value Bool) examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool where - authByField = E.exists . E.from $ \(course `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + cId = E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) + + authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField - E.on $ isCourseStudyFeature course studyFeatures - E.&&. course E.^. CourseId E.==. E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) + E.where_ . E.maybe E.false id . E.subSelectMaybe . E.from $ \course -> do + E.where_ $ course E.^. CourseId E.==. cId + return . E.just $ isCourseStudyFeature course studyFeatures E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. examResult E.^. ExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField @@ -46,8 +50,8 @@ examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. E.||. E.exists (E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. authId E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice - E.&&. E.not_ (E.exists . E.from $ \courseUserExamOfficeOptOut -> - E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId + E.&&. E.not_ (E.exists . E.from $ \courseUserExamOfficeOptOut -> do + E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. cId E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool ) diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index 7d9c177d3..ed7be4aba 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -7,6 +7,7 @@ import Import.NoFoundation import Handler.Utils.StudyFeatures import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office @@ -35,10 +36,11 @@ examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (E.Value Bool) examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool where - authByField = E.exists . E.from $ \(externalExam `E.InnerJoin` examOfficeField `E.InnerJoin` studyFeatures) -> do + authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField - E.on $ isExternalExamStudyFeature externalExam studyFeatures - E.&&. externalExam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam + E.where_ . E.maybe E.false id . E.subSelectMaybe . E.from $ \externalExam -> do + E.where_ $ externalExam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam + return . E.just $ isExternalExamStudyFeature externalExam studyFeatures E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. eexamResult E.^. ExternalExamResultUser E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 359f6780a..00af8c928 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -74,8 +74,18 @@ isRelevantStudyFeature :: PersistEntity record -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) isRelevantStudyFeature termField record studyFeatures - = overlap studyFeatures E.>. E.val 0 - E.&&. E.not_ (E.exists betterOverlap) + = ( ( overlap studyFeatures E.>. E.val 0 + E.||. ( E.just (studyFeatures E.^. StudyFeaturesLastObserved) E.==. studyFeatures E.^. StudyFeaturesFirstObserved + E.&&. termStart E.<=. E.day (studyFeatures E.^. StudyFeaturesLastObserved) + E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.<=. termEnd + ) + ) + E.&&. E.not_ (E.exists betterOverlap) + ) + E.||. ( E.subSelectForeign record termField (E.^. TermActive) + E.&&. E.not_ (E.exists anyOverlap) + E.&&. studyFeatures E.^. StudyFeaturesValid + ) where termEnd = E.subSelectForeign record termField (E.^. TermEnd) termStart = E.subSelectForeign record termField (E.^. TermStart) @@ -84,6 +94,10 @@ isRelevantStudyFeature termField record studyFeatures = E.min (E.day $ studyFeatures' E.^. StudyFeaturesLastObserved) termEnd `E.diffDays` E.maybe termStart (E.max termStart . E.day) (studyFeatures' E.^. StudyFeaturesFirstObserved) + anyOverlap = E.from $ \studyFeatures' -> do + E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser + E.where_ $ overlap studyFeatures' E.>. E.val 0 + betterOverlap = E.from $ \studyFeatures' -> do E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser E.&&. studyFeatures' E.^. StudyFeaturesDegree E.==. studyFeatures E.^. StudyFeaturesDegree From dcfdb5130d19e737147bfe9065a6ccb5edf49a77 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 13:15:16 +0200 Subject: [PATCH 12/48] fix: missing translations --- messages/uniworx/en-eu.msg | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 8b94f6d6f..218a2f410 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -876,6 +876,8 @@ SubmissionReplace: Replace submission SubmissionCreated: Successfully created submission SubmissionUpdated: Successfully replaced submission +ColumnStudyFeatures: Features of study + AdminFeaturesHeading: Features of study StudyTerms: Fields of study StudyTerm: Field of study @@ -2022,6 +2024,10 @@ CsvColumnApplicationsVeto: Vetoed applicants are never assigned to the course; " CsvColumnApplicationsRating: Application grading; Any number grade ("1.0", "1.3", "1.7", ..., "4.0", "5.0"); Empty cells will be treated as if they contained a grade between 2.3 and 2.7 CsvColumnApplicationsComment: Application comment; depending on course settings this might purely be a note for course administrators or be feedback for the applicant +ApplicationGeneratedColumns: Master data +ApplicationUserColumns: Application +ApplicationRatingColumns: Rating + Action: Action ActionNoUsersSelected: No users selected From 363f7abc192872ebd2a609b8bd89b58032bc9131 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 14:29:35 +0200 Subject: [PATCH 13/48] feat: restore study features in all tables --- messages/uniworx/de-de-formal.msg | 2 +- messages/uniworx/en-eu.msg | 2 +- src/Handler/Course/Application/List.hs | 19 +++++++++++++++ src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/Users.hs | 31 ++++++++++++++++++++++++- src/Handler/ExamOffice/Exam.hs | 30 +++++++++++++++++++++++- src/Handler/Tutorial/Users.hs | 4 +++- src/Handler/Utils/ExternalExam/Users.hs | 31 ++++++++++++++++++++++++- src/Handler/Utils/StudyFeatures.hs | 4 +++- 9 files changed, 117 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 22f213807..cc7329693 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1999,7 +1999,7 @@ CsvColumnUserName: Voller Name des Teilnehmers CsvColumnUserMatriculation: Matrikelnummer des Teilnehmers CsvColumnUserSex: Geschlecht CsvColumnUserEmail: E-Mail-Adresse des Teilnehmers -CsvColumnUserStudyFeatures: Alle aktiven Studiendaten des Teilnehmers als Semikolon (;) separierte Liste +CsvColumnUserStudyFeatures: Alle relevanten Studiendaten des Teilnehmers als Semikolon (;) separierte Liste CsvColumnUserField: Studienfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat CsvColumnUserDegree: Abschluss, den der Teilnehmer im assoziierten Studienfach anstrebt CsvColumnUserSemester: Fachsemester des Teilnehmers im assoziierten Studienfach diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 218a2f410..fb555bcb4 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1998,7 +1998,7 @@ CsvColumnUserName: Participant's full name CsvColumnUserMatriculation: Participant's matriculation CsvColumnUserSex: Participant's sex CsvColumnUserEmail: Participant's email address -CsvColumnUserStudyFeatures: All active fields of study for the participant, separated by semicolon (;) +CsvColumnUserStudyFeatures: All relevant features of study for the participant, separated by semicolon (;) CsvColumnUserField: Field of study the participant specified when enrolling for the course CsvColumnUserDegree: Degree the participant pursues in their associated field of study CsvColumnUserSemester: Semester the participant is in wrt. to their associated field of study diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 426c519d8..6ba8ebcc1 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -107,6 +107,7 @@ data CourseApplicationsTableCsv = CourseApplicationsTableCsv , csvCAName :: Maybe Text , csvCAEmail :: Maybe UserEmail , csvCAMatriculation :: Maybe Text + , csvCAStudyFeatures :: UserTableStudyFeatures , csvCAText :: Maybe Text , csvCAHasFiles :: Maybe Bool , csvCAVeto :: Maybe CourseApplicationsTableVeto @@ -129,6 +130,7 @@ instance Csv.FromNamedRecord CourseApplicationsTableCsv where <*> csv .:?? "name" <*> csv .:?? "email" <*> csv .:?? "matriculation" + <*> pure mempty <*> csv .:?? "text" <*> csv .:?? "has-files" <*> csv .:?? "veto" @@ -145,6 +147,7 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where , ('csvCAName , MsgCsvColumnApplicationsName ) , ('csvCAEmail , MsgCsvColumnApplicationsEmail ) , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation) + , ('csvCAStudyFeatures, MsgCsvColumnUserStudyFeatures ) , ('csvCAText , MsgCsvColumnApplicationsText ) , ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles ) , ('csvCAVeto , MsgCsvColumnApplicationsVeto ) @@ -321,6 +324,18 @@ postCApplicationsR tid ssh csh = do , fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto) , fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints) , fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment) + , fltrRelevantStudyFeaturesTerms (to $ + \t -> ( E.val courseTerm + , views queryUser (E.^. UserId) t + )) + , fltrRelevantStudyFeaturesDegree (to $ + \t -> ( E.val courseTerm + , views queryUser (E.^. UserId) t + )) + , fltrRelevantStudyFeaturesSemester (to $ + \t -> ( E.val courseTerm + , views queryUser (E.^. UserId) t + )) ] dbtFilterUI = mconcat [ fltrAllocationUI @@ -332,6 +347,9 @@ postCApplicationsR tid ssh csh = do , fltrApplicationVetoUI , fltrApplicationRatingPointsUI , fltrApplicationRatingCommentUI + , fltrRelevantStudyFeaturesTermsUI + , fltrRelevantStudyFeaturesDegreeUI + , fltrRelevantStudyFeaturesSemesterUI ] dbtStyle = def @@ -345,6 +363,7 @@ postCApplicationsR tid ssh csh = do <*> preview (resultUser . _entityVal . _userDisplayName) <*> preview (resultUser . _entityVal . _userEmail) <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just) + <*> view resultStudyFeatures <*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just) <*> preview resultHasFiles <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 8db6e791c..68abfdcd3 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 - , colUserSex' + , colUserSex', _userStudyFeatures ) where import Import diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index a347d95a0..30b351113 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -10,6 +10,7 @@ import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Users import Handler.Utils.Csv +import Handler.Utils.StudyFeatures import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) @@ -58,6 +59,7 @@ type ExamUserTableData = DBRow ( Entity ExamRegistration , Maybe (Entity ExamResult) , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) , Maybe (Entity CourseUserNote) + , UserTableStudyFeatures ) instance HasEntity ExamUserTableData User where @@ -137,6 +139,9 @@ resultExamPartResults = resultExamParts <. _2 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) resultCourseNote = _dbrOutput . _7 . _Just +resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures +resultStudyFeatures = _dbrOutput . _8 + resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) @@ -165,6 +170,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserFirstName :: Maybe Text , csvEUserName :: Maybe Text , csvEUserMatriculation :: Maybe Text + , csvEUserStudyFeatures :: UserTableStudyFeatures , csvEUserOccurrence :: Maybe (CI Text) , csvEUserExercisePoints :: Maybe (Maybe Points) , csvEUserExerciseNumPasses :: Maybe (Maybe Int) @@ -184,6 +190,7 @@ instance ToNamedRecord ExamUserTableCsv where , "first-name" Csv..= csvEUserFirstName , "name" Csv..= csvEUserName , "matriculation" Csv..= csvEUserMatriculation + , "study-features" Csv..= csvEUserStudyFeatures , "occurrence" Csv..= csvEUserOccurrence ] ++ catMaybes [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints @@ -208,6 +215,7 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:?? "first-name" <*> csv .:?? "name" <*> csv .:?? "matriculation" + <*> pure mempty <*> csv .:?? "occurrence" <*> fmap Just (csv .:?? "exercise-points") <*> fmap Just (csv .:?? "exercise-num-passes") @@ -228,6 +236,7 @@ instance CsvColumnsExplained ExamUserTableCsv where , single "first-name" MsgCsvColumnExamUserFirstName , single "name" MsgCsvColumnExamUserName , single "matriculation" MsgCsvColumnExamUserMatriculation + , single "study-features" MsgCsvColumnUserStudyFeatures , single "occurrence" MsgCsvColumnExamUserOccurrence , single "exercise-points" MsgCsvColumnExamUserExercisePoints , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses @@ -249,6 +258,7 @@ examUserTableCsvHeader :: ( MonoFoldable mono examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ [ "surname", "first-name", "name" , "matriculation" + , "study-features" , "course-note" , "occurrence" ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints) @@ -359,6 +369,7 @@ getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn + Course{..} <- getJust examCourse occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName] examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam @@ -431,10 +442,11 @@ postEUsersR tid ssh csh examn = do 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 <*> getExamParts <*> view _6 + <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey)) where getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) getExamParts = do @@ -453,6 +465,7 @@ 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 $ colStudyFeatures 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 @@ -491,12 +504,27 @@ postEUsersR tid ssh csh examn = do , uncurry singletonMap $ fltrUserMatriclenr queryUser , uncurry singletonMap ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult)) + , fltrRelevantStudyFeaturesTerms (to $ + \t -> ( E.val courseTerm + , queryUser t E.^. UserId + )) + , fltrRelevantStudyFeaturesDegree (to $ + \t -> ( E.val courseTerm + , queryUser t E.^. UserId + )) + , fltrRelevantStudyFeaturesSemester (to $ + \t -> ( E.val courseTerm + , queryUser t E.^. UserId + )) ] dbtFilterUI mPrev = mconcat $ catMaybes [ Just $ fltrUserNameEmailUI mPrev , Just $ fltrUserMatriclenrUI mPrev , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence) , Just $ fltrExamResultPointsUI mPrev + , Just $ fltrRelevantStudyFeaturesTermsUI mPrev + , Just $ fltrRelevantStudyFeaturesDegreeUI mPrev + , Just $ fltrRelevantStudyFeaturesSemesterUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm @@ -564,6 +592,7 @@ postEUsersR tid ssh csh examn = do <*> view (resultUser . _entityVal . _userFirstName . to Just) <*> view (resultUser . _entityVal . _userDisplayName . to Just) <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> view resultStudyFeatures <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) <*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 209da69f2..4364079c7 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -22,6 +22,8 @@ import qualified Data.Map as Map import qualified Data.Conduit.List as C import qualified Colonnade +import Handler.Utils.StudyFeatures + data ButtonCloseExam = BtnCloseExam deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) @@ -75,6 +77,7 @@ type ExamUserTableData = DBRow ( Entity ExamResult , Maybe (Entity ExamRegistration) , Bool , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] + , UserTableStudyFeatures ) queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration))) @@ -113,11 +116,15 @@ resultIsSynced = _dbrOutput . _5 resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand) resultSynchronised = _dbrOutput . _6 . traverse +resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures +resultStudyFeatures = _dbrOutput . _7 + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Text , csvEUserFirstName :: Text , csvEUserName :: Text , csvEUserMatriculation :: Maybe Text + , csvEUserStudyFeatures :: UserTableStudyFeatures , csvEUserOccurrenceStart :: Maybe ZonedTime , csvEUserExamResult :: ExamResultPassedGrade } @@ -139,6 +146,7 @@ instance CsvColumnsExplained ExamUserTableCsv where , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) , ('csvEUserName , MsgCsvColumnExamUserName ) , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) + , ('csvEUserStudyFeatures , MsgCsvColumnUserStudyFeatures ) , ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart ) , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) ] @@ -166,6 +174,7 @@ postEGradesR tid ssh csh examn = do now <- liftIO getCurrentTime ((usersResult, examUsersTable), Entity eId _) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + Course{..} <- getJust examCourse csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR @@ -241,9 +250,10 @@ postEGradesR tid ssh csh examn = do dbtProj :: DBRow _ -> DB ExamUserTableData dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ - (,,,,,) + (,,,,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value) <*> getSynchronised + <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey)) where getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] getSynchronised = do @@ -297,6 +307,7 @@ 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) + , colStudyFeatures resultStudyFeatures , 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 @@ -315,12 +326,28 @@ postEGradesR tid ssh csh examn = do , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) , fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just) , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid) + , fltrRelevantStudyFeaturesTerms (to $ + \t -> ( E.val courseTerm + , views queryUser (E.^. UserId) t + )) + , fltrRelevantStudyFeaturesDegree (to $ + \t -> ( E.val courseTerm + , views queryUser (E.^. UserId) t + )) + , fltrRelevantStudyFeaturesSemester (to $ + \t -> ( E.val courseTerm + , views queryUser (E.^. UserId) t + )) + ] dbtFilterUI = mconcat [ fltrUserNameUI' , fltrUserMatriculationUI , fltrExamResultPointsUI , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised) + , fltrRelevantStudyFeaturesTermsUI + , fltrRelevantStudyFeaturesDegreeUI + , fltrRelevantStudyFeaturesSemesterUI ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm @@ -355,6 +382,7 @@ postEGradesR tid ssh csh examn = do (row ^. resultUser . _entityVal . _userFirstName) (row ^. resultUser . _entityVal . _userDisplayName) (row ^. resultUser . _entityVal . _userMatrikelnummer) + (row ^. resultStudyFeatures) (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 6e7c9184f..5e91ce386 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -41,10 +41,12 @@ postTUsersR tid ssh csh tutn = do , guardOn showSex colUserSex' , pure colUserEmail , pure colUserMatriclenr + , pure $ colStudyFeatures _userStudyFeatures ] psValidator = def & defaultSortingByName - & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"]) 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 diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 68d6a5875..a64df671f 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -29,6 +29,8 @@ import qualified Data.Conduit.List as C import Data.List (cycle) +import Handler.Utils.StudyFeatures + data ExternalExamUserMode = EEUMUsers | EEUMGrades deriving (Eq, Ord, Read, Show, Bounded, Enum, Generic, Typeable) @@ -45,6 +47,7 @@ type ExternalExamUserTableData = DBRow ( Entity ExternalExamResult , Entity User , Bool , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] + , UserTableStudyFeatures ) queryUser :: Getter ExternalExamUserTableExpr (E.SqlExpr (Entity User)) @@ -68,12 +71,16 @@ resultIsSynced = _dbrOutput . _3 resultSynchronised :: Traversal' ExternalExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand) resultSynchronised = _dbrOutput . _4 . traverse +resultStudyFeatures :: Lens' ExternalExamUserTableData UserTableStudyFeatures +resultStudyFeatures = _dbrOutput . _5 + data ExternalExamUserTableCsv = ExternalExamUserTableCsv { csvEUserSurname :: Maybe Text , csvEUserFirstName :: Maybe Text , csvEUserName :: Maybe Text , csvEUserMatriculation :: Maybe Text + , csvEUserStudyFeatures :: UserTableStudyFeatures , csvEUserOccurrenceStart :: Maybe ZonedTime , csvEUserExamResult :: ExamResultPassedGrade } deriving (Generic) @@ -95,6 +102,7 @@ instance FromNamedRecord ExternalExamUserTableCsv where <*> csv .:?? "first-name" <*> csv .:?? "name" <*> csv .:?? "matriculation" + <*> pure mempty <*> csv .:?? "occurrence-start" <*> csv .: "exam-result" @@ -105,6 +113,7 @@ instance CsvColumnsExplained ExternalExamUserTableCsv where , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) , ('csvEUserName , MsgCsvColumnExamUserName ) , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) + , ('csvEUserStudyFeatures , MsgCsvColumnUserStudyFeatures ) , ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart ) , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) ] @@ -209,9 +218,10 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do dbtProj :: DBRow _ -> DB ExternalExamUserTableData dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ - (,,,) + (,,,,) <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> getSynchronised + <*> (lift . externalExamUserStudyFeatures eeId =<< view (_2 . _entityKey)) where getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] getSynchronised = do @@ -265,6 +275,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , fromMaybe mempty . guardOn (is _EEUMGrades mode) $ colSynced , colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) + , colStudyFeatures resultStudyFeatures , Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do t <- view $ resultResult . _entityVal . _externalExamResultTime lift $ formatTimeW SelFormatDateTime t @@ -282,6 +293,19 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) , fltrExamResultPoints (queryResult . to (E.^. ExternalExamResultResult) . to E.just) , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid) + , fltrRelevantStudyFeaturesTerms (to $ + \t -> ( E.val externalExamTerm + , views queryUser (E.^. UserId) t + )) + , fltrRelevantStudyFeaturesDegree (to $ + \t -> ( E.val externalExamTerm + , views queryUser (E.^. UserId) t + )) + , fltrRelevantStudyFeaturesSemester (to $ + \t -> ( E.val externalExamTerm + , views queryUser (E.^. UserId) t + )) + ] dbtFilterUI = mconcat [ fltrUserNameUI' @@ -291,6 +315,9 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do EEUMGrades -> \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised) _other -> mempty + , fltrRelevantStudyFeaturesTermsUI + , fltrRelevantStudyFeaturesDegreeUI + , fltrRelevantStudyFeaturesSemesterUI ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm @@ -345,6 +372,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do } EEUMUsers -> let baseEncode = simpleCsvEncode csvName encodeCsv' + csvEUserStudyFeatures = mempty in baseEncode <&> \enc -> enc { dbtCsvExampleData = Just [ ExternalExamUserTableCsv{..} @@ -388,6 +416,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , csvEUserFirstName = row ^? resultUser . _entityVal . _userFirstName , csvEUserName = row ^? resultUser . _entityVal . _userDisplayName , csvEUserMatriculation = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just + , csvEUserStudyFeatures = row ^. resultStudyFeatures , csvEUserOccurrenceStart = row ^? resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime , csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult } diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 00af8c928..f4d146d11 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -41,7 +41,9 @@ deriveJSON defaultOptions newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature) deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (ToJSON, FromJSON) + deriving newtype ( ToJSON, FromJSON + , Semigroup, Monoid + ) makeWrapped ''UserTableStudyFeatures _UserTableStudyFeatures :: Iso' UserTableStudyFeatures [UserTableStudyFeature] From 6abe5c8b3f917cdf13909aa42a19d7aa9db96237 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 14:43:18 +0200 Subject: [PATCH 14/48] refactor: hlint --- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Course/Users.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index c2e01d7c5..f7c9ea350 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -93,7 +93,7 @@ participantInvitationConfig = InvitationConfig{..} invitationRestriction _ _ = return Authorized invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime - return . fmap (, ()) $ JunctionParticipant now <$> pure Nothing <*> pure CourseParticipantActive + return . pure . (, ()) $ JunctionParticipant now Nothing 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 diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 68abfdcd3..f6c31ef4e 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -223,7 +223,7 @@ instance CsvColumnsExplained UserTableCsv where single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget single k v = singletonMap k [whamlet|_{v}|] -data UserCsvExportData = UserCsvExportData +newtype UserCsvExportData = UserCsvExportData { csvUserIncludeSheets :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default UserCsvExportData where From 2c4080d0e0d7f59829238830a5200116a9d884ec Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 14:55:32 +0200 Subject: [PATCH 15/48] feat: generated columns tooltip --- messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 1 + src/Handler/Course/Application/List.hs | 3 ++- 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index cc7329693..05a93d902 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2026,6 +2026,7 @@ CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber ApplicationGeneratedColumns: Stammdaten +ApplicationGeneratedColumnsTip: Auf diese Daten haben die Bewerber keinen Einfluss ApplicationUserColumns: Bewerbung ApplicationRatingColumns: Bewertung diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index fb555bcb4..f44dc45fb 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2025,6 +2025,7 @@ CsvColumnApplicationsRating: Application grading; Any number grade ("1.0", "1.3" CsvColumnApplicationsComment: Application comment; depending on course settings this might purely be a note for course administrators or be feedback for the applicant ApplicationGeneratedColumns: Master data +ApplicationGeneratedColumnsTip: Applicants cannot modify these data ApplicationUserColumns: Application ApplicationRatingColumns: Rating diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 6ba8ebcc1..57ed2f2db 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -281,7 +281,7 @@ postCApplicationsR tid ssh csh = do dbtColonnade :: Cornice Sortable ('Cap 'Base) _ _ dbtColonnade = mconcat - [ cap (Sortable Nothing $ i18nCell MsgApplicationGeneratedColumns) $ mconcat + [ cap (Sortable Nothing generatedColumnsHeader) $ mconcat [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand) , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey) @@ -300,6 +300,7 @@ postCApplicationsR tid ssh csh = do , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment) ] ] + where generatedColumnsHeader = cell $ i18n MsgApplicationGeneratedColumns <> (messageTooltip =<< messageI Info MsgApplicationGeneratedColumnsTip) dbtSorting = mconcat [ singletonMap "participant" . SortColumn $ view queryIsParticipant From 457738dc28538198ded2313c41d6bb0a5cadb103 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 15:44:00 +0200 Subject: [PATCH 16/48] Apply 2 suggestion(s) to 2 file(s) --- messages/uniworx/de-de-formal.msg | 2 +- messages/uniworx/en-eu.msg | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 05a93d902..07095c592 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2026,7 +2026,7 @@ CsvColumnApplicationsRating: Bewertung der Bewerbung; "1.0", "1.3", "1.7", ..., CsvColumnApplicationsComment: Kommentar zur Bewerbung; je nach Kurs-Einstellungen entweder nur als Notiz für die Kursverwalter oder Feedback für den Bewerber ApplicationGeneratedColumns: Stammdaten -ApplicationGeneratedColumnsTip: Auf diese Daten haben die Bewerber keinen Einfluss +ApplicationGeneratedColumnsTip: Stammdaten eines Bewerbers sind Daten, welche dem System zu diesem Benutzer bekannt sind und welche der Benutzer im Zuge der Bewerbung nicht beeinflussen kann. ApplicationUserColumns: Bewerbung ApplicationRatingColumns: Bewertung diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index f44dc45fb..1c236b868 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2025,7 +2025,7 @@ CsvColumnApplicationsRating: Application grading; Any number grade ("1.0", "1.3" CsvColumnApplicationsComment: Application comment; depending on course settings this might purely be a note for course administrators or be feedback for the applicant ApplicationGeneratedColumns: Master data -ApplicationGeneratedColumnsTip: Applicants cannot modify these data +ApplicationGeneratedColumnsTip: An applicant's master data is data which is known to the system about this user and which the user cannot modify when applying for the course. ApplicationUserColumns: Application ApplicationRatingColumns: Rating From 5541619372f4a4e46ccc403004e869afdfaed7b0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 18:33:41 +0200 Subject: [PATCH 17/48] fix: tests --- test/Handler/Sheet/PersonalisedFilesSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Handler/Sheet/PersonalisedFilesSpec.hs b/test/Handler/Sheet/PersonalisedFilesSpec.hs index 64b5e1dc1..8dacb3eca 100644 --- a/test/Handler/Sheet/PersonalisedFilesSpec.hs +++ b/test/Handler/Sheet/PersonalisedFilesSpec.hs @@ -61,7 +61,7 @@ spec = withApp . describe "Personalised sheet file zip encoding" $ do let res = res' { personalisedSheetFileResidualSheet = shid, personalisedSheetFileResidualUser = uid } fRef <- lift (sinkFile f :: DB FileReference) now <- liftIO getCurrentTime - void . lift . insert $ CourseParticipant cid (personalisedSheetFileResidualUser res) now Nothing Nothing CourseParticipantActive + void . lift . insert $ CourseParticipant cid (personalisedSheetFileResidualUser res) now Nothing CourseParticipantActive void . lift . insert $ _FileReference # (fRef, res) return (f, res) From abc37aca9c2aa5eafe7eea9333886b43189d5591 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Aug 2020 17:04:52 +0200 Subject: [PATCH 18/48] feat: add user-system-function --- messages/uniworx/de-de-formal.msg | 10 +++++++ messages/uniworx/en-eu.msg | 10 +++++++ models/users.model | 4 +++ src/Foundation/I18n.hs | 1 + src/Handler/Users.hs | 29 ++++++++++++++++++- src/Jobs/Handler/QueueNotification.hs | 3 ++ .../SendNotification/UserRightsUpdate.hs | 14 +++++++++ src/Jobs/Types.hs | 1 + src/Model/Types.hs | 1 + src/Model/Types/User.hs | 16 ++++++++++ src/Utils.hs | 3 ++ src/Utils/Form.hs | 1 + templates/adminUser.hamlet | 1 + .../mail/userSystemFunctionsUpdate.hamlet | 21 ++++++++++++++ 14 files changed, 114 insertions(+), 1 deletion(-) create mode 100644 src/Model/Types/User.hs create mode 100644 templates/mail/userSystemFunctionsUpdate.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 07095c592..de2ed76ba 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -765,6 +765,9 @@ CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"} UserListTitle: Komprehensive Benutzerliste AccessRightsSaved: Berechtigungen erfolgreich verändert AccessRightsNotChanged: Berechtigungen wurden nicht verändert +UserSystemFunctions: Systemweite Rollen +UserSystemFunctionsSaved: Systemweite Rollen gespeichert +UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"} @@ -1014,6 +1017,10 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte. MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen. +MailSubjectUserSystemFunctionsUpdate name@Text: Berechtigungen für #{name} aktualisiert +MailUserSystemFunctionsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work nicht-institutsbezogene Berechtigungen: +MailUserSystemFunctionsNoFunctions: Keine + MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer Uni2work-internen Kennung in Uni2work einloggen @@ -2750,3 +2757,6 @@ SheetPersonalisedFilesUsersList: Liste von Teilnehmern mit personalisierten Übu AdminCrontabNotGenerated: (Noch) keine Crontab generiert CronMatchAsap: ASAP CronMatchNone: Nie + +SystemExamOffice: Prüfungsverwaltung +SystemFaculty: Fakultätsmitglied \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 1c236b868..ade2650a1 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -762,6 +762,9 @@ CorrectorsFor n: #{pluralEN n "Corrector" "Correctors"} UserListTitle: Comprehensive list of users AccessRightsSaved: Successfully updated permissions AccessRightsNotChanged: Permissions left unchanged +UserSystemFunctions: System wide roles +UserSystemFunctionsSaved: Successfully saved system wide roles +UserSystemFunctionsNotChanged: No system wide roles were changed LecturersForN n: #{pluralEN n "Lecturer" "Lecturers"} @@ -1014,6 +1017,10 @@ MailUserRightsIntro name email: #{name} <#{email}> now has the following permiss MailNoLecturerRights: You don't currently have lecturer permissions for any department. MailLecturerRights n: As a lecturer you may create new courses within your #{pluralEN n "department" "departments"}. +MailSubjectUserSystemFunctionsUpdate name: Permissions for #{name} changed +MailUserSystemFunctionsIntro name email: #{name} <#{email}> now has the following, not school restricted, permissions: +MailUserSystemFunctionsNoFunctions: None + MailSubjectUserAuthModeUpdate: Your Uni2work login UserAuthModePWHashChangedToLDAP: You can now log in to Uni2work using your Campus-account UserAuthModeLDAPChangedToPWHash: You can now log in to Uni2work using your Uni2work-internal account @@ -2751,3 +2758,6 @@ SheetPersonalisedFilesUsersList: List of course participants who have personalis AdminCrontabNotGenerated: Crontab not (yet) generated CronMatchAsap: ASAP CronMatchNone: Never + +SystemExamOffice: Exam office +SystemFaculty: Faculty member diff --git a/models/users.model b/models/users.model index 740de8186..95945d8a8 100644 --- a/models/users.model +++ b/models/users.model @@ -42,6 +42,10 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation school SchoolId function SchoolFunction UniqueUserFunction user school function +UserSystemFunction + user UserId + function SystemFunction + UniqueUserSystemFunction user function UserExamOffice user UserId field StudyTermsId diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index aa514a72d..71543f2d9 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -219,6 +219,7 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel embedRenderMessage ''UniWorX ''SchoolFunction id +embedRenderMessage ''UniWorX ''SystemFunction id embedRenderMessage ''UniWorX ''CsvPreset id embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) embedRenderMessage ''UniWorX ''FavouriteReason id diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 88d0340fd..1f64d0da3 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -277,7 +277,7 @@ getAdminUserR = postAdminUserR postAdminUserR uuid = do adminId <- requireAuthId uid <- decrypt uuid - (user@User{..}, adminSchools, functions, schools) <- runDB $ do + (user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do user <- get404 uid schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do @@ -289,10 +289,14 @@ postAdminUserR uuid = do E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin return (school, userFunction E.?. UserFunctionFunction, isAdmin) + systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid] [] + let systemFunctions = (`Set.member` systemFunctionsF) + return ( user , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools , setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools , setOf (folded . _1) schools + , systemFunctions ) let allFunctions = Set.fromList universeF allSchools = Set.mapMonotonic entityKey schools @@ -311,6 +315,8 @@ postAdminUserR uuid = do userAuthenticationForm = buttonForm' $ if | userAuthentication == AuthLDAP -> [BtnAuthPWHash] | otherwise -> [BtnAuthLDAP, BtnPasswordReset] + systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False + where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func let userRightsAction changes = do let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes) updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff @@ -367,8 +373,24 @@ postAdminUserR uuid = do queueJob' $ JobSendPasswordReset uid addMessageI Success MsgPasswordResetQueued redirect $ AdminUserR uuid + + userSystemFunctionsAction newFuncs = do + let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions + if + | not $ Set.null symmDiff -> runDBJobs $ do + forM_ symmDiff $ \func -> if + | newFuncs func + -> void . insertUnique $ UserSystemFunction uid func + | otherwise + -> deleteBy $ UniqueUserSystemFunction uid func + queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions + addMessageI Success MsgUserSystemFunctionsSaved + | otherwise + -> addMessageI Info MsgUserSystemFunctionsNotChanged + redirect $ AdminUserR uuid ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm + ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm' let rightsForm = wrapForm rightsFormWidget def { formAction = Just . SomeRoute $ AdminUserR uuid , formEncoding = rightsFormEnctype @@ -378,8 +400,13 @@ postAdminUserR uuid = do , formEncoding = authFormEnctype , formSubmit = FormNoSubmit } + systemFunctionsForm = wrapForm systemFunctionsWidget def + { formAction = Just . SomeRoute $ AdminUserR uuid + , formEncoding = systemFunctionsEnctype + } formResult rightsResult userRightsAction formResult authResult userAuthenticationAction + formResult systemFunctionsResult userSystemFunctionsAction let heading = [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] -- Delete Button needed in data-delete diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index fb225b98f..38fa2a3f0 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -113,6 +113,8 @@ determineNotificationCandidates = awaitForever $ \notif -> do E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin return user withNotif . yieldMany . nub $ affectedUser <> affectedAdmins + NotificationUserSystemFunctionsUpdate{..} + -> withNotif $ selectSource [UserId ==. nUser] [] NotificationUserAuthModeUpdate{..} -> withNotif $ selectSource [UserId ==. nUser] [] NotificationExamRegistrationActive{..} @@ -295,6 +297,7 @@ classifyNotification NotificationSheetInactive{} = return NTShe classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate +classifyNotification NotificationUserSystemFunctionsUpdate{} = return NTUserRightsUpdate classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate classifyNotification NotificationExamRegistrationActive{} = return NTExamRegistrationActive classifyNotification NotificationExamRegistrationSoonInactive{} = return NTExamRegistrationSoonInactive diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs index aec3f2a42..f2a7ba935 100644 --- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs @@ -2,6 +2,7 @@ module Jobs.Handler.SendNotification.UserRightsUpdate ( dispatchNotificationUserRightsUpdate + , dispatchNotificationUserSystemFunctionsUpdate ) where import Import @@ -27,3 +28,16 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) + +dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Handler () +dispatchNotificationUserSystemFunctionsUpdate nUser _originalSystemFunctions jRecipient = userMailT jRecipient $ do + (User{..}, functions) <- liftHandler . runDB $ do + user <- getJust nUser + functions <- map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. nUser] [] + return (user, Set.fromList functions) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectUserSystemFunctionsUpdate userDisplayName + -- MsgRenderer mr <- getMailMsgRenderer + editNotifications <- mkEditNotifications jRecipient + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userSystemFunctionsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 729cd356b..065c806cc 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -99,6 +99,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } | NotificationCorrectionsNotDistributed { nSheet :: SheetId } | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } + | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } | NotificationExamRegistrationActive { nExam :: ExamId } | NotificationExamRegistrationSoonInactive { nExam :: ExamId } diff --git a/src/Model/Types.hs b/src/Model/Types.hs index fc3b1662f..b40e5c912 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -16,3 +16,4 @@ import Model.Types.School as Types import Model.Types.Allocation as Types import Model.Types.Languages as Types import Model.Types.File as Types +import Model.Types.User as Types diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs new file mode 100644 index 000000000..09eba6393 --- /dev/null +++ b/src/Model/Types/User.hs @@ -0,0 +1,16 @@ +module Model.Types.User where + +import Import.NoModel +import Model.Types.TH.PathPiece + + +data SystemFunction + = SystemExamOffice + | SystemFaculty + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, Hashable, NFData) + +nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1 +pathPieceJSON ''SystemFunction +pathPieceJSONKey ''SystemFunction +derivePersistFieldPathPiece ''SystemFunction diff --git a/src/Utils.hs b/src/Utils.hs index 6a5bd9105..3a517d231 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -483,6 +483,9 @@ setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k +setFromFunc = Set.fromList . flip filter universeF + ---------- -- Maps -- ---------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index b894c3137..2fa06586a 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -215,6 +215,7 @@ data FormIdentifier | FIDDelete | FIDCourseRegister | FIDuserRights + | FIDUserSystemFunctions | FIDcUserNote | FIDcRegField | FIDcRegButton diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index af9c9f5c2..6012e38d7 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -4,6 +4,7 @@ $newline never

_{MsgAdminUserRightsHeading} + ^{systemFunctionsForm} ^{rightsForm}

diff --git a/templates/mail/userSystemFunctionsUpdate.hamlet b/templates/mail/userSystemFunctionsUpdate.hamlet new file mode 100644 index 000000000..263a626c5 --- /dev/null +++ b/templates/mail/userSystemFunctionsUpdate.hamlet @@ -0,0 +1,21 @@ +$newline never +\ + + + +