diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 20bb62ae6..f07dc6003 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -299,8 +299,7 @@ upsertAvsUserById api = do
(Nothing, Just AvsDataPerson{..}) -> do -- No LDAP User, but found in AVS; create new user
let firmAddress = guessLicenceAddress avsPersonPersonCards
mbCompany = firmAddress ^? _Just . _1 . _Just
- userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
- addrCard = firmAddress ^? _Just . _3
+ userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
pinCard = Set.lookupMax avsPersonPersonCards
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
fakeIdent = CI.mk $ "AVSID:" <> tshow api
@@ -328,9 +327,9 @@ upsertAvsUserById api = do
whenIsJust mbUid $ \uid -> runDB $ do
now <- liftIO getCurrentTime
insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo
- -- forM_ avsPersonPersonCards $ -- save all cards for later
- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
- forM_ cs $ -- only save used cards for the postal address update detection
+ forM_ avsPersonPersonCards $ -- save all cards for later
+ -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
+ -- forM_ cs $ -- only save used cards for the postal address update detection
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
upsertUserCompany uid mbCompany
return mbUid
@@ -338,36 +337,32 @@ upsertAvsUserById api = do
(Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
let firmAddress = guessLicenceAddress avsPersonPersonCards
mbCompany = firmAddress ^? _Just . _1 . _Just
- userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
- addrCard = firmAddress ^? _Just . _3
+ mbCoFirmAddr= mergeCompanyAddress <$> firmAddress
+ userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
pinCard = Set.lookupMax avsPersonPersonCards
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
runDB $ do
now <- liftIO getCurrentTime
- upsertUserCompany uid mbCompany
- whenIsJust addrCard $ \aCard ->
- getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case
- (Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change
- update uac [UserAvsCardLastSynch =. now]
- _ -> do -- possibly new address data
- void $ upsert UserAvsCard
- { userAvsCardPersonId = api
- , userAvsCardCardNo = avsDataCardNo aCard
- , userAvsCardCard = aCard
- , userAvsCardLastSynch= now
- }
- [ UserAvsCardCard =. aCard
- , UserAvsCardLastSynch =. now
- ]
- when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
- whenIsJust pinCard $ \pCard ->
- unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
- -- update pin, but only if it was unset or set to the value of an old card
- oldCards <- selectList [UserAvsCardPersonId ==. api] []
+ oldCards <- selectList [UserAvsCardPersonId ==. api] []
+ let oldAddrs = Set.fromList $ mapMaybe (maybeCompanyAddress . userAvsCardCard . entityVal) oldCards
+ unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
+ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
+ whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
+ unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
[UserPinPassword =. userPin]
insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now
+ upsertUserCompany uid mbCompany
+ forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard
+ { userAvsCardPersonId = api
+ , userAvsCardCardNo = avsDataCardNo aCard
+ , userAvsCardCard = aCard
+ , userAvsCardLastSynch = now
+ }
+ [ UserAvsCardCard =. aCard
+ , UserAvsCardLastSynch =. now
+ ]
return $ Just uid
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 0fddc70cf..319b7e68e 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -150,6 +150,11 @@ instance ToJSON AvsCardNo where
normalizeAvsCardNo :: Text -> Text
normalizeAvsCardNo = Text.justifyRight 8 '0'
+instance Canonical AvsCardNo where
+ canonical AvsCardNo{..} = AvsCardNo $ normalizeAvsCardNo avsCardNo
+ -- canonical = AvsCardNo . normalizeAvsCardNo . avsCardNo
+
+
data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
deriving (Eq, Ord, Generic, Typeable)
@@ -319,6 +324,7 @@ instance Canonical AvsDataPersonCard where
& _avsDataPostalCode %~ canonical
& _avsDataCity %~ canonical
& _avsDataFirm %~ canonical
+ & _avsDataCardNo %~ canonical
-- TODO: use canonical in FromJSON/ToJSON instances for consistency
instance FromJSON AvsDataPersonCard where
@@ -332,7 +338,7 @@ instance FromJSON AvsDataPersonCard where
<*> v .:?! "PostalCode"
<*> v .:?! "City"
<*> v .:?! "Firm"
- <*> v .: "CardNo"
+ <*> ((v .: "CardNo") <&> canonical)
<*> v .: "VersionNo"
instance ToJSON AvsDataPersonCard where
@@ -349,7 +355,7 @@ instance ToJSON AvsDataPersonCard where
[ "Valid" .= show avsDataValid
, "CardColor" .= avsDataCardColor
, "CardAreas" .= Set.foldl Text.snoc Text.empty avsDataCardAreas
- , "CardNo" .= avsDataCardNo
+ , "CardNo" .= (avsDataCardNo & canonical)
, "VersionNo" .= avsDataVersionNo
]
derivePersistFieldJSON ''AvsDataPersonCard
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index 7f1807b90..5dffe2666 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -89,21 +89,32 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
cardMatch AvsDataPersonCard{..} =
avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
-guessLicenceAddress cards
- | Just c <- Set.lookupMax cards
- , card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
- , Just street <- avsDataStreet
+
+getCompanyAddress :: AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
+getCompanyAddress card@AvsDataPersonCard{..}
+ | Just street <- avsDataStreet
, Just pcode <- avsDataPostalCode
, Just city <- avsDataCity
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card)
| otherwise = Nothing
--- | Helper for guessLicenceAddress
+-- | From a set of card, choose the one with the most complete postal address.
+-- Returns company, postal address and the associated card where the address was taken from
+guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
+guessLicenceAddress cards
+ | Just c <- Set.lookupMax cards
+ , card <- Set.foldr pickLicenceAddress c cards
+ = getCompanyAddress card
+ | otherwise = Nothing
+
+-- | Helper for guessLicenceAddress or getCompanyAddress
mergeCompanyAddress :: (Maybe Text, Text, a) -> Text
mergeCompanyAddress (Nothing , addr, _) = addr
mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr
+maybeCompanyAddress :: AvsDataPersonCard -> Maybe Text
+maybeCompanyAddress = fmap mergeCompanyAddress . getCompanyAddress
+
hasAddress :: AvsDataPersonCard -> Bool
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet
index 8025af5c1..8a5a5337d 100644
--- a/templates/admin-problems.hamlet
+++ b/templates/admin-problems.hamlet
@@ -40,4 +40,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
^{flagError noStalePrintJobs}
- ^{simpleLink (i18n (MsgProblemsNoStalePrintJobs cutOffPrintDays)) PrintCenterR}
+ ^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}