From f36f234c423ae006eb81c5e1afd0b4a44495e357 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 13 Dec 2023 16:25:11 +0100 Subject: [PATCH] chore(firm): improve efficiency of foreign supervisor filter --- src/Handler/Firm.hs | 87 ++++++++++++++++++------------ src/Handler/Utils/StudyFeatures.hs | 2 +- test/Database/Fill.hs | 62 +++++++++++++++------ 3 files changed, 100 insertions(+), 51 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index b50539d87..8b8911df4 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR , postFirmAllR + ( getFirmAllR , postFirmAllR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR , getFirmCommR , postFirmCommR @@ -127,7 +127,7 @@ firmActionHandler route isAdmin = flip formResult faHandler faHandler (FirmActResetSupervisionData{..}, fids) = do madId <- bool maybeAuthId (return Nothing) isAdmin - let suprFltr = if + let suprFltr = if | isAdmin -> const E.true | (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId | otherwise -> const E.false @@ -214,7 +214,7 @@ runFirmActionFormPost cid route isAdmin acts = do return [whamlet|

- _{MsgFirmAction} + _{MsgFirmAction}

_{MsgFirmActionInfo} @@ -248,14 +248,14 @@ addDefaultSupervisors cid employees = do (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid E.&&. spr E.^. UserCompanySupervisor - return $ UserSupervisor + E.distinct $ return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> usr E.<&> (spr E.^. UserCompanySupervisorReroute) ) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) --- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor @@ -263,16 +263,16 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) E.where_ $ E.and $ guardMonoid (not mutualSupervision) [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do superv <- E.from $ E.table @UserSupervisor E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser ]) <> [ spr E.^. UserCompanySupervisor , spr E.^. UserCompanyCompany `E.in_` E.vals cids - , usr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids ] - return $ UserSupervisor + E.distinct $ return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) E.<&> (spr E.^. UserCompanySupervisorReroute) @@ -291,7 +291,7 @@ addDefaultSupervisorsAll mutualSupervision cids = do , spr E.^. UserCompanyCompany `E.in_` E.vals cids , usr E.^. UserCompanyCompany `E.in_` E.vals cids ] - return $ UserSupervisor + E.distinct $ return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) E.<&> (spr E.^. UserCompanySupervisorReroute) @@ -541,15 +541,15 @@ mkFirmAllTable isAdmin uid = do usr <- E.from $ E.table @User E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) - E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) - ) E.&&. (E.exists (do + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. (E.exists (do usrCmp <- E.from $ E.table @UserCompany E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.&&. usrCmp E.^. UserCompanySupervisor E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - ) E.||. E.exists (do + ) E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor E.&&. E.exists (do usrSub <- E.from $ E.table @UserCompany E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser @@ -559,20 +559,37 @@ mkFirmAllTable isAdmin uid = do ) ) , single ("is-supervisor2" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do - (usr :& usrCmp) <- E.from $ E.table @User - `E.leftJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) + usr <- E.from $ E.table @User E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) - E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) - ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) - E.||. E.exists (do - (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser) - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - ) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. E.exists (do + usrCmp <- E.from $ E.table @UserCompany + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. (( usrCmp E.^. UserCompanySupervisor + E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId + ) E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + )) ) ) + -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + -- (usr :& usrCmp) <- E.from $ E.table @User + -- `E.leftJoin` E.table @UserCompany + -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) + -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + -- ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + -- E.||. E.exists (do + -- (usrSpr :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==. usrSub E.^. UserCompanyUser) + -- E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + -- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- ) + -- ) + -- ) , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany @@ -618,9 +635,9 @@ mkFirmAllTable isAdmin uid = do [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) - , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) - , prismAForm (singletonFilter "is-supervisor2") mPrev $ aopt textField (fslI MsgTableSupervisor) -- TODO: remove either one variant which works worse , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-supervisor2") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] @@ -681,7 +698,7 @@ data FirmUserAction = FirmUserActNotify nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id -data FirmUserActionData = FirmUserActNotifyData +data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool @@ -746,7 +763,7 @@ mkFirmUserTable isAdmin cid = do ] rawSupers <- E.select $ do - (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany + (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) @@ -755,7 +772,7 @@ mkFirmUserTable isAdmin cid = do -- supervisorField :: Field Handler UserId -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers - + fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -902,7 +919,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- checkAdmin + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -961,12 +978,12 @@ postFirmUsersR fsh = do

  • #{usr} |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) - delSupers <- runDB - $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep + delSupers <- runDB + $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing @@ -1003,7 +1020,7 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData - | FirmSuperActSwitchSuperData + | FirmSuperActSwitchSuperData { firmSuperActSwitchSuper :: Maybe Bool , firmSuperActSwitchReroute :: Maybe Bool } @@ -1169,7 +1186,7 @@ postFirmSupersR fsh = do (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - <*> if firmSuperActRMSuperActive /= Just True + <*> if firmSuperActRMSuperActive /= Just True then return 0 else E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor @@ -1182,7 +1199,7 @@ postFirmSupersR fsh = do addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do - let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of + let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of (Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ]) (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer] , [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ]) diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 1bc5baba8..8aa191153 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -137,7 +137,7 @@ cacheStudyFeatureRelevance fFilter = do E.on E.true E.where_ $ fFilter studyFeatures E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures - return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) + E.distinct $ return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) ) ( \_current _excluded -> [] ) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 19f424fc8..c1c657912 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -11,8 +11,9 @@ import "uniworx" Import hiding (Option(..), currentYear) import qualified Data.Text.Encoding as TEnc import qualified Yesod.Auth.Util.PasswordStore as PWStore -import qualified Data.Set as Set -import qualified Data.Map as Map +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Map as Map import Utils.Holidays @@ -494,6 +495,15 @@ fillDb = do , "Mark", "Paul", "Steven", "Andrew" , "Kenneth", "Joshua", "George", "Kevin" , "Brian", "Edward", "Susan", "Ronald" + , "Nico", "Pascal", "Danielle", "Brendon" + , "Winston", "Luke", "Jeff", "Ben" + , "Asis", "Janika", "Claudio", "Frank" + , "Anna", "Ivo", "Merlin", "Fabienne" + , "Angela", "Alissa", "Fredrik", "Sharlee" + , "René", "Tuval", "Dom", "Fabian" + , "Steve", "Bruce", "Adrian", "Nicko" + , "Joakim", "Ylva", "Mats", "Emil" + , "Angus", "Seeb", "Thalia", "Manu" ] surnames = [ "Smith", "Johnson", "Williams", "Brown" , "Jones", "Miller", "Davis", "Garcia" @@ -503,15 +513,17 @@ fillDb = do , "Lopez", "Lee", "Gonzalez", "Harris" , "Clark", "Lewis", "Robinson", "Walker" , "Perez", "Hall", "Young", "Allen" + , "Loomis", "Amott", "Gluz", "Erlandsson" + , "Glanzmann", "Murphy", "Henzi", "Sutter" + , "Nasseri", "Wolf", "Quarta", "Fuhrmann" + , "McCall", "Kilpatrick", "Ling", "Gordon" + , "Sallach", "Ratajczak", "Friedrich", "Schillo" + , "Völkl", "Dahn", "Berthiaume", "Crey" + , "Murray", "Dickinson", "McBrain", "Gers" + , "Nilsson", "Eriksson", "Fehrm", "Grahn" + , "Winkler", "Levermann", "Bellazecca", "Lotter" ] - middlenames = [ Nothing, Just "Jamesson" ] - toMatrikel :: [Int] -> [Text] - toMatrikel ns - | (cs, rest) <- splitAt 8 ns - , length cs == 8 - = foldMap tshow cs : toMatrikel rest - | otherwise - = [] + middlenames = [ Nothing, Just "Jamesson", Just "Theresa", Just "Ally", Just "Tiberius", Just "Maria" ] manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User { userIdent , userAuthentication = AuthLDAP @@ -571,8 +583,16 @@ fillDb = do "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" "Jackson" -> "" _ -> userIdent - - matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) + -- toMatrikel :: [Int] -> [Text] + -- toMatrikel ns + -- | (cs, rest) <- splitAt 10 ns + -- , length cs == 10 + -- = foldMap tshow cs : toMatrikel rest + -- | otherwise + -- = [] + -- matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) + baseMatrikel <- getRandomR (10000 :: Int, 999999 :: Int) + let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699] manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] @@ -630,6 +650,11 @@ fillDb = do ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com" bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing + randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing | n <- [1001..2002] + , let neven = even n + , let rcName = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n) + , let rcShort = CI.mk $ "RC" <> tshow n + ] void . insert' $ UserCompany jost fraportAg True True void . insert' $ UserCompany svaupel nice True False void . insert' $ UserCompany gkleen nice False False @@ -642,6 +667,13 @@ fillDb = do insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] + insertMany_ [UserCompany uid rckey issuper False + | rckey <- randComps + , Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey] + , Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers + , uSurname /= "Jackson", uSurname /= "Lee" + , let issuper = uSurname == "Wolf" + ] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost sbarth False @@ -661,9 +693,9 @@ fillDb = do , UserSupervisor gkleen gkleen True , UserSupervisor tinaTester tinaTester False ] - ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] - ++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] - ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] + ++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] + ++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ] + ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ] upsertManyWhere supvs [] [] [] -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!