diff --git a/models/study-features.model b/models/study-features.model new file mode 100644 index 000000000..71b72ad0f --- /dev/null +++ b/models/study-features.model @@ -0,0 +1,58 @@ +StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login + user UserId + degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. + field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. + superField StudyTermsId Maybe + type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach + semester Int + firstObserved UTCTime Maybe + lastObserved UTCTime default=now() -- last update from LDAP + valid Bool default=true + relevanceCached Bool default=false + UniqueStudyFeatures user degree field type semester + deriving Eq Show + -- UniqueUserSubject ubuser degree field -- There exists a counterexample + +RelevantStudyFeatures + term TermId + studyFeatures StudyFeaturesId + UniqueRelevantStudyFeatures term studyFeatures + +StudyDegree -- Studienabschluss + key Int -- LMU-internal key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + Primary key -- column key is used as actual DB row key + -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } + deriving Eq Show +StudyTerms -- Studiengang + key Int -- standardised key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + defaultDegree StudyDegreeId Maybe + defaultType StudyFieldType Maybe + Primary key -- column key is used as actual DB row key + -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } + deriving Eq Ord Show +StudySubTerms + child StudyTermsId + parent StudyTermsId + UniqueStudySubTerms child parent +StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. + -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. + -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. + -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations + incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs + key Int -- a possible key for the studyTermName or studySubTermName + name Text -- studyTermName as plain text from LDAP + deriving Show Eq Ord +StudySubTermParentCandidate + incidence TermCandidateIncidence + key Int + parent Int + deriving Show Eq Ord +StudyTermStandaloneCandidate + incidence TermCandidateIncidence + key Int + deriving Show Eq Ord + diff --git a/models/users.model b/models/users.model index b3b92e2d3..a8eb73c12 100644 --- a/models/users.model +++ b/models/users.model @@ -38,6 +38,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory + UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...) user UserId school SchoolId @@ -58,56 +59,6 @@ UserSchool -- Managed by users themselves, encodes "schools of interest" school SchoolId isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically UniqueUserSchool user school -StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login - user UserId - degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. - field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. - superField StudyTermsId Maybe - type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach - semester Int - 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 -StudyDegree -- Studienabschluss - key Int -- LMU-internal key - shorthand Text Maybe -- admin determined shorthand - name Text Maybe -- description given by LDAP - Primary key -- column key is used as actual DB row key - -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } - deriving Eq Show -StudyTerms -- Studiengang - key Int -- standardised key - shorthand Text Maybe -- admin determined shorthand - name Text Maybe -- description given by LDAP - defaultDegree StudyDegreeId Maybe - defaultType StudyFieldType Maybe - Primary key -- column key is used as actual DB row key - -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } - deriving Eq Ord Show -StudySubTerms - child StudyTermsId - parent StudyTermsId - UniqueStudySubTerms child parent -StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. - -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. - -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. - -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations - incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs - key Int -- a possible key for the studyTermName or studySubTermName - name Text -- studyTermName as plain text from LDAP - deriving Show Eq Ord -StudySubTermParentCandidate - incidence TermCandidateIncidence - key Int - parent Int - deriving Show Eq Ord -StudyTermStandaloneCandidate - incidence TermCandidateIncidence - key Int - deriving Show Eq Ord UserGroupMember group UserGroupName diff --git a/shell.nix b/shell.nix index 33411fdad..a6096242b 100644 --- a/shell.nix +++ b/shell.nix @@ -45,7 +45,7 @@ let pgSockDir=$(mktemp -d) pgLogFile=$(mktemp) initdb --no-locale -D ''${pgDir} - pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990" + pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms" export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} psql -f ${postgresSchema} postgres printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 1c8bd1e61..321f80691 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -343,7 +343,19 @@ upsertCampusUser upsertMode ldapData = do , Just defType <- studyTermsDefaultType -> do $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|] - (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester (Just now) now True) <$> assimilateSubTerms subterms unusedFeats + let sf = StudyFeatures + { studyFeaturesUser = userId + , studyFeaturesDegree = defDegree + , studyFeaturesField = subterm + , studyFeaturesSuperField = Nothing + , studyFeaturesType = defType + , studyFeaturesSemester = subSemester + , studyFeaturesFirstObserved = Just now + , studyFeaturesLastObserved = now + , studyFeaturesValid = True + , studyFeaturesRelevanceCached = False + } + (sf :) <$> assimilateSubTerms subterms unusedFeats Nothing | [] <- unusedFeats -> do $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] @@ -418,6 +430,8 @@ upsertCampusUser upsertMode ldapData = do ] associateUserSchoolsByTerms userId + cacheStudyFeatureRelevance $ \studyFeatures -> studyFeatures E.^. StudyFeaturesUser E.==. E.val userId + let userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools userAssociatedSchools' = do diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index f4d146d11..7a2b1c6cc 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -4,9 +4,11 @@ module Handler.Utils.StudyFeatures , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType , UserTableStudyFeatures(..) , _UserTableStudyFeatures - , isRelevantStudyFeature + , isRelevantStudyFeature, isRelevantStudyFeatureCached + , cacheStudyFeatureRelevance , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures + , isTermStudyFeature ) where import Import.NoFoundation @@ -24,6 +26,7 @@ import qualified Data.Set as Set import Data.RFC5051 (compareUnicode) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -109,8 +112,38 @@ isRelevantStudyFeature termField record studyFeatures E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1 E.&&. overlap studyFeatures' E.>. overlap studyFeatures +isRelevantStudyFeatureCached :: PersistEntity record + => EntityField record TermId + -> E.SqlExpr (Entity record) + -> E.SqlExpr (Entity StudyFeatures) + -> E.SqlExpr (E.Value Bool) +isRelevantStudyFeatureCached termField record studyFeatures + = E.bool calcNow useCache $ studyFeatures E.^. StudyFeaturesRelevanceCached + where + useCache + = E.exists . E.from $ \relevantStudyFeatures -> + E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesTerm E.==. record E.^. termField + E.&&. relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. studyFeatures E.^. StudyFeaturesId + calcNow = isRelevantStudyFeature termField record studyFeatures + +cacheStudyFeatureRelevance :: MonadIO m + => (E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)) + -> SqlPersistT m () +cacheStudyFeatureRelevance fFilter = do + E.insertSelectWithConflict UniqueRelevantStudyFeatures + ( E.from $ \(studyFeatures `E.InnerJoin` term) -> do + E.on E.true + E.where_ $ fFilter studyFeatures + E.where_ $ isRelevantStudyFeature TermId term studyFeatures + return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) + ) + ( \_current _excluded -> [] ) + E.update $ \studyFeatures -> do + E.set studyFeatures [ StudyFeaturesRelevanceCached E.=. E.true ] + E.where_ $ fFilter studyFeatures + isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isCourseStudyFeature = isRelevantStudyFeature CourseTerm +isCourseStudyFeature = isRelevantStudyFeatureCached CourseTerm courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures courseUserStudyFeatures cId uid = do @@ -130,7 +163,7 @@ courseUserStudyFeatures cId uid = do } isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isExternalExamStudyFeature = isRelevantStudyFeature ExternalExamTerm +isExternalExamStudyFeature = isRelevantStudyFeatureCached ExternalExamTerm externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures externalExamUserStudyFeatures eeId uid = do @@ -148,3 +181,6 @@ externalExamUserStudyFeatures eeId uid = do , userTableSemester = studyFeaturesSemester , userTableFieldType = studyFeaturesType } + +isTermStudyFeature :: E.SqlExpr (Entity Term) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isTermStudyFeature = isRelevantStudyFeatureCached TermId diff --git a/src/Handler/Utils/StudyFeatures/Parse.hs b/src/Handler/Utils/StudyFeatures/Parse.hs index 3001c258f..a0e749f86 100644 --- a/src/Handler/Utils/StudyFeatures/Parse.hs +++ b/src/Handler/Utils/StudyFeatures/Parse.hs @@ -43,6 +43,7 @@ pStudyFeatures studyFeaturesUser now = do studyFeaturesSuperField = Nothing studyFeaturesFirstObserved = Just now studyFeaturesLastObserved = now + studyFeaturesRelevanceCached = False return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 3d66fcace..73b6cacae 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -789,7 +789,7 @@ colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body 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 + E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid @@ -807,7 +807,7 @@ 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 + E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid @@ -826,7 +826,7 @@ fltrRelevantStudyFeaturesDegreeUI mPrev = 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 + E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index aad31a85b..358ed1746 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -491,6 +491,7 @@ fillDb = do (Just now) now True + False insert_ $ StudyFeatures maxMuster sdBsc @@ -501,6 +502,7 @@ fillDb = do (Just now) now True + False insert_ $ StudyFeatures tinaTester sdBsc @@ -511,6 +513,7 @@ fillDb = do (Just now) now False + False insert_ $ StudyFeatures tinaTester sdLAG @@ -521,6 +524,7 @@ fillDb = do (Just now) now True + False insert_ $ StudyFeatures tinaTester sdLAR @@ -531,6 +535,7 @@ fillDb = do (Just now) now True + False insert_ $ StudyFeatures tinaTester sdMst @@ -541,6 +546,7 @@ fillDb = do (Just now) now True + False -- FFP let nbrs :: [Int]