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

refactor(qualifications): idea how to work with blocks as a table (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2023-06-16 14:07:02 +00:00
parent a0295c7654
commit 43dbe18110
3 changed files with 55 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Handler/LMS.hs
View File

@ -355,8 +355,8 @@ lmsTableQuery :: QualificationId -> LmsTableExpr
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do
-- RECALL: another outer join on PrintJob did not work out well, since -- RECALL: another outer join on PrintJob did not work out well, since
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- - using noExsists on printJob join condition works, but only deliver single value; -- - using notExists on printJob join condition works, but only deliver single value, aggregation can deliver all;
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest -- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest
E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser
E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser

42
src/Handler/Qualification.hs
View File

@ -27,6 +27,7 @@ import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Database.Persist.Sql (updateWhereCount) import Database.Persist.Sql (updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.PostgreSQL as E
@ -209,19 +210,22 @@ instance CsvColumnsExplained QualificationTableCsv where
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2) queryLmsUser = $(sqlLOJproj 3 2)
queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 3 3)
type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany], Maybe (Entity LmsUser))
resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -235,6 +239,9 @@ resultLmsUser = _dbrOutput . _3 . _Just
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _4 resultCompanyUser = _dbrOutput . _4
resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _5 . _Just
instance HasEntity QualificationTableData User where instance HasEntity QualificationTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -293,16 +300,37 @@ blockActRemoveSupervisors QualificationActBlockSupervisorData = True
blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res
blockActRemoveSupervisors _ = False blockActRemoveSupervisors _ = False
-- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
-- , E.SqlExpr (Entity User)
-- , E.SqlExpr (Maybe (Entity LmsUser))
-- )
-- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do
-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
-- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-- return (qualUser, user, lmsUser)
qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
) )
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
--
E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
E.&&. E.notExists (E.from $ \earlierBlock ->
E.where_ $ earlierBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId
E.&&. earlierBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom
)
return (qualUser, user, lmsUser) return (qualUser, user, lmsUser)

19
src/Handler/Utils/Qualification.hs
View File

@ -33,11 +33,28 @@ isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualifica
------------------ ------------------
-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date -- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
-- validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
-- validQualification nowaday = \qualUser ->
-- (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
-- ,qualUser E.^. QualificationUserValidUntil)) -- currently valid
-- E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification nowaday = \qualUser -> validQualification nowaday = \qualUser ->
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
,qualUser E.^. QualificationUserValidUntil)) -- currently valid ,qualUser E.^. QualificationUserValidUntil)) -- currently valid
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked E.&&. (E.notExists $ E.from $ \qualUserBlock -> do
E.where_ $ E.not (qualUserBlock E.^. QualificationUserBlockUnblock)
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
E.&&. qualUserBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId
E.&&. E.notExists $ E.from $ \qualUserUnblock -> do
E.where_ (qualUserUnblock E.^. QualificationUserBlockUnblock)
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val nowaday
E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom
E.&&. qualUserUnBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId
)
validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
validQualification' nowaday qualUser = validQualification' nowaday qualUser =