From 4161c92d12d7a4b087e7708f6680e1f49b3ce8e4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 May 2023 09:59:52 +0000 Subject: [PATCH] chore(avs): drop avs card no uniqueness and attempt to fix filtering --- models/avs.model | 2 +- src/Handler/LMS.hs | 12 ++++++------ src/Handler/Qualification.hs | 21 +++++++++++++++------ src/Handler/Utils/Avs.hs | 25 +++++++++++++++---------- test/Database/Fill.hs | 8 ++++---- 5 files changed, 41 insertions(+), 27 deletions(-) diff --git a/models/avs.model b/models/avs.model index 45f2321d7..4f495bd25 100644 --- a/models/avs.model +++ b/models/avs.model @@ -29,5 +29,5 @@ UserAvsCard cardNo AvsFullCardNo card AvsDataPersonCard lastSynch UTCTime - UniqueAvsCard cardNo + -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons deriving Generic diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 1b2107632..1499ebb1d 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -439,13 +439,13 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + Nothing -> E.false + Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId - E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId - E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) - `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) - ) + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + ) , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6ddeb3dde..dcbb42508 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -358,17 +358,26 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) - , single ("avs-card" , FilterColumn . E.mkExistsFilter $ \row criterion -> - E.from $ \(usrAvs `E.InnerJoin` avsCard) -> do + , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + Nothing -> E.false + Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId - E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId - E.&&. ((E.explicitUnsafeCoerceSqlExprValue "citext" (avsCard E.^. UserAvsCardCardNo) :: E.SqlExpr (E.Value (CI Text))) - `E.hasInfix` (E.val criterion :: E.SqlExpr (E.Value (CI Text)))) - ) + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + ) , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) + , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + E.from $ \(usrComp `E.InnerJoin` comp) -> do + let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` + (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) + testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId + testcrit = maybe testname testnumber $ readMay $ CI.original criterion + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit + ) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b3e3dfd8f..3a6083fae 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -339,12 +339,16 @@ guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoT _ -> return Nothing guessAvsUser someid = do let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard - extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid - extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid case discernAvsCardPersonalNo someid of - Just cid@(Left cardNo) -> - maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ - maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo + Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid + -- NOTE: card validity might be outdated, so we must always check with avs + -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do + -- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid + -- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid + -- cards <- selectList [UserAvsCardCardNo ==. cardNo] [] + -- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of + -- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard) + -- _ -> return Nothing Just cid@(Right _wholeNumber) -> maybeUpsertAvsUserByCard cid >>= \case Nothing -> @@ -493,15 +497,16 @@ upsertAvsUserById api = do [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany userFirmAddr - forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard + forM_ avsPersonPersonCards $ \aCard -> do + let fcn = getFullCardNo aCard + -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused + deleteWhere [UserAvsCardCardNo ==. fcn] + insert_ $ UserAvsCard { userAvsCardPersonId = api - , userAvsCardCardNo = getFullCardNo aCard + , userAvsCardCardNo = fcn , userAvsCardCard = aCard , userAvsCardLastSynch = now } - [ UserAvsCardCard =. aCard - , UserAvsCardLastSynch =. now - ] return $ Just uid diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8d34c713b..d165ed9fc 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -680,10 +680,10 @@ fillDb = do void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 - void . insert' $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now - void . insert' $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now - void . insert' $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now - void . insert' $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now + insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now + insert_ $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now + insert_ $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now + insert_ $ UserAvsCard (AvsPersonId 4) (AvsFullCardNo (AvsCardNo "9999") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "9999") "4") now let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]