fix(avs): several minor bugfixes
- See notes in #158 for details on update change policy - fieldLensVal was not working - create index for deleted table prevented start - some hlint errors
This commit is contained in:
parent
4f8850b3b4
commit
a52c8a6ad7
@ -165,14 +165,6 @@ updateReceivers uid = do
|
||||
------------------
|
||||
-- CR3 Functions
|
||||
|
||||
--
|
||||
-- DONE Update UserCompany too
|
||||
-- DONE #124 Add an old default supervisor to an Admin TODO-List
|
||||
-- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
|
||||
-- DONE #36 "company postal preference", but for updates only yet
|
||||
--
|
||||
-- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
|
||||
-- DONE: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
|
||||
|
||||
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
|
||||
class SomeAvsQuery q where
|
||||
@ -291,31 +283,36 @@ data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => Chec
|
||||
-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
|
||||
-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
|
||||
mkUpdate :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
|
||||
mkUpdate ent newapi (Just oldapi) (CheckAvsUpdate up la)
|
||||
| let newval = newapi ^. la
|
||||
, let oldval = oldapi ^. la
|
||||
, let entval = getField up ent
|
||||
, oldval /= newval
|
||||
mkUpdate ent new (Just old) (CheckAvsUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let oldval = old ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
, oldval == entval
|
||||
= Just (up =. newval)
|
||||
mkUpdate _ _ _ _ = Nothing
|
||||
|
||||
-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
|
||||
mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
|
||||
mkUpdate' ent new Nothing = mkUpdateDirect ent new
|
||||
mkUpdate' ent new just = mkUpdate ent new just
|
||||
|
||||
mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
|
||||
mkUpdateDirect dbv inp (CheckAvsUpdate up l)
|
||||
| let newval = inp ^. l
|
||||
, let entval = dbv ^. fieldLensVal up
|
||||
mkUpdateDirect ent new (CheckAvsUpdate up l)
|
||||
| let newval = new ^. l
|
||||
, let entval = ent ^. fieldLensVal up
|
||||
, newval /= entval
|
||||
= Just (up =. newval)
|
||||
mkUpdateDirect _ _ _ = Nothing
|
||||
|
||||
-- | Unconditionally update a record through CheckAvsU
|
||||
updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record
|
||||
updateRecord dbv inp (CheckAvsUpdate up l) =
|
||||
let newval = inp ^. l
|
||||
updateRecord ent new (CheckAvsUpdate up l) =
|
||||
let newval = new ^. l
|
||||
lensRec = fieldLensVal up
|
||||
in dbv & lensRec .~ newval
|
||||
in ent & lensRec .~ newval
|
||||
|
||||
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism.
|
||||
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism, but single query may throw
|
||||
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
|
||||
updateAvsUserByIds apids0 = do
|
||||
apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0
|
||||
@ -333,12 +330,12 @@ updateAvsUserByIds apids0 = do
|
||||
let usrId = userAvsUser usravs
|
||||
usr <- MaybeT $ get usrId
|
||||
lift $ do -- maybeT no longer needed from here onwards
|
||||
newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here
|
||||
newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw
|
||||
now <- liftIO getCurrentTime
|
||||
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
||||
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
||||
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
||||
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.
|
||||
per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
|
||||
[ CheckAvsUpdate UserFirstName _avsInfoFirstName
|
||||
, CheckAvsUpdate UserSurname _avsInfoLastName
|
||||
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName
|
||||
@ -347,14 +344,14 @@ updateAvsUserByIds apids0 = do
|
||||
, 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 $
|
||||
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.
|
||||
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,
|
||||
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 oldAvsCardNo $ -- Maybe update PDF pin to latest card
|
||||
pin_up = mkUpdate' usr newAvsCardNo 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`
|
||||
@ -371,6 +368,8 @@ updateAvsUserByIds apids0 = do
|
||||
let oldCompanyId = entityKey <$> oldCompanyEnt
|
||||
oldCompanyMb = entityVal <$> oldCompanyEnt
|
||||
pst_up = if
|
||||
-- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
||||
-- -> mkUpdate' usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
| isNothing oldCompanyMb
|
||||
-> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||
| oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
||||
@ -550,7 +549,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
||||
return newCmp
|
||||
|
||||
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
|
||||
let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||
Entity firmid <$> updateGet firmid cmp_ups
|
||||
|
||||
where
|
||||
@ -635,7 +634,7 @@ setLicence :: (PersistUniqueRead backend, MonadThrow m,
|
||||
UserId -> AvsLicence -> ReaderT backend m Bool
|
||||
setLicence uid lic =
|
||||
getBy (UniqueUserAvsUser uid) >>= \case
|
||||
Just (Entity{entityVal=UserAvs{userAvsPersonId=api}}) -> setLicenceAvs api lic
|
||||
Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
|
||||
Nothing -> do
|
||||
uname <- userDisplayName <<$>> get uid
|
||||
throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
|
||||
|
||||
@ -95,8 +95,7 @@ migrateManual = do
|
||||
, ("idx_qualification_user_block_quser" ,"CREATE INDEX idx_qualification_user_block_quser ON \"qualification_user_block\" (\"qualification_user\")")
|
||||
, ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
|
||||
, ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")
|
||||
, ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
|
||||
, ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
|
||||
, ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
|
||||
, ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
|
||||
, ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company
|
||||
, ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user
|
||||
|
||||
@ -45,8 +45,7 @@ fieldLensVal f = entityLens . fieldLens f
|
||||
getVal :: record -> Entity record
|
||||
getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
|
||||
setVal :: record -> Entity record -> record
|
||||
-- setVal _ = entityVal
|
||||
setVal = const -- TODO verify
|
||||
setVal _ = entityVal
|
||||
|
||||
|
||||
emptyOrIn :: PersistField typ
|
||||
|
||||
@ -769,7 +769,7 @@ fillDb = do
|
||||
, let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
|
||||
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
|
||||
void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
|
||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
|
||||
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
|
||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
|
||||
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False
|
||||
|
||||
@ -43,8 +43,8 @@ import Data.Universe
|
||||
|
||||
instance Arbitrary EmailAddress where
|
||||
arbitrary = do
|
||||
local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
|
||||
domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\d -> isEmail (CBS.pack "example") d)
|
||||
local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
|
||||
domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (isEmail (CBS.pack "example"))
|
||||
let (Just result) = emailAddress (makeEmailLike local domain)
|
||||
pure result
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user