fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(firm): improve efficiency of foreign supervisor filter

Browse Source
This commit is contained in:
Steffen Jost 2023-12-13 16:25:11 +01:00
parent ce45d26a21
commit f36f234c42
3 changed files with 100 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/Handler/Firm.hs
View File

@ -248,7 +248,7 @@ addDefaultSupervisors cid employees = do
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
E.&&. spr E.^. UserCompanySupervisor E.&&. spr E.^. UserCompanySupervisor
return $ UserSupervisor E.distinct $ return $ UserSupervisor
E.<# (spr E.^. UserCompanyUser) E.<# (spr E.^. UserCompanyUser)
E.<&> usr E.<&> usr
E.<&> (spr E.^. UserCompanySupervisorReroute) E.<&> (spr E.^. UserCompanySupervisorReroute)
@ -272,7 +272,7 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
, spr E.^. UserCompanyCompany `E.in_` E.vals cids , 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.<# (spr E.^. UserCompanyUser)
E.<&> (usr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute) E.<&> (spr E.^. UserCompanySupervisorReroute)
@ -291,7 +291,7 @@ addDefaultSupervisorsAll mutualSupervision cids = do
, spr E.^. UserCompanyCompany `E.in_` E.vals cids , 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.<# (spr E.^. UserCompanyUser)
E.<&> (usr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser)
E.<&> (spr E.^. UserCompanySupervisorReroute) E.<&> (spr E.^. UserCompanySupervisorReroute)
@ -541,7 +541,7 @@ mkFirmAllTable isAdmin uid = do
usr <- E.from $ E.table @User usr <- E.from $ E.table @User
E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) -- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
) E.&&. (E.exists (do ) E.&&. (E.exists (do
usrCmp <- E.from $ E.table @UserCompany usrCmp <- E.from $ E.table @UserCompany
E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
@ -549,7 +549,7 @@ mkFirmAllTable isAdmin uid = do
E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
) E.||. E.exists (do ) E.||. E.exists (do
usrSpr <- E.from $ E.table @UserSupervisor 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 E.&&. E.exists (do
usrSub <- E.from $ E.table @UserCompany usrSub <- E.from $ E.table @UserCompany
E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser 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 , single ("is-supervisor2" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User usr <- 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.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val 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
E.||. E.exists (do usrCmp <- E.from $ E.table @UserCompany
(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_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId E.&&. (( usrCmp E.^. UserCompanySupervisor
E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId 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 , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User (usr :& usrCmp) <- E.from $ E.table @User
`E.innerJoin` E.table @UserCompany `E.innerJoin` E.table @UserCompany
@ -618,9 +635,9 @@ mkFirmAllTable isAdmin uid = do
[ fltrCompanyNameUI mPrev [ fltrCompanyNameUI mPrev
, prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo)
, prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) , 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-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 "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) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern)
] ]

2
src/Handler/Utils/StudyFeatures.hs
View File

@ -137,7 +137,7 @@ cacheStudyFeatureRelevance fFilter = do
E.on E.true E.on E.true
E.where_ $ fFilter studyFeatures E.where_ $ fFilter studyFeatures
E.where_ $ isRelevantStudyFeature (E.val now) TermId term 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 -> [] ) ( \_current _excluded -> [] )

62
test/Database/Fill.hs
View File

@ -11,8 +11,9 @@ import "uniworx" Import hiding (Option(..), currentYear)
import qualified Data.Text.Encoding as TEnc import qualified Data.Text.Encoding as TEnc
import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Yesod.Auth.Util.PasswordStore as PWStore
import qualified Data.Set as Set import qualified Data.List as List
import qualified Data.Map as Map import qualified Data.Set as Set
import qualified Data.Map as Map
import Utils.Holidays import Utils.Holidays
@ -494,6 +495,15 @@ fillDb = do
, "Mark", "Paul", "Steven", "Andrew" , "Mark", "Paul", "Steven", "Andrew"
, "Kenneth", "Joshua", "George", "Kevin" , "Kenneth", "Joshua", "George", "Kevin"
, "Brian", "Edward", "Susan", "Ronald" , "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" surnames = [ "Smith", "Johnson", "Williams", "Brown"
, "Jones", "Miller", "Davis", "Garcia" , "Jones", "Miller", "Davis", "Garcia"
@ -503,15 +513,17 @@ fillDb = do
, "Lopez", "Lee", "Gonzalez", "Harris" , "Lopez", "Lee", "Gonzalez", "Harris"
, "Clark", "Lewis", "Robinson", "Walker" , "Clark", "Lewis", "Robinson", "Walker"
, "Perez", "Hall", "Young", "Allen" , "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" ] middlenames = [ Nothing, Just "Jamesson", Just "Theresa", Just "Ally", Just "Tiberius", Just "Maria" ]
toMatrikel :: [Int] -> [Text]
toMatrikel ns
| (cs, rest) <- splitAt 8 ns
, length cs == 8
= foldMap tshow cs : toMatrikel rest
| otherwise
= []
manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
{ userIdent { userIdent
, userAuthentication = AuthLDAP , userAuthentication = AuthLDAP
@ -571,8 +583,16 @@ fillDb = do
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
"Jackson" -> "" "Jackson" -> ""
_ -> userIdent _ -> userIdent
-- toMatrikel :: [Int] -> [Text]
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) -- 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 manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] 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" 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 bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing
_noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True 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 jost fraportAg True True
void . insert' $ UserCompany svaupel nice True False void . insert' $ UserCompany svaupel nice True False
void . insert' $ UserCompany gkleen nice False 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 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 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 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 gkleen True
-- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost svaupel False
-- void . insert' $ UserSupervisor jost sbarth False -- void . insert' $ UserSupervisor jost sbarth False
@ -661,9 +693,9 @@ fillDb = do
, UserSupervisor gkleen gkleen True , UserSupervisor gkleen gkleen True
, UserSupervisor tinaTester tinaTester False , UserSupervisor tinaTester tinaTester False
] ]
++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] ++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost]
++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] ++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ]
++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]
upsertManyWhere supvs [] [] [] upsertManyWhere supvs [] [] []
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error! -- insertMany_ supvs -- NOTE: multiple calls like this throw an error!