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