-- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Utils.Avs where import Import.NoModel import Utils.Lens import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as Text import Servant import Servant.Client #ifdef DEVELOPMENT #else import Servant.Client.Core (requestPath) #endif import Model.Types.Avs ------------- -- AVS API -- ------------- type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences) type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus type AVSPersonContact = "InfoPersonContact" :> ReqBody '[JSON] AvsQueryContact :> Post '[JSON] AvsResponseContact type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce = 90 -- maximum input set size for avsQuerySetLicences as enforced by AVS avsMaxQueryAtOnce :: Int avsMaxQueryAtOnce = 900 -- maximum input set size for avsQueryStatus as enforced by AVS avsApi :: Proxy AVS avsApi = Proxy {- -- Somehow the GADT-style declaration is not flexible enough to compile at the location of the function call data AvsQuery where AvsQuery :: { avsQueryPerson :: MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) , avsQueryStatus :: MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) ... } -> AvsQuery -} data AvsQuery = AvsQuery { avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson) , avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus) , avsQueryContact :: forall m. MonadIO m => AvsQueryContact -> m (Either ClientError AvsResponseContact) , avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences) -- , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM , avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences) } makeLenses_ ''AvsQuery -- | To query all active licences, a special constant argument must be prepared avsQueryAllLicences :: AvsQueryGetLicences avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery #ifdef DEVELOPMENT mkAvsQuery _ _ _ = AvsQuery { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing) , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty } #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv , avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv , avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences -- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv , avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv } where ( rawQueryPerson :<|> rawQueryStatus :<|> rawQueryContact :<|> rawQueryGetLicences :<|> rawQuerySetLicences ) = client avsApi basicAuth catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404))) | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other splitQuery :: (Wrapped a, Wrapped c, Unwrapped a ~ Set b, Semigroup (Unwrapped c)) => (a -> ClientM c) -> a -> ClientM c splitQuery rawQuery q | Set.size s <= avsMaxQueryAtOnce = rawQuery q | otherwise = do let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s res1 <- rawQuery $ view _Unwrapped' avsid1 res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2 return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped') where s = view _Wrapped' q #endif ----------------------- -- Utility Functions -- ----------------------- -- | retrieve AvsDataPersonCard with longest validity for a given licence, -- first argument is a lower bound for avsDataValidTo, usually current day -- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case) getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards where licence = licence2char licence' validLicenceCards = Set.filter cardMatch cards cardMatch AvsDataPersonCard{..} = avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) getCompanyAddress card@AvsDataPersonCard{..} | Just street <- avsDataStreet , Just pcode <- avsDataPostalCode , Just city <- avsDataCity = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) | isJust avsDataFirm = (avsDataFirm, Nothing, Just card) | otherwise = (Nothing, Nothing, Nothing) -- | From a set of card, choose the one with the most complete postal address. -- Returns company, postal address and the associated card where the address was taken from guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) guessLicenceAddress cards | Just c <- Set.lookupMax cards , card <- Set.foldr pickLicenceAddress c cards = getCompanyAddress card | otherwise = (Nothing, Nothing, Nothing) hasAddress :: AvsDataPersonCard -> Bool hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard pickLicenceAddress a b | Just r <- pickBetter' hasAddress = r -- prefer card with complete address | Just r <- pickBetter' avsDataValid = r -- prefer valid cards | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. | avsDataCardColor a < avsDataCardColor b = b | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date | avsDataIssueDate a < avsDataIssueDate b = b | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date | avsDataValidTo a < avsDataValidTo b = b | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm | a <= b = b -- respect natural Ord instance | otherwise = a where pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard pickBetter' = pickBetter a b licenceRollfeld = licence2char AvsLicenceRollfeld licenceVorfeld = licence2char AvsLicenceVorfeld {- Note: For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering compare a b = compareBy avsDataValid <> compareBy avsDataValidTo <> compareBy avsDataIssueDate ... where compareBy f = compare `on` f a b -} -- Merges several answers by AvsPersonId, preserving all AvsPersonCards mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId = flip $ Set.foldr aux where aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp 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 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' (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 } pickBy :: Ord b => (a -> b) -> a -> a -> a pickBy f x y | f x >= f y = x | otherwise = y