From df559fead137a4ed22d59375b535a4d745ad4d09 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 17 Nov 2022 12:32:08 +0100 Subject: [PATCH] chore(avs): adjust to newly refined VSM specifications (WIP) --- src/Model/Types/Avs.hs | 24 ++++++++++++++++-------- src/Utils/Avs.hs | 20 ++++++++++---------- 2 files changed, 26 insertions(+), 18 deletions(-) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 063df660a..dd576c823 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -137,10 +137,14 @@ instance ToJSON AvsLicence where toJSON AvsLicenceRollfeld = Number 2 instance FromJSON AvsLicence where - parseJSON (Number n) | n == 0 = pure AvsNoLicence - | n == 1 = pure AvsLicenceVorfeld + parseJSON (Number n) | n == 1 = pure AvsLicenceVorfeld -- ordered by occurrence, n==1 is most common case | n == 2 = pure AvsLicenceRollfeld + | n == 0 = pure AvsNoLicence -- n==0 never received from AVS, only sent to AVS +#ifdef DEVELOPMENT parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid +#else + parseJSON _ = pure AvsNoLicence -- we simply ignore all other values +#endif -- | Ought to be identical to QualificationShortname! licence2char :: AvsLicence -> Char @@ -312,8 +316,7 @@ deriveJSON defaultOptions data AvsPersonLicence = AvsPersonLicence { avsLicencePersonID :: AvsPersonId - , avsLicenceRampLicence :: AvsLicence -- Schnittstelle unklar: RampDrivingLicence oder RampLicence - --, avsLicenceRampDrivingLicence :: AvsLicence + , avsLicenceRampLicence :: AvsLicence } deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions @@ -324,16 +327,21 @@ deriveJSON defaultOptions } ''AvsPersonLicence data AvsLicenceResponse = AvsLicenceResponse - { avsResponsePersonID :: AvsPersonId - , avsResponseSuccess :: SloppyBool - , avsResponseMessage :: Text - } + { avsResponsePersonID :: AvsPersonId + , avsResponseSuccess :: SloppyBool + , avsResponseMessage :: Text + } + | AvsErrorResponse + { avsResponseStatus :: Text + , avsResponseMessage :: Text + } deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True , tagSingleConstructors = False , rejectUnknownFields = False + , sumEncoding = UntaggedValue } ''AvsLicenceResponse diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index df3b35c40..dfd2d7c04 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -43,7 +43,7 @@ data AvsQuery where data AvsQuery = AvsQuery { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) - , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) + , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) , avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences) , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) , avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences) @@ -59,7 +59,7 @@ avsQueryAllLicences = AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId $ Avs mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv - , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv + , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv @@ -71,7 +71,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other - + ----------------------- -- Utility Functions -- ----------------------- @@ -140,7 +140,7 @@ bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering -- Merges several answers by AvsPersonId, preserving all AvsPersonCards mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId = flip $ Set.foldr aux - where + where aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp @@ -148,13 +148,13 @@ catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -mergeAvsDataPerson = Map.unionWithKey merger - where +mergeAvsDataPerson = Map.unionWithKey merger + where merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson - merger api pa pb = + 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 + in AvsDataPerson { avsPersonFirstName = pickBy' Text.length avsPersonFirstName , avsPersonLastName = pickBy' Text.length avsPersonLastName , avsPersonInternalPersonalNo = pickBy' (Text.length . fromMaybe mempty) avsPersonInternalPersonalNo @@ -163,8 +163,8 @@ mergeAvsDataPerson = Map.unionWithKey merger , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb } - pickBy :: Ord b => (a -> b) -> a -> a -> a - pickBy f x y | f x >= f y = x + pickBy :: Ord b => (a -> b) -> a -> a -> a + pickBy f x y | f x >= f y = x | otherwise = y