fraport/fradrive
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

87
src/Handler/Firm.hs
View File

@ -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|
<section>
<h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
_{MsgFirmAction}
_{MsgFirmAction}
<div>
<p>
_{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
<li>#{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 ])

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

@ -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 -> [] )

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 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!