Merge branch '642-schlechte-performance-auf-prufungen' into 'master'

feat(study-features): cache study features term relevance

Closes #642

See merge request uni2work/uni2work!30

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
+

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

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}

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

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

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 '#'

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

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]