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

fix(firm): improve supervisor filter by caching

Browse Source
This commit is contained in:
Steffen Jost 2023-12-19 18:15:09 +01:00
parent dd5d283f88
commit 88f24fe6f1
3 changed files with 92 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Database/Esqueleto/Utils.hs
View File

@ -227,8 +227,13 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare
) )
and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
and = F.foldl' (E.&&.) true -- we can use foldl' since Postgresql reorders conditions anyway -- and = F.foldl' (E.&&.) true -- we can use foldl' since PostgreSQL reorders conditions anyway
or = F.foldl' (E.||.) false -- or = F.foldl' (E.||.) false
-- Maybe this help the PostgreSQL query optimizer, though I doubt it?
and f | F.null f = true
| otherwise = F.foldl1 (E.&&.) f
or f | F.null f = false
| otherwise = F.foldl1 (E.||.) f
-- | Given a test and a set of values, check whether anyone succeeds the test -- | Given a test and a set of values, check whether anyone succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)

123
src/Handler/Firm.hs
View File

@ -468,7 +468,7 @@ mkFirmAllTable isAdmin uid = do
-- , cmpy & firmCountActiveReroutes' -- 10 -- , cmpy & firmCountActiveReroutes' -- 10
) )
dbtRowKey = (E.^. CompanyId) dbtRowKey = (E.^. CompanyId)
dbtProj = dbtProjId dbtProj = dbtProjFilteredPostId
dbtColonnade = formColonnade $ mconcat dbtColonnade = formColonnade $ mconcat
[ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
, sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
@ -518,7 +518,7 @@ mkFirmAllTable isAdmin uid = do
) )
) )
-- THIS WAS WAY TOO SLOW: -- THIS WAS WAY TOO SLOW:
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- (usr :& usrCmp) <- E.from $ E.table @User -- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany -- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
@ -537,45 +537,90 @@ mkFirmAllTable isAdmin uid = do
-- ) -- )
-- ) -- )
-- ) -- )
, single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
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
E.&&. usrCmp E.^. UserCompanySupervisor -- E.&&. usrCmp E.^. UserCompanySupervisor
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_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor -- 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
E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId -- E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
) -- )
) -- )
) -- )
-- )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- 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
-- 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 $ \row (getLast -> criterion) ->
case criterion of
Nothing -> E.true
(Just (crit::Text)) -> E.exists $ do
usr <- E.from $ E.table @User
E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val crit)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit)
) 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-supervisor2" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do , single ("is-supervisor0", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
usr <- E.from $ E.table @User case criterion of
E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) Nothing -> return True :: DB Bool
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) (Just (crit::Text)) -> do
-- E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) critFirms <- memcachedBy (Just . Right $ 15 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do
) E.&&. E.exists (do (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company
usrCmp <- E.from $ E.table @UserCompany `E.on` (\(usr :& cmp) -> E.exists (do
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId usrCmp <- E.from $ E.table @UserCompany
E.&&. (( usrCmp E.^. UserCompanySupervisor E.where_ $ usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId E.&&. (( usrCmp E.^. UserCompanySupervisor
) E.||. E.exists (do E.&&. usrCmp E.^. UserCompanyUser E.==. usr E.^. UserId
usrSpr <- E.from $ E.table @UserSupervisor ) E.||. E.exists (do
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser usrSpr <- E.from $ E.table @UserSupervisor
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
))
)) ))
) E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit)
E.orderBy [E.asc $ cmp E.^. CompanyId]
return $ cmp E.^. CompanyId
let cid = dbr ^. resultAllCompanyEntity . _entityKey
return $ Set.member cid critFirms
) )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- (usr :& usrCmp) <- E.from $ E.table @User -- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany -- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
@ -636,8 +681,8 @@ mkFirmAllTable isAdmin uid = do
, 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-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault)
, prismAForm (singletonFilter "is-supervisor0") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , 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/Table/Pagination.hs
View File

@ -769,7 +769,7 @@ dbtProjFilteredPostId :: forall fs r r'.
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjFilteredPostId = withFilteredPost dbtProjId' dbtProjFilteredPostId = withFilteredPost dbtProjId'
-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern -- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergebniszeilen in Haskell transformieren und filtern
dbtProjFilteredPostSimple :: forall fs r r' r''. dbtProjFilteredPostSimple :: forall fs r r' r''.
( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' ) ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
=> (r -> DB r'') => (r -> DB r'')