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

refactor(firm): messaging performance

Browse Source
This commit is contained in:
Steffen Jost 2023-11-21 13:33:12 +01:00
parent 0f9a7a8c53
commit b7d6474ace
2 changed files with 40 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
src/Handler/Firm.hs
View File

@ -1006,56 +1006,42 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR)
handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html
handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."]
handleFirmCommR ultDest cs = do
let csKey = CompanyKey <$> cs
-- get employees of chosen companies
empys <- E.unValue <<$>> runDB (E.select $ do
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey
return $ emp E.^. UserId
)
-- get supervisors of employees
sprs <- E.unValue <<$>> runDB (E.select $ do
spr <- E.from $ E.table @User
E.where_ $ E.exists $ do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
return $ spr E.^. UserId
)
-- get companies of all supervisors
sprCmpys <- E.unValue <<$>> runDB (E.select $ do
cmpy <- E.from $ E.table @Company
E.where_ $ E.exists $ do
usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs
return $ cmpy E.^.CompanyId
)
let
queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation
queryLoners = do
spr <- E.from $ E.table @User
E.where_ $ spr E.^. UserId `E.in_` E.valList empys
E.&&. E.notExists (do
sprCmp <- E.from $ E.table @UserCompany
E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId
)
return spr
queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
queryCmpy sORe acid = do
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid
E.&&. (if sORe
then -- supervisors only
E.exists $ do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
else E.true
)
queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds
queryGiven usrs = do
usr <- E.from $ E.table @User
E.where_ $ usr E.^. UserId `E.in_` E.valList usrs
return usr
mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId]
mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l]
toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey)
csKeys = CompanyKey <$> cs
mbUser <- maybeAuthId
-- get employees of chosen companies
empys <- mkCompanyUsrList <$> runDB (E.select $ do
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
)
-- get supervisors of employees
--sprs <- mkCompanyUsrList <$> runDB (E.select $ do
sprs' <- runDB (E.select $ do
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
E.||. (spr E.^. UserId E.=?. E.val mbUser)
E.||. E.exists (do
usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys)
)
E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany]
return (cmp E.?. UserCompanyCompany, spr E.^. UserId)
)
$logInfoS "Firm" "!!!Messaging here!!!"
unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!!
let sprs = mkCompanyUsrList sprs'
commR CommunicationRoute
{ crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification }
, crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle }
@ -1063,10 +1049,9 @@ handleFirmCommR ultDest cs = do
, crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++
(RGFirmIndependent, queryLoners) :
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ]
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
[(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++
[(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ]
}
{- Auswahlbox für Mitteilung:

3
src/Utils.hs
View File

@ -771,6 +771,9 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
pattern NonEmpty x xs = x :| xs
{-# COMPLETE NonEmpty #-}
checkAsc :: Ord a => [a] -> Bool
checkAsc (x:r@(y:_)) = x<=y && checkAsc r
checkAsc _ = True
----------
-- Sets --