From 3b346277331fc76ed35e8fcf38e6e32ba0235786 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 28 Sep 2022 18:13:23 +0200 Subject: [PATCH] chore(avs): construct comprehensive avs queries --- src/Handler/Utils/Avs.hs | 13 ++++++++--- src/Model/Types/Avs.hs | 49 ++++++++++++++++++++++++++++++++-------- 2 files changed, 50 insertions(+), 12 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 7fb5f498b..28dc51cb5 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -26,6 +26,11 @@ data AvsException deriving (Show, Generic, Typeable) instance Exception AvsException +{- + Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException? +-} + + ------------------ -- AVS Handlers -- ------------------ @@ -38,8 +43,6 @@ instance Exception AvsException -} - - -- Do we need this? -- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence) @@ -114,9 +117,13 @@ upsertAvsUser api = do -- lookupAvsUser :: AvsPersonId -> lookupAvsUser api = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - -- avsQueryPerson does not support querying an AvsPersonId, hence we need a preliminary avsQueryStatus to get all AvsCardNo + -- avsQueryPerson does not support querying an AvsPersonId directly, + -- hence we need a preliminary avsQueryStatus to get all AvsCardNo. + -- Note that avsQueryStatus only provides limited information AvsResponseStatus statuses <- throwLeftM $ avsQueryStatus $ AvsQueryStatus $ Set.singleton api _avsperson <- forM statuses $ \AvsStatusPerson{avsStatusPersonCardStatus} -> + foldlM Map.empty avsStatusPersonCardStatus + TODO TODO TODO forM avsStatusPersonCardStatus $ \AvsDataPersonCard{avsDataCardNo} -> AvsResponsePerson ps <- throwLeftM $ avsQueryPerson $ AvsQueryPerson def{avsPersonQueryCardNo = avsDataCardNo} return $ mergeByPersonId ps diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index e718e14b2..48c111609 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -140,15 +140,15 @@ instance FromJSON AvsDataCardColor where data AvsDataPersonCard = AvsDataPersonCard - { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans - , avsDataValidTo :: Maybe Day -- always Nothing if returned with AvsResponseStatus - , avsDataIssueDate :: Maybe Day -- always Nothing if returned with AvsResponseStatus + { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans + , avsDataValidTo :: Maybe Day -- Nothing if returned with AvsResponseStatus + , avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus , avsDataCardColor :: AvsDataCardColor - , avsDataCardAreas :: Set Char -- logically a set of upper-case letters - , avsDataStreet :: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataPostalCode:: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataCity :: Maybe Text -- always Nothing if returned with AvsResponseStatus - , avsDataFirm :: Maybe Text -- always Nothing if returned with AvsResponseStatus + , avsDataCardAreas :: Set Char -- logically a set of upper-case letters + , avsDataStreet :: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataPostalCode:: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataCity :: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataFirm :: Maybe Text -- Nothing if returned with AvsResponseStatus , avsDataCardNo :: AvsCardNo -- always 8 digits , avsDataVersionNo :: Text } @@ -236,7 +236,7 @@ deriveJSON defaultOptions data AvsStatusPerson = AvsStatusPerson { avsStatusPersonID :: AvsPersonId - , avsStatusPersonCardStatus :: Set AvsDataPersonCard + , avsStatusPersonCardStatus :: Set AvsDataPersonCard -- only delivers non-Maybe fields, all Maybe-fields are Nothing } deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -462,6 +462,36 @@ bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering compareBy f = compare `on` f a b -} +mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +mergeAvsDataPerson = Map.unionWithKey merger + where + 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 + +catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson +catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp + +mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson +mergeByPersonId = Set.foldr aux Map.empty + where + aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson + aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp + +{- Not general enough: mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId = Set.foldr aux Map.empty where @@ -484,3 +514,4 @@ mergeByPersonId = Set.foldr aux Map.empty pickBy :: Ord b => (a -> b) -> a -> a -> a pickBy f x y | f x >= f y = x | otherwise = y +-} \ No newline at end of file