fradrive/src/Utils/Avs.hs

-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@frapor.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

#ifndef DEVELOPMENT
import Servant.Client.Core (requestPath)
import UnliftIO.Concurrent (threadDelay)
#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 = 80   -- maximum input set size for avsQuerySetLicences as enforced by AVS

avsMaxQueryAtOnce :: Int
avsMaxQueryAtOnce = 500       -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS

avsMaxQueryDelay :: Int
avsMaxQueryDelay = 300000    -- microsecond to wait before sending another AVS query


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


-- | AVS/VSM-interface currently only allows GetLicences with query argument ID 0, which means all licences; all other queries yield an empty response
avsQueryAllLicences :: AvsQueryGetLicences
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero


mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery
    { avsQueryPerson          =       return . Right . fakePerson
    , avsQueryStatus          =       return . Right . fakeStatus
    , avsQueryContact         =       return . Right . fakeContact
    , avsQuerySetLicences     = \_ -> return . Right $ AvsResponseSetLicences mempty
    , avsQueryGetAllLicences  =       return . Right $ AvsResponseGetLicences mempty
    }
  where
    fakePerson :: AvsQueryPerson -> AvsResponsePerson
    fakePerson = 
      let
        sarah   = Set.singleton $ AvsDataPerson "Sarah"   "Vaupel"  Nothing            2 (AvsPersonId        2) mempty
        stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth"   Nothing            4 (AvsPersonId        4) mempty
        steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
        sumpfi1  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
        sumpfi2  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604387) mempty
        sumpfi3  = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604591) mempty
      in \case 
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson steffen
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")}                                    -> AvsResponsePerson steffen
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson stephan
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"}  -> AvsResponsePerson sarah
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")}                                          -> AvsResponsePerson $ steffen <> sarah
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4")       , avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ steffen <> stephan
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
        AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"}  -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
        _ -> AvsResponsePerson steffen

    fakeStatus :: AvsQueryStatus -> AvsResponseStatus
    fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList
        [ AvsDataPersonCard True  (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb  (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG")                              (AvsCardNo "6666") "4"   
        , AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot   (Set.fromList ['F','A' ])    Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH")  (AvsCardNo "7777") "4"
        , AvsDataPersonCard True  (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau  mempty                       Nothing Nothing Nothing (Just "Fraport Facility Services GmbH")          (AvsCardNo "8888") "4"
        ]
    fakeStatus  _ = AvsResponseStatus mempty
    fakeContact :: AvsQueryContact -> AvsResponseContact
    fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
    fakeContact _ = AvsResponseContact mempty
#else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
    { avsQueryPerson      = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries
                                  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 -- NOTE: 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
    | avsMaxQueryAtOnce >= Set.size s = rawQuery q
    | otherwise = do
        --  logInfoS "AVS" $ "Splitting large query for input Set " <> tshow (Set.size s) -- would require MonadLogger ClientM
        let (avsid1, avsid2) = Set.splitAt avsMaxQueryAtOnce s
        res1 <-            rawQuery $ view _Unwrapped' avsid1
        liftIO $ threadDelay avsMaxQueryDelay
        res2 <- splitQuery rawQuery $ view _Unwrapped' avsid2
        return $ view _Unwrapped' (res1 ^. _Wrapped' <> res2 ^. _Wrapped')
  where 
    s = view _Wrapped' q
#endif

-----------------------
-- Utility Functions -- DEPRECTATED
-----------------------

--   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)

-- | DEPRECTATED
-- 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