refactor(qualifications): idea how to work with blocks as a table (WIP)
This commit is contained in:
parent
a0295c7654
commit
43dbe18110
@ -355,8 +355,8 @@ lmsTableQuery :: QualificationId -> LmsTableExpr
|
||||
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do
|
||||
-- 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;
|
||||
-- - using noExsists on printJob join condition works, but only deliver single value;
|
||||
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
|
||||
-- - 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 subqueries to learn whether the request was indeed the latest
|
||||
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
|
||||
|
||||
@ -27,6 +27,7 @@ import qualified Data.Text as T
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Conduit.List as C
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
@ -209,19 +210,22 @@ instance CsvColumnsExplained QualificationTableCsv where
|
||||
|
||||
type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||
`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 = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
|
||||
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
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 = $(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 = _dbrOutput . _1
|
||||
@ -235,6 +239,9 @@ resultLmsUser = _dbrOutput . _3 . _Just
|
||||
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
|
||||
resultCompanyUser = _dbrOutput . _4
|
||||
|
||||
resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
|
||||
resultQualBlock = _dbrOutput . _5 . _Just
|
||||
|
||||
|
||||
instance HasEntity QualificationTableData User where
|
||||
hasEntity = resultUser
|
||||
@ -293,16 +300,37 @@ blockActRemoveSupervisors QualificationActBlockSupervisorData = True
|
||||
blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res
|
||||
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
|
||||
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
||||
, E.SqlExpr (Entity User)
|
||||
, 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.&&. 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)
|
||||
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)
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
-- 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 nowaday = \qualUser ->
|
||||
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
,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' nowaday qualUser =
|
||||
|
||||
Loading…
Reference in New Issue
Block a user