From a373abad26141f2ec82615a5c33c0768ef7625a2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 16 Apr 2024 12:56:03 +0200 Subject: [PATCH] refactor(avs): safe old card-no to perform pdf pin pass updates --- models/avs.model | 1 + src/Handler/Utils/Avs.hs | 70 ++++++++++++++++++++++------------------ src/Model/Types/Avs.hs | 10 ++++-- test/Database/Fill.hs | 14 ++++---- 4 files changed, 54 insertions(+), 41 deletions(-) diff --git a/models/avs.model b/models/avs.model index 30e5e8ea8..4871d7615 100644 --- a/models/avs.model +++ b/models/avs.model @@ -21,6 +21,7 @@ UserAvs lastSynchError Text Maybe lastPersonInfo AvsPersonInfo Maybe -- just to discern field changes lastFirmInfo AvsFirmInfo Maybe -- just to discern field changes + lastCardNo AvsFullCardNo Maybe -- just to discern changes UniqueUserAvsUser user UniqueUserAvsId personId deriving Generic Show diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2fbb57d46..accd090c1 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -201,14 +201,14 @@ upsertAvsUserById api = do $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] case candidates of - [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing) -- TODO info + [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing Nothing) -- TODO info (_:_) -> throwM $ AvsUserAmbiguous api [] -> do upsRes :: Either SomeException (Entity User) <- try $ ldapLookupAndUpsert persNo $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing -- pin/addr are updated in next step anyway -- TODO info + Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing Nothing -- pin/addr are updated in next step anyway -- TODO info Left err -> do $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err return mbuid -- == Nothing -- user could not be created somehow @@ -248,7 +248,7 @@ upsertAvsUserById api = do } mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do - insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing Nothing Nothing -- TODO info + insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing Nothing Nothing Nothing -- TODO info forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] -- forM_ cs $ -- only save used cards for the postal address update detection @@ -434,7 +434,10 @@ queryAvsPrimaryCard api = runMaybeT $ do AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus - + +queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo) +queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard + -- | Queries AVS to retrieve pin generated from primary card no queryAvsPin :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe Text) queryAvsPin = fmap (fmap personCard2pin) . queryAvsPrimaryCard @@ -529,36 +532,41 @@ updateAvsUserByIds apids0 = do return res where procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do - (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid - let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here - let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here + (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid let usrId = userAvsUser usravs usr <- MaybeT $ get usrId - now <- liftIO getCurrentTime - let per_ups = mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo) -- NOTE: Updates erfolgen nur, wenn der Alt-Wert identisch zu Aktuellem-Wert sind! Bei mehreren Update-Möglichkeiten für ein Feld kann nur eines zutreffen. - [ CheckAvsUpdate UserFirstName _avsInfoFirstName - , CheckAvsUpdate UserSurname _avsInfoLastName - , CheckAvsUpdate UserDisplayName _avsInfoDisplayName - , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth - , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo - , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo - ] - em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo $ - CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User - em_f_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. - CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI - eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type - frm_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, - CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead - usr_up1 = eml_up `mcons` (frm_up `mcons` per_ups) - avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` - [ UserAvsLastSynch =. now - , UserAvsLastSynchError =. Nothing - , UserAvsLastPersonInfo =. Just newAvsPersonInfo - , UserAvsLastFirmInfo =. Just newAvsFirmInfo - ] lift $ do -- maybeT no longer needed from here onwards + newAvsCardNo <- queryAvsFullCardNo apid -- We must not abort entire synch when receiving `Nothing` here, hence no MaybeT here + now <- liftIO getCurrentTime + let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here + oldAvsFirmInfo = userAvsLastFirmInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here + oldAvsCardNo = userAvsLastCardNo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here + per_ups = mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo) -- NOTE: Updates erfolgen nur, wenn der Alt-Wert identisch zu Aktuellem-Wert sind! Bei mehreren Update-Möglichkeiten für ein Feld kann nur eines zutreffen. + [ CheckAvsUpdate UserFirstName _avsInfoFirstName + , CheckAvsUpdate UserSurname _avsInfoLastName + , CheckAvsUpdate UserDisplayName _avsInfoDisplayName + , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth + , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo + , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` + , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + ] + em_p_up = mkUpdate usr newAvsPersonInfo oldAvsPersonInfo $ + CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User + em_f_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. + CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI + eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type + frm_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, + CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead + pin_up = mkUpdate usr newAvsCardNo (Just oldAvsCardNo) $ -- Maybe update PDF pin to latest card + CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just + usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups)) + avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` + [ UserAvsLastSynch =. now + , UserAvsLastSynchError =. Nothing + , UserAvsLastPersonInfo =. Just newAvsPersonInfo + , UserAvsLastFirmInfo =. Just newAvsFirmInfo + , UserAvsLastCardNo =. newAvsCardNo + ] -- update company association & supervision Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 6168c52cb..7617aef89 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -413,12 +413,16 @@ derivePersistFieldJSON ''AvsDataPersonCard getFullCardNo :: AvsDataPersonCard -> AvsFullCardNo getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo avsDataCardNo avsDataVersionNo +avsFullCardNo2pin :: AvsFullCardNo -> Text +avsFullCardNo2pin = Text.dropWhile ('0'==) . tshowAvsFullCardNo + -- | like `tshowAvsFullCardNo` but without leading zeroes for use as pdf pin personCard2pin :: AvsDataPersonCard -> Text -personCard2pin = Text.dropWhile ('0'==) . tshowAvsFullCardNo . getFullCardNo +personCard2pin = avsFullCardNo2pin . getFullCardNo -personCards2pin :: Set AvsDataPersonCard -> Maybe Text -personCards2pin = fmap personCard2pin . Set.lookupMax +-- DEPRECATED, use Handler.Utils.Avs.queryAvsPin instead +-- personCards2pin :: Set AvsDataPersonCard -> Maybe Text +-- personCards2pin = fmap personCard2pin . Set.lookupMax data AvsStatusPerson = AvsStatusPerson { avsStatusPersonID :: AvsPersonId diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 0b85772af..c8f8e2758 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -595,7 +595,7 @@ fillDb = do let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699] manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] - insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing Nothing Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] + insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing Nothing Nothing Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] let tmin = -1 tmax = 2 @@ -723,12 +723,12 @@ fillDb = do void . insert' $ UserSchool uid mi False for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False - void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing 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.|]