chore(avs): fix json tests

src/Application.hs

@@ -371,7 +371,7 @@ makeFoundation appSettings''@AppSettings{..} = do
       let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
 
       -- Return the foundation
-      $logDebugS "setup" "Done"
+      $logInfoS "setup" "*** DONE ***"
       return foundation
 
 data SessionStoreException

src/Model/Types/Avs.hs

@@ -14,9 +14,10 @@ import qualified Data.Csv as Csv
 import Utils.Lens.TH
 
 import Text.Read (Read(..))
-
-import qualified Data.Set           as Set
 import qualified Data.Text          as Text
+import qualified Data.Set           as Set
+import qualified Data.Map           as Map
+
 -- import qualified Data.HashMap.Lazy  as HM
 
 import Data.Aeson
@@ -166,6 +167,23 @@ instance Ord AvsDataPersonCard where
       compareBy f = compare `on` f a b
  -}
 
+makeLenses_ ''AvsDataPersonCard
+{-
+instance Canonical AvsDataPersonCard where
+  canonical proto = proto { avsDataStreet     = null2nothing $ avsDataStreet      proto
+                          , avsDataPostalCode = null2nothing $ avsDataPostalCode  proto
+                          , avsDataCity       = null2nothing $ avsDataCity        proto
+                          , avsDataFirm       = null2nothing $ avsDataFirm        proto
+                          }
+-}                           
+instance Canonical AvsDataPersonCard where
+  canonical proto = 
+    proto & _avsDataStreet      %~ null2nothing
+          & _avsDataPostalCode  %~ null2nothing
+          & _avsDataCity        %~ null2nothing
+          & _avsDataFirm        %~ null2nothing
+
+-- TODO: use canonical in FromJSON/ToJSON instances for consistency
 instance FromJSON AvsDataPersonCard where
   parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
     <$> ((v .: "Valid") <&> sloppyBool)
@@ -199,7 +217,8 @@ instance ToJSON AvsDataPersonCard where
     ]
 
 derivePersistFieldJSON ''AvsDataPersonCard
-makeLenses_ ''AvsDataPersonCard
+
+
 
 -- The AVS API sometimes requests PersonIds as numbers and sometimes as objects.
 newtype AvsObjPersonId = AvsObjPersonId
@@ -238,6 +257,19 @@ data AvsDataPerson = AvsDataPerson
       }
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
+makeLenses_ ''AvsDataPerson
+
+{-
+instance Canonical AvsDataPerson where
+  canonical proto = 
+    proto & _avsPersonInternalPersonalNo %~ null2nothing
+          & _avsPersonPersonCards        %~ Set.map canonical
+-}
+instance Canonical AvsDataPerson where
+  canonical = over _avsPersonInternalPersonalNo null2nothing
+            . over _avsPersonPersonCards        canonical
+
+
 instance FromJSON AvsDataPerson where
   parseJSON = withObject "AvsDataPerson" $ \v -> AvsDataPerson
     <$> v .:    "FirstName"
@@ -428,4 +460,27 @@ bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
               ...
     where
       compareBy f = compare `on` f a b
--}
+-}
+
+mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson
+mergeByPersonId = Set.foldr aux Map.empty
+  where
+    aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
+    aux adp@AvsDataPerson{avsPersonPersonID} = Map.insertWithKey merger avsPersonPersonID adp 
+    
+    merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
+    merger api pa pb = 
+      let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
+          pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
+      in AvsDataPerson 
+        { avsPersonFirstName          = pickBy' Text.length avsPersonFirstName
+        , avsPersonLastName           = pickBy' Text.length avsPersonLastName
+        , avsPersonInternalPersonalNo = pickBy' (Text.length . (fromMaybe mempty)) avsPersonInternalPersonalNo
+        , avsPersonPersonNo           = pickBy' id avsPersonPersonNo
+        , avsPersonPersonID           = api -- keys must be identical due to call with insertWithKey
+        , avsPersonPersonCards        = (Set.union `on` avsPersonPersonCards) pa pb
+        }
+
+    pickBy :: Ord b => (a -> b) -> a -> a -> a 
+    pickBy f x y  | (f x) >= (f y)  = x 
+                  | otherwise       = y

src/Utils.hs

@@ -949,7 +949,8 @@ actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a
 actRight (Left  x) _ = pure $ Left x
 actRight (Right y) f = f y
 
-
+--leftExceptT :: Monad m => m (Either e a) -> ExceptT e m a
+--leftExceptT -- TODO
 
 ---------------
 -- Exception --
@@ -1813,3 +1814,15 @@ dir <//> file = dir </> dropDrive file
 ----------------
 
 makePrisms ''ExitCase
+
+
+---------------
+-- Normalize --
+---------------
+
+-- | Bad hack class for datatypes that have multiple inequal representations which ought to be identical, i.e. Just "" ~= Nothing
+class Canonical a where 
+  canonical :: a -> a
+
+instance (Ord a, Canonical a) => Canonical (Set a) where
+  canonical = Set.map canonical

test/Utils/TypesSpec.hs

@@ -27,25 +27,16 @@ instance Arbitrary AvsDataCardColor where
   shrink = genericShrink
 
 instance Arbitrary AvsDataPersonCard where
-  arbitrary = do
+  arbitrary = canonical <$> genericArbitrary    
-    proto <- genericArbitrary    
+  shrink = fmap canonical <$> genericShrink
-    return $ proto  { avsDataStreet     = null2nothing $ avsDataStreet      proto
-                    , avsDataPostalCode = null2nothing $ avsDataPostalCode  proto
-                    , avsDataCity       = null2nothing $ avsDataCity        proto
-                    , avsDataFirm       = null2nothing $ avsDataFirm        proto
-                    }
-  shrink = genericShrink
 
 instance Arbitrary AvsStatusPerson where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
 instance Arbitrary AvsDataPerson where
-  arbitrary = do 
+  arbitrary = canonical <$> genericArbitrary
-    proto <- genericArbitrary
+  shrink = fmap canonical <$> genericShrink
-    return $ proto { avsPersonInternalPersonalNo = null2nothing $ avsPersonInternalPersonalNo proto}
-
-  shrink = genericShrink
 
 instance Arbitrary AvsPersonLicence where
   arbitrary = genericArbitrary