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
2020-10-06 14:31:02 +02:00 · 2020-10-06 14:31:02 +02:00 · 33b02e9936
commit 33b02e9936
parent beef9ee6a6 564c0b975a
8 changed files with 124 additions and 58 deletions
--- a/models/study-features.model
+++ 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
+
--- 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
--- 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}
--- 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
--- 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
--- 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 '#'
--- 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
--- 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]