-- 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 = 80   -- maximum input set size for avsQuerySetLicences as enforced by AVS

avsMaxQueryAtOnce :: Int
avsMaxQueryAtOnce = 500       -- 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 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
    | 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
        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


