From b20008d3bcb730ff76a76ce2928364e6ce9e7c35 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 30 Nov 2022 15:42:47 +0100 Subject: [PATCH] fix(avs): normalize internal personal numbers between LDAP and AVS --- src/Handler/Admin/Avs.hs | 6 ++++- src/Handler/Utils/Avs.hs | 6 ++--- src/Model/Types/Avs.hs | 50 ++++++++++++++++++++++++++++++++++++++-- src/Utils.hs | 14 +++++++---- src/Utils/Avs.hs | 2 +- 5 files changed, 66 insertions(+), 12 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index c36b45493..9bff17398 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -35,6 +35,9 @@ instance Button UniWorX ButtonAvsTest where avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo avsCardNoField = convertField AvsCardNo avsCardNo textField +avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo +avsInternalPersonalNoField = convertField (canonical . AvsInternalPersonalNo) avsInternalPersonalNo textField + makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html -> flip (renderAForm FormStandard) html $ AvsQueryPerson @@ -42,7 +45,8 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) - <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) + <*> aopt avsInternalPersonalNoField + (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9c070221b..9c4dec62d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -258,8 +258,8 @@ upsertAvsUserById api = do mbuid <- getBy (UniqueUserAvsId api) case (mbuid, mbapd) of (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number - | Just persNo <- avsPersonInternalPersonalNo -> do - candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] [] + | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do + candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] case candidates of [uid] -> insertUniqueEntity $ UserAvs api uid (_:_) -> throwM AvsUserAmbiguous @@ -290,7 +290,7 @@ upsertAvsUserById api = do , aufSex = Nothing , aufMobile = Nothing , aufTelephone = Nothing - , aufFPersonalNumber = avsPersonInternalPersonalNo + , aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo , aufFDepartment = Nothing , aufPostAddress = userFirmAddr , aufPrefersPostal = isJust firmAddress diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 3443d6938..9b20eaee7 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -81,7 +81,53 @@ instance FromJSON SloppyBool where -- AVS Datatypes -- ------------------- -type AvsInternalPersonalNo = Text -- ought to be all digits, type synonym for clarity/documentation within types +newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits + deriving (Eq, Ord, Show, Generic, Typeable) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) +instance E.SqlString AvsInternalPersonalNo +-- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API +normalizeAvsInternalPersonalNo :: Text -> Text +normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace c) +instance Canonical AvsInternalPersonalNo where + canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn +instance FromJSON AvsInternalPersonalNo where + parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x +instance ToJSON AvsInternalPersonalNo where + toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn + +type instance Element AvsInternalPersonalNo = Char +instance MonoFoldable AvsInternalPersonalNo where + ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo + ofoldr x y = Text.foldr x y . avsInternalPersonalNo + ofoldl' x y = Text.foldl' x y . avsInternalPersonalNo + otoList = Text.unpack . avsInternalPersonalNo + oall x = Text.all x . avsInternalPersonalNo + oany x = Text.any x . avsInternalPersonalNo + onull = Text.null . avsInternalPersonalNo + olength = Text.length . avsInternalPersonalNo + ofoldr1Ex x = Text.foldr1 x . avsInternalPersonalNo + ofoldl1Ex' x = Text.foldl1' x . avsInternalPersonalNo + headEx = Text.head . avsInternalPersonalNo + lastEx = Text.last . avsInternalPersonalNo + {-# INLINE ofoldMap #-} + {-# INLINE ofoldr #-} + {-# INLINE ofoldl' #-} + {-# INLINE otoList #-} + {-# INLINE oall #-} + {-# INLINE oany #-} + {-# INLINE onull #-} + {-# INLINE olength #-} + {-# INLINE ofoldr1Ex #-} + {-# INLINE ofoldl1Ex' #-} + {-# INLINE headEx #-} + {-# INLINE lastEx #-} + +{- +instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where + canonical (Just aipn) | ipn@(AvsInternalPersonalNo pn) <- canonical aipn, not (null pn) = Just ipn + canonical _ = Nothing +-} + -- CompleteCardNo = xxxxxxxx.y -- where x is an 8 digit AvsCardNo prefixed by zeros, see normalizeAvsCardNo @@ -117,7 +163,7 @@ readAvsFullCardNo _ = Nothing discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) | Text.null pv - = Just $ Right c + = Just $ Right $ AvsInternalPersonalNo c | not $ Text.null c , Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v diff --git a/src/Utils.hs b/src/Utils.hs index 8a92fe520..7d023a4b3 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1876,14 +1876,18 @@ makePrisms ''ExitCase class Canonical a where canonical :: a -> a -instance MonoFoldable mono => Canonical (Maybe mono) where + +instance {-# OVERLAPPABLE #-} MonoFoldable mono => Canonical (Maybe mono) where canonical (Just t) | null t = Nothing canonical other = other --- instance (Canonical mono, MonoFoldable mono) => Canonical (Maybe mono) where --- canonical (Just t) | null t = Nothing --- canonical (Just t) = Just $ canonical t --- canonical other = other +{- +instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where + canonical r@(Just t) = let c = canonical t + in if null c then Nothing else + if t==c then r else Just c + canonical other = other +-} -- this instance is more of a convenient abuse of the class (expand to Foldable) instance (Ord a, Canonical a) => Canonical (Set a) where diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index ef5aaf46c..3606bb2c0 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -157,7 +157,7 @@ mergeAvsDataPerson = Map.unionWithKey merger in AvsDataPerson { avsPersonFirstName = pickBy' Text.length avsPersonFirstName , avsPersonLastName = pickBy' Text.length avsPersonLastName - , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo + , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo , avsPersonPersonNo = pickBy' id avsPersonPersonNo , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb