From 43dbe18110727b600613a7c83ebf2ae3fdd2ad49 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 16 Jun 2023 14:07:02 +0000 Subject: [PATCH] refactor(qualifications): idea how to work with blocks as a table (WIP) --- src/Handler/LMS.hs | 4 +-- src/Handler/Qualification.hs | 42 +++++++++++++++++++++++++----- src/Handler/Utils/Qualification.hs | 19 +++++++++++++- 3 files changed, 55 insertions(+), 10 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b7638b482..b08c16cce 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9ce89fc8e..9f76a6c1e 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -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) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index bffbad258..af3b1fd75 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 =