fix(avs): normalize internal personal numbers between LDAP and AVS

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 ()

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
+        | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
-            candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
+            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

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

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
+instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Canonical (Maybe mono) where
---   canonical (Just t) = Just $ canonical t
+  canonical r@(Just t) = let c = canonical t 
---   canonical other = other
+                         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

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