212 lines
11 KiB
Haskell
212 lines
11 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- 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
|
|
|
|
|