171 lines
8.5 KiB
Haskell
171 lines
8.5 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
|
|
import Servant.Client.Core (requestPath)
|
|
|
|
import Model.Types.Avs
|
|
|
|
|
|
-------------
|
|
-- AVS API --
|
|
-------------
|
|
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
|
|
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
|
|
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
|
|
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
|
|
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
|
|
|
|
|
|
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)
|
|
, 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 $ AvsPersonId 0
|
|
|
|
|
|
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
|
|
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
|
|
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
|
|
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
|
|
}
|
|
where
|
|
(rawQueryPerson :<|> rawQueryStatus :<|> 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
|
|
|
|
|
|
-----------------------
|
|
-- 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)
|
|
|
|
guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
|
|
guessLicenceAddress cards
|
|
| Just c <- Set.lookupMax cards
|
|
, card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
|
|
, Just street <- avsDataStreet
|
|
, Just pcode <- avsDataPostalCode
|
|
, Just city <- avsDataCity
|
|
= Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card)
|
|
| otherwise = Nothing
|
|
|
|
-- | Helper for guessLicenceAddress
|
|
mergeCompanyAddress :: (Maybe Text, Text, a) -> Text
|
|
mergeCompanyAddress (Nothing , addr, _) = addr
|
|
mergeCompanyAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr
|
|
|
|
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
|
|
|
|
|