diff --git a/src/Application.hs b/src/Application.hs index 0b67152d6..29aadb760 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index bf5851355..1cebc7a16 100644 --- a/src/Model/Types/Avs.hs +++ b/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 --} \ No newline at end of file +-} + +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 diff --git a/src/Utils.hs b/src/Utils.hs index e375de8d0..5276e8544 100644 --- a/src/Utils.hs +++ b/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 diff --git a/test/Utils/TypesSpec.hs b/test/Utils/TypesSpec.hs index 61a58f39f..ccb6e016e 100644 --- a/test/Utils/TypesSpec.hs +++ b/test/Utils/TypesSpec.hs @@ -27,25 +27,16 @@ instance Arbitrary AvsDataCardColor where shrink = genericShrink instance Arbitrary AvsDataPersonCard where - arbitrary = do - proto <- genericArbitrary - return $ proto { avsDataStreet = null2nothing $ avsDataStreet proto - , avsDataPostalCode = null2nothing $ avsDataPostalCode proto - , avsDataCity = null2nothing $ avsDataCity proto - , avsDataFirm = null2nothing $ avsDataFirm proto - } - shrink = genericShrink + arbitrary = canonical <$> genericArbitrary + shrink = fmap canonical <$> genericShrink instance Arbitrary AvsStatusPerson where arbitrary = genericArbitrary shrink = genericShrink instance Arbitrary AvsDataPerson where - arbitrary = do - proto <- genericArbitrary - return $ proto { avsPersonInternalPersonalNo = null2nothing $ avsPersonInternalPersonalNo proto} - - shrink = genericShrink + arbitrary = canonical <$> genericArbitrary + shrink = fmap canonical <$> genericShrink instance Arbitrary AvsPersonLicence where arbitrary = genericArbitrary