-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications, ExistentialQuantification #-}

-- Module for functions directly related to the AVS interface,
-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
-- NOTE: Several ifdef DEVELOPMENT used, so UNSET DEVELOPMENT and build before comitting.

module Handler.Utils.Avs
  ( guessAvsUser
  , upsertAvsUserByCard
  , upsertAvsUserById
  , updateAvsUserByIds
  , updateAvsUserByADC
  , linktoAvsUserByUIDs
  , queueAvsUpdateByUID, queueAvsUpdateByAID
  -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
  , AvsLicenceDifferences(..)
  , setLicence, setLicenceAvs, setLicencesAvs
  , retrieveDifferingLicences, retrieveDifferingLicencesStatus
  , computeDifferingLicences
  -- , synchAvsLicences
  , queryAvsFullStatus
  , lookupAvsUser, lookupAvsUsers
  , AvsException(..)
  , updateReceivers
  , AvsPersonIdMapPersonCard
  -- CR3
  , SomeAvsQuery(..)
  , queryAvsCardNo, queryAvsCardNos
  , catchAVShandler
  ) where

import Import

-- import Handler.Utils
-- import qualified Database.Esqueleto.Legacy as E


import qualified Data.Set             as Set
import qualified Data.Map             as Map
import qualified Data.Text            as Text
-- import qualified Data.CaseInsensitive as CI

import qualified Control.Monad.Catch  as Catch

import Foundation.Yesod.Auth (userLookupAndUpsert)

import Jobs.Queue

import Utils.Avs
import Utils.Users
-- import Utils.Mail (validEmail)
import Handler.Utils.Users
import Handler.Utils.Company
import Handler.Utils.Qualification
import Handler.Utils.Memcached
import Handler.Utils.AvsUpdate

import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils        as E
import qualified Database.Esqueleto.PostgreSQL   as E

import Servant.Client.Core.ClientError (ClientError)


--------------------
-- AVS Exceptions --
--------------------

data AvsException
  = AvsInterfaceUnavailable                   -- Interface to AVS was not configured at startup or does not respond
  | AvsUserUnassociated Text                  -- Manipulating AVS Data for a user that is not linked to AVS yet
  | AvsUserUnknownByAvs AvsPersonId           -- AvsPersonId not (or no longer) found in AVS
  | AvsUserAmbiguous    AvsPersonId           -- Multiple matching existing users found for a query in AVS or DB
  | AvsStatusSearchEmpty                      -- AvsStatusSearch returned empty result
  | AvsPersonSearchEmpty                      -- AvsPersonSearch returned empty result
  | AvsPersonSearchAmbiguous                  -- AvsPersonSearch returned more than one result
  | AvsSetLicencesFailed Text                 -- AvsSetLicence total failure
  | AvsIdMismatch AvsPersonId AvsPersonId     -- First AVS Id was requested, but second one was returned for that query
  | AvsUserCreationFailed AvsPersonId
  deriving (Show, Eq, Ord, Generic)
instance Exception AvsException
embedRenderMessage ''UniWorX ''AvsException id  -- display as feedback for user initiated actions -- moved to Foundation.I18n

{-
  Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
-}

-- | Catch AVS exceptions and display them as messages
catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
-- catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
catchAVS2message = catchAVShandler False False True Nothing

-- | Catch AVS exceptions and ignore them, but display them as messages
catchAVS2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
catchAVS2log = catchAVShandler False True False Nothing

catchAll2log :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m a -> m ()
catchAll2log  = voidMaybe catchAll2log'

catchAll2log' :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
catchAll2log' = catchAVShandler True True False Nothing

catchAVShandler :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => Bool -> Bool -> Bool -> a -> m a -> m a
catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHandlers)
  where
    avsHandlers =
      [ Catch.Handler (\(exc::AvsException) -> liftHandler $ do
            let txt = "AVS exception ignored: " <> tshow exc
            when toLog $ $logErrorS "AVS" txt
            when toMsg $ addMessageI Warning exc
            return dft
          )

      , Catch.Handler (\(exc::ClientError ) -> liftHandler $ do
            let txt = "AVS fatal communicaton failure: " <> tshow exc
            when toLog $ $logErrorS "AVS" txt
            when toMsg $ addMessage Warning $ toHtml txt
            return dft
          )
      ]
    allHandlers = guardMonoid allEx
      [ Catch.Handler (\(exc::SomeException) -> liftHandler $ do
            let txt = "AVS fatal unknown failure: " <> tshow exc
            when toLog $ $logErrorS "AVS" txt
            when toMsg $ addMessage Error $ toHtml txt
            return dft
          )
      ]



------------------
-- AVS Handlers --
------------------

-- convenience wrapper for easy replacement with true status query
queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus
queryAvsFullStatus api =
  lookupAvsUser api <&> \case
    Just AvsDataPerson{avsPersonPersonCards=cards}
      | notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards
    _otherwise        -> AvsResponseStatus   mempty

-- TODO: delete deprecated Utility Functions from Utils.Avs as well -- still needed, since avsStatusQuery does not deliver company names tied to cards
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                  AvsPersonId -> m (Maybe AvsDataPerson)
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)

-- | retrieves complete avs user records for given AvsPersonIds.
--   Note that this requires several AVS-API queries, since
--    - avsQueryPerson does not support querying an AvsPersonId directly
--    - avsQueryStatus only provides limited information
--   avsQuery is used to obtain all card numbers, which are then queried separately an merged
--   May throw Servant.ClientError or AvsExceptions
--   Does not write to our own DB!
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                   Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
lookupAvsUsers apis = do
  AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
  -- $logInfoS "AVS-2" [st|Statuses for #{tshow apis} lieferte #{tshow statuses} |]    -- DEBUG
  let forFoldlM = $(permuteFun [3,2,1]) foldlM
  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
      AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
      -- $logInfoS "AVS-3" [st|PersonSearch for card #{tshow $ avsCardNo avsDataCardNo}.#{avsDataVersionNo} lieferte #{tshow adps} |]    -- DEBUG
      return $ mergeByPersonId adps acc2


-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
updateReceivers :: UserId -> Handler  (Entity User, [Entity User], Bool)
updateReceivers uid = do
  -- First perform AVS update for receiver
  runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
      Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ runDB $ updateAvsUserById apid
      Nothing -> return ()
  -- Retrieve updated user and supervisors now
  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
    <$> getJustEntity uid
    <*> (E.select $ do
          (usrSuper :& usrAvs) <-
            E.from $     E.table @UserSupervisor
            `E.leftJoin` E.table @UserAvs
            `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
          E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
              E.&&.  (usrSuper E.^. UserSupervisorRerouteNotifications)
          pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
        )
  let (superVs, avsIds) = unzip avsSupers
      receiverIDs :: [UserId] = E.unValue <$> superVs
      toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
      directResult = return (underling, pure underling, True)             -- already contains updated address
  runDB $ forM_ toUpdate (catchAll2log . updateAvsUserById)   -- attempt to update postaddress from AVS
  if null receiverIDs
    then directResult
    else do
      receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
      if null receivers
        then directResult
        else return (underling, receivers, uid `elem` (entityKey <$> receivers))


------------------
-- CR3 Functions


-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
class SomeAvsQuery q where
  type SomeAvsResponse q :: Type
  pickQuery       :: (MonadIO m) => AvsQuery -> q -> m (Either ClientError (SomeAvsResponse q))
  -- | send query to AVS or maybe look it up within cache, depending on the type of the query
  avsQuery        :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
  avsQuery        = avsQueryNoCache
  -- | send query to AVS directly, never cached
  avsQueryNoCache :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
  avsQueryNoCache = avsQueryNoCacheDefault

avsQueryNoCacheDefault :: (SomeAvsQuery q
                  ,   MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
avsQueryNoCacheDefault qry = do
    qfun <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ preview (_appAvsQuery . _Just . to pickQuery)
    throwLeftM $ qfun qry

avsQueryCached :: (SomeAvsQuery q, Binary q, Binary (SomeAvsResponse q), Typeable (SomeAvsResponse q)
                  ,   MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => q -> m (SomeAvsResponse q)
avsQueryCached qry =
  getsYesod (preview $ _appAvsConf . _Just . _avsCacheExpiry) >>= \case
    Just t | t > 1  -> memcachedBy (Just $ Right t) qry $ avsQueryNoCache qry
    _               ->                                    avsQueryNoCache qry

instance SomeAvsQuery AvsQueryPerson where
  type SomeAvsResponse AvsQueryPerson = AvsResponsePerson
  pickQuery = avsQueryPerson
  avsQuery  = avsQueryCached

instance SomeAvsQuery AvsQueryStatus where
  type SomeAvsResponse AvsQueryStatus = AvsResponseStatus
  pickQuery = avsQueryStatus
  avsQuery  = avsQueryCached

instance SomeAvsQuery AvsQueryContact where
  type SomeAvsResponse AvsQueryContact = AvsResponseContact
  pickQuery = avsQueryContact
  avsQuery  = avsQueryCached

instance SomeAvsQuery AvsQuerySetLicences where
  type SomeAvsResponse AvsQuerySetLicences = AvsResponseSetLicences
  pickQuery = avsQuerySetLicences
  -- NOTE: avsQuery  = avsQueryCached -- should not and indeed does not compile
  avsQueryNoCache qry = avsQueryNoCacheDefault qry
    <* memcachedInvalidate (Proxy @AvsResponseContact) -- invalidate all AvsResponseContact which may contain RampLicence info, since keys may comprise several ids

instance SomeAvsQuery AvsQueryGetAllLicences where
  type SomeAvsResponse AvsQueryGetAllLicences = AvsResponseGetLicences
  pickQuery = const . avsQueryGetAllLicences



queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId)
queryAvsCardNos = foldMapM queryAvsCardNo

queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId)
queryAvsCardNo crd = do
    AvsResponsePerson adps <- avsQuery $ qry crd
    return $ Set.map avsPersonPersonID adps
  where
    qry (Left acno)               = def{ avsPersonQueryCardNo     = Just acno }
    qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo     = Just avsFullCardNo
                                       , avsPersonQueryVersionNo  = Just avsFullCardVersion
                                       }

-- | Queries AVS Status to retrieve primary card (heursitic)
queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
queryAvsPrimaryCard api = runMaybeT $ do
  AvsResponseStatus res <- MaybeT . catchAVS2log . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
  pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
  hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus

-- | Queries AVS to retrieve CardNo from primary card (heursitic)
queryAvsFullCardNo ::  (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard


-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do
  AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
  let res = Set.filter ((== apid) . avsContactPersonID) adcs
  snd <<$>> traverseJoin updateAvsUserByADC (Set.lookupMax res)

-- | Variant of `updateAvsUserByIds'` that catches and logs all exceptions
updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId))
updateAvsUserByIds = catchAVShandler True True False mempty . updateAvsUserByIds'

-- | Update given AvsPersonIds by querying AVS for each; update only, no insertion! Uses batch mechanism and should not throw. Each user dealt within own runDB, i.e. own DB transaction
updateAvsUserByIds' :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId))
updateAvsUserByIds' apids = do
    -- apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0 --not needed anymore, we expect the set to be linked
    AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched
    let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order)
    (oks,bad) <- foldlM procResp mempty requestedAnswers
    let missing = Set.toList $ Set.difference (Set.difference apids $ Set.map fst oks) bad
    unless (null missing) $ do
      now <- liftIO getCurrentTime
      runDB $ updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Avs contact info unknown for AvsPersonId"] -- all others were already marked as updated
    return oks
  where
    procResp :: (Set (AvsPersonId, UserId), Set AvsPersonId) -> AvsDataContact -> Handler (Set (AvsPersonId, UserId), Set AvsPersonId)
    procResp (accOk, accBad) adc = do
      let errHandler e = runDB $ do
            let apid = avsContactPersonID adc
            now <- liftIO getCurrentTime
            updateBy (UniqueUserAvsId apid) [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just (tshow e)]
            return (accOk, Set.insert apid accBad)
          updateAvsUserByADC' :: DB (Set (AvsPersonId, UserId), Set AvsPersonId)
          updateAvsUserByADC' = do
            res <- updateAvsUserByADC adc
            return (maybeInsert res accOk, accBad)
      catchAll (runDB updateAvsUserByADC') errHandler



updateAvsUserByADC :: AvsDataContact -> DB (Maybe (AvsPersonId, UserId))
updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMaybeT $ do
      (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid
      let usrId = userAvsUser usravs
      usr <- MaybeT $ get usrId
      lift $ do -- maybeT no longer needed from here onwards
        uuid :: CryptoUUIDUser <- encrypt usrId
        $logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
        let oldAvsPersonInfo  = userAvsLastPersonInfo usravs   -- Nothing is ok here
            oldAvsFirmInfo    = userAvsLastFirmInfo   usravs   -- Nothing is ok here
            oldAvsCardNo      = userAvsLastCardNo     usravs & fmap Just
            oldAvsDataContact = case (oldAvsPersonInfo, oldAvsFirmInfo) of
                                  (Just oapi, Just oafi) -> Just $ AvsDataContact apid oapi oafi
                                  _ -> Nothing
        newAvsCardNo <- queryAvsFullCardNo apid               -- Nothing os ok here, does not throw
        now <- liftIO getCurrentTime
        mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire
        ldap_ups <- if  | Just ldapExpire   <- mbLdapExpire
                        , maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr)
                        , Just udep <- userCompanyDepartment usr
                        , let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
                              depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP
                          -> do -- LDAP sync invalid/expired
                            usrComp <- getBy $ UniqueUserCompany usrId depKey
                            whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do
                              delete ucKey
                              when isSuper $ reportAdminProblem $ AdminProblemSupervisorLeftCompany usrId depKey rroute
                            return  [ UserCompanyDepartment     =. Nothing
                                    , UserCompanyPersonalNumber =. aipn
                                    , UserLdapPrimaryKey        =. aipn
                                    ]
                        | otherwise
                          -> return $ mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $
                              bcons (isJust $ newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo)
                              (mkCheckUpdate CU_API_UserLdapPrimaryKey)
                              [mkCheckUpdate CU_API_UserCompanyPersonalNumber]
        let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo . mkCheckUpdate)
                      [ CU_API_UserFirstName
                      , CU_API_UserSurname
                      , CU_API_UserDisplayName
                      , CU_API_UserBirthday
                      , CU_API_UserMobile
                      , CU_API_UserMatrikelnummer
                      -- , CU_API_UserCompanyPersonalNumber -- needs special treatment, see ldap_ups above
                      ]
            eml_up  = mkUpdate  usr newAvsDataContact oldAvsDataContact $ mkCheckUpdate CU_ADC_UserDisplayEmail                            -- DisplayEmail updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
            -- eml_up2 = mkUpdate  usr newAvsFirmInfo   oldAvsFirmInfo     $ mkCheckUpdate CU_AFI_UserEmail                                -- Email update erfolgt nur, wenn hier die SuperiorEmail als Fallback gespeichert wurde; UserEmail Uniqueness nicht gewährleistet
            frm_up  = mkUpdate' usr newAvsFirmInfo   oldAvsFirmInfo     $ mkCheckUpdate CU_AFI_UserPostAddress                             -- Legacy, if company postal is stored in user; should no longer be true for new users, since company address should now be referenced with UserCompany instead
            pin_up0 = mkUpdate  usr newAvsCardNo     oldAvsCardNo       $                                                                  -- Maybe update PDF pin to latest card
                        CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
            usr_up1 = mconss [eml_up, frm_up] $ ldap_ups <> per_ups
            avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
                      [ UserAvsLastSynch      =. now
                      , UserAvsLastSynchError =. Nothing
                      , UserAvsLastPersonInfo =. Just newAvsPersonInfo
                      , UserAvsLastFirmInfo   =. Just newAvsFirmInfo
                      , UserAvsLastCardNo     =. newAvsCardNo
                      ]

        usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
          -- update company association & supervision
          newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
          upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId   -- ensure firmInfo superior is supervisor for this user
          oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
          primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
          let oldCompanyId = entityKey <$> oldCompanyEnt
              -- oldCompanyMb = entityVal <$> oldCompanyEnt
              -- pst_up  = if
              --           -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId                                              -- refactor could replace next 4 lines
              --           --   -> mkUpdate'      usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
              --           | isNothing oldCompanyMb
              --             -> mkUpdateDirect usr newCompany              $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- always update if company association is fresh (case should not occur in practice though)
              --           | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
              --             -> mkUpdate       usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal  -- possibly change postal preference
              --           | otherwise
              --             -> Nothing
              superReasonComDef = tshow SupervisorReasonCompanyDefault
              newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
              -- pin_up :: Maybe (Update User)
              -- pin_up = guardOnM (newCompanyEnt ^. _entityVal . _companyPinPassword) pin_up0
              -- base_up :: [Update User]
              -- base_up = maybeToList pin_up -- catMaybes [pin_up]
              -- -- Use above if we gain more base updates --
              base_up :: [Update User]
              base_up = guardMonoid (newCompanyEnt ^. _entityVal . _companyPinPassword) (maybeToList pin_up0)

          case oldAvsFirmInfo of
            _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
                -> do                                                                           --  => do nothing
                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company id unchanged.|]
                    return base_up
            (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi)
                        && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
                        || isJust    (view _avsFirmPrimaryEmail       oafi)
                        && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
                -> do                                                                           --  => just update user company association, keeping supervision privileges
                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company address unchanged, just updating.|]
                    case oldCompanyId of
                      Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
                      Just ocid -> do
                        void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId)  -- keep default supervisor settings
                        void $ updateWhere [ UserSupervisorSupervisor ==. usrId                                               -- update company-related supervisions
                                           , UserSupervisorCompany ==. Just ocid                                              -- to new company, regardless of
                                           , UserSupervisorReason ==. Just superReasonComDef]                                 -- user
                                           [ UserSupervisorCompany =. Just newCompanyId]
                    return base_up
            _ | Just newCompanyId == primaryCompanyId                                           -- old primaryCompany is now also AVS-company
                -> do
                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Primary company unchanged.|]
                    whenIsJust oldCompanyId $ \oldCid -> do
                      deleteBy $ UniqueUserCompany usrId oldCid
                      deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
                    return base_up
            _                                                                                   -- company changed completely
                -> do
                    (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
                    $logInfoS "Supervision" [st|updateAvsUserByADC for #{tshow usrId} to new company #{unCompanyKey newCompanyId} from old company #{oldCompanyId} having primary company #{primaryCompanyId}. Company switched. #{length pst_up} updates. #{length problems} problems.|]
                    mapM_ reportAdminProblem problems
                    -- Following line does not type, hence additional parameter needed
                    -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
                    return $ base_up <> pst_up
                    -- SPECIALISED CODE, PROBABLY DEPRECATED
                    -- switch user company, keeping old priority
                    -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
                    --   Nothing ->
                    --     void $ insertUnique newUserComp
                    --   Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
                    --     when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
                    --     delete ucidOld
                    --     void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
                    -- -- adjust supervision
                    -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
                    -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
                    -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
                    -- addDefaultSupervisors' newCompanyId $ singleton usrId
                    -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
                    -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
                    -- return pst_up
        update usrId usr_up2                                         -- update user by company switch first (due to possible conflicts with usr_up2)
        update usrId usr_up1                                         -- update user eventually
        update uaId  avs_ups                                         -- update stored avsinfo for future updates
      return (apid, usrId)


linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do
    ips <- runDBRead $ E.select $ do
      usr <- E.from $ E.table @User
      let uid = usr E.^. UserId
          ipn = usr E.^. UserCompanyPersonalNumber
      E.where_ $ E.isJust ipn
          E.&&. uid `E.in_` E.vals uids
          E.&&. E.notExists (do
              usrAvs <- E.from $ E.table @UserAvs
              E.where_ $ uid E.==. usrAvs E.^. UserAvsUser
            )
      return (uid, ipn)
    mapM_ procUsr ips
  where
    procUsr (E.Value uid, E.Value (Just ipn)) = catchAll2log $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
    procUsr _ = return ()

-- | similar to 'upsertAvsUserByCard', but accounts for the known UserId
linktoAvsUserByUID :: UserId -> AvsInternalPersonalNo -> Handler ()
linktoAvsUserByUID uid aipn = do
  AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryInternalPersonalNo = Just aipn}
  case Set.elems adps of
    []      -> throwM AvsPersonSearchEmpty
    (_:_:_) -> throwM AvsPersonSearchAmbiguous
    [AvsDataPerson{avsPersonPersonID=api}] ->
      void $ createAvsUserById (Just uid) api

-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
createAvsUserById muid api = do
  AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
  case Set.toList contactRes of
    []      -> throwM $ AvsUserUnknownByAvs api
    (_:_:_) -> throwM $ AvsUserAmbiguous    api
    [adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
      | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
      | otherwise -> do
        -- check for matching existing user
        let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
            -- persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
        oldUsr <- runDB $ do
          mbUid <- firstJustM $ return muid : maybe [] (\ipn ->
                [ getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn] -- must ensure filter isnt ==. Nothing
                , catchAll2log' (Just . entityKey <$> ldapLookupAndUpsert ipn) -- attempt to insert by LDAP first
                ]
                ) internalPersNo
          mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
          return (mbUid, mbUAvs)
        usrCardNo <- queryAvsFullCardNo api
        now <- liftIO getCurrentTime
        let usrAvs uid  mbPersonInfo mbFirmInfo mbUsrCardNo = UserAvs
                  { userAvsPersonId       = api
                  , userAvsUser           = uid
                  , userAvsNoPerson       = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
                  , userAvsLastSynch      = now
                  , userAvsLastSynchError = Nothing
                  , userAvsLastPersonInfo = mbPersonInfo
                  , userAvsLastFirmInfo   = mbFirmInfo
                  , userAvsLastCardNo     = mbUsrCardNo
                  }
        case oldUsr of
          (Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
          (Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}})
            | api /= api' -> throwM $ AvsIdMismatch api api'
            | uid /= uid' -> throwM $ AvsUserAmbiguous api
            | otherwise   -> return uid                         -- nothing to do
          (Just uid, Nothing) -> runDB $ do                     -- link with matching exisitng user
            insert_ $ usrAvs uid Nothing Nothing Nothing        -- all infos must be Nothing for subsequent update to work as intended
            updRes <- updateAvsUserById api                     -- no loop, since updateAvsUserById does not call createAvsUserById
            case updRes of
              Nothing         -> throwM $ AvsUserUnknownByAvs api
              Just uid'
                | uid /= uid' -> throwM $ AvsUserAmbiguous api
                | otherwise   -> return uid
          (Nothing, Nothing) -> do                              -- create fresh user
            Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
            let pinPass = guardMonoid (cmp ^. _companyPinPassword) (avsFullCardNo2pin <$> usrCardNo)
                -- superiorEmail = filterMaybe validEmail $ adc ^. _avsContactFirmInfo . _avsFirmEMailSuperior
                newUserData = AddUserData
                  { audTitle            = Nothing
                  , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
                  , audSurname          = cpi ^. _avsInfoLastName     & Text.strip
                  , audDisplayName      = cpi ^. _avsInfoDisplayName
                  , audDisplayEmail     = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI
                  , audEmail            = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI
                  , audIdent            = "AVSID:" <> ciShow api
                  , audAuth             = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
                  , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just
                  , audSex              = Nothing
                  , audBirthday         = cpi ^. _avsInfoDateOfBirth
                  , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo
                  , audTelephone        = Nothing
                  , audFPersonalNumber  = internalPersNo
                  , audFDepartment      = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
                  , audPostAddress      = Nothing -- always use company address indirectly
                  , audPrefersPostal    = cmp ^. _companyPrefersPostal
                  , audPinPassword      = pinPass
                  }
            runDB $ do        -- any failure must rollback all DB write transactions here
              uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
              let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done
              void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
              -- Supervision
              void $ addDefaultSupervisors' cid $ singleton uid
              -- Save AVS data for future updates
              insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
              return uid


-- getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
-- getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany

-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
getAvsCompany afi =
  let compName      :: CompanyName
      compName       = afi ^. _avsFirmFirm . from _CI
      compShorthand :: CompanyShorthand
      compShorthand  = afi ^. _avsFirmAbbreviation . from _CI
      compAvsId      = afi ^. _avsFirmFirmNo
  in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future
        guardMonoid (compAvsId > 0)
        [ getBy     $ UniqueCompanyAvsId  compAvsId
        , getEntity $ CompanyKey        $ compShorthand <> "-" <> ciShow compAvsId
        ] <>
        [ getByFilter [CompanyName ==.    compName]
        , getEntity $ CompanyKey          compShorthand
        ]

-- | insert a company from AVS firm info or update an existing one based on previous values
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
--   | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo  -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
    mbFirmEnt <- getAvsCompany newAvsFirmInfo --  primarily by AvsId, then Shorthand, then name
    $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
    case mbFirmEnt of
      Nothing -> do                                                                                  -- insert new company, neither AvsId nor Shorthand exist in DB
        afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
                then return $ newAvsFirmInfo ^. _avsFirmFirmNo
                else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
        let upd  = flip updateRecord newAvsFirmInfo
            dmy = Company                                                                            -- mostly dummy, values are actually produced through firmInfo2company below for consistency
                  { companyName           = newAvsFirmInfo ^. _avsFirmFirm          . from _CI
                  , companyShorthand      = newAvsFirmInfo ^. _avsFirmAbbreviation  . from _CI
                  , companyAvsId          = afn
                  , companyPrefersPostal  = True
                  , companyPostAddress    = newAvsFirmInfo ^. _avsFirmPostAddress
                  , companyEmail          = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
                  , companyPinPassword    = True
                  }
            cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
        $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
        newCmp <- insertEntity cmp
        reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
        return newCmp

      (Just Entity{entityKey=firmid, entityVal=firm}) -> do                                          -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
        let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
            oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
            cmp_ups = mapMaybe  (mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
            key_ups =            mkUpdate'            firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2key
        uniq_ups    <-           mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo  firmInfo2companyNo
        $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
        res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups
        let cmp_id  = res_cmp ^. _entityVal . _companyAvsId
        res_cmp2 <- case key_ups of
          Just key_up | cmp_id > 0 -> do
            $logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id
            let uniq_cmp = UniqueCompanyAvsId cmp_id
                cmp_key  = newAvsFirmInfo ^. _avsFirmAbbreviation  . from _CI
                alt_key  = cmp_key <> "-" <> ciShow cmp_id
            key_ok <- notExists [CompanyShorthand ==. cmp_key]
            alt_ok <- notExists [CompanyShorthand ==. alt_key]
            if | key_ok -> updateBy uniq_cmp [key_up]                                                      -- this is ok, since we have OnUpdateCascade on all CompanyId entries
               | alt_ok -> updateBy uniq_cmp [CompanyShorthand =. alt_key]
               | otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
            maybeM (return res_cmp) return $ getBy uniq_cmp
          _otherwise -> return res_cmp
        $logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
        return res_cmp2
  where
    firmInfo2key =
        CheckUpdate CompanyShorthand   $ _avsFirmAbbreviation  . from _CI  -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
    firmInfo2companyNo =
        CheckUpdate CompanyAvsId         _avsFirmFirmNo                    -- Updating a unique needs special considerations; AVS does not update FirmNo, but for legacy reasons we might have companies without a number
    firmInfo2company =
      [ CheckUpdate CompanyName        $ _avsFirmFirm          . from _CI
      , CheckUpdate CompanyPostAddress   _avsFirmPostAddress
      , CheckUpdate CompanyEmail       $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
      -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal          -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
      -- , CheckUpdate CompanyPinPassword -- same as for FirmPrefersPostal
      ]


-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
  let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
      getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
      newAvsNo    = newAfi ^.         _avsFirmFirmNo
      oldAvsNo    = oldAfi ^? _Just . _avsFirmFirmNo
      mbSupEmail  = newAfi ^.         _avsFirmEMailSuperior
      mbOldEmail  = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
      getSupId    =  getInsertUid                `traverseJoin` mbSupEmail
      getOldId    = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
      getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
      getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
      unchangedCompany = oldAvsNo   == Just newAvsNo
      changedSuperior  = mbSupEmail /= mbOldEmail     -- beware we only have AvsFirmInfo for one user; also both could be Nothing
      --   1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
      --   2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
      --   3. unchangedCompany && changedSuperior: update superior for all users
  in unless (unchangedCompany && not changedSuperior) $ do      -- do nothing if (unchangedCompany && not changedSuperior).
    mbSupId  <- getSupId
    mbUsrSup <- getSupervision mbSupId
    -- delete old superiors, if any
    when (unchangedCompany && changedSuperior) $
      deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
                          [ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
    unless unchangedCompany $
      deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
    -- ensure superior supervision
    case (mbSupId, mbUsrSup) of
      (_          , Just _) -> return () -- supId is already supervisor for uid for any reason
      (Just supId, Nothing) -> do
        -- ensure association between company and superior at equal-to-top priority
        prio <- getCompanyUserMaxPrio supId
        void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations

        -- ensure all company associates are irregularly supervised by the superior
        E.insertSelectWithConflict UniqueUserSupervisor
          (do
            usr <- E.from $ E.table @UserCompany
            E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
                -- E.&&. E.notExists (do                                                              -- restrict to primary company only
                --     othr <- E.from $ E.table @UserCompany
                --     E.where_ $ othr E.^. UserCompanyPriority E.>.  usr E.^. UserCompanyPriority
                --         E.&&.  othr E.^. UserCompanyUser     E.==. usr E.^. UserCompanyUser
                --         E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
                --   )
            return $ UserSupervisor
              E.<#  E.val supId
              E.<&> (usr E.^. UserCompanyUser)
              E.<&> E.false
              E.<&> E.justVal cid
              E.<&> E.val reasonSuperior
          )
          (\_old new ->
            [ UserSupervisorCompany               E.=. new E.^. UserSupervisorCompany
            , UserSupervisorReason                E.=. new E.^. UserSupervisorReason
            , UserSupervisorRerouteNotifications  E.=. new E.^. UserSupervisorRerouteNotifications
            ]
          )
        when (unchangedCompany && changedSuperior) $ do
          oldSupId <- getOldId
          reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
      (Nothing, Nothing) ->
        when (unchangedCompany && changedSuperior) $ do
          oldSupId <- getOldId
          reportAdminProblem $ AdminProblemCompanySuperiorNotFound usrId mbSupEmail cid oldSupId

-- | queue AVS synch for several UserIds, if a day is given, the last synch must be before the date to trigger an update
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User)    (E.^. UserId)      (\usr    -> usr E.^. UserId             `E.in_` E.vals uids)

queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> DB Int64
queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUser) (\usrAvs -> usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids)

-- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
queueAvsUpdateAux tbl prj fltr pause = do
  now <- liftIO getCurrentTime
  n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
        ( do
            usr <- E.from tbl
            E.where_ $ fltr usr
            return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause)
        ) (\current excluded ->
            [ AvsSyncCreationTime E.=. E.least    (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
            , AvsSyncPause        E.=. E.greatest (current E.^. AvsSyncPause)        (excluded E.^. AvsSyncPause)
            ]
        )
  runDBJobs' $ queueDBJob JobSynchroniseAvsQueue
  return n


-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;
--   fail-safe, may or may not update existing users, may insert new users
--   If an existing User with internal number is found, an AVS update query is executed
guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
  | prefix=="AVSID:" =
      let avsid = AvsPersonId nr in
      runDBRead (getBy $ UniqueUserAvsId avsid)          >>= \case
        (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
        Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
  | prefix=="AVSNO:" =
      runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
    catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
      Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
        runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
      other -> return other
guessAvsUser someid = do
    try (runDB $ ldapLookupAndUpsert someid) >>= \case
      Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
        let ldapUid = Just uid
        avsUid <- catchAVS2message $ upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo
        unless (ldapUid == avsUid) $ addMessageI Warning MsgAvsPersonSearchAmbiguous
        return ldapUid
      Right Entity{entityKey=uid} -> return $ Just uid
      other -> do -- attempt to recover by trying other ids
        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
        runDB . runMaybeT $
                MaybeT (guessUserByEmail $ stripCI someid)              -- recall that monadic actions are only executed until first success here
            <|> MaybeT (getKeyByFilter [UserDisplayName  ==. someid])


-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId)
upsertAvsUserByCard persNo = do
  let qry = case persNo of
        Left fpn
          -> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
        Right AvsFullCardNo{..}
          -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
          -- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
  AvsResponsePerson adps <- avsQuery qry
  case Set.elems adps of
    []      -> return Nothing -- throwM AvsPersonSearchEmpty -- since return a Maybe, there is no need to throw here
    (_:_:_) -> throwM AvsPersonSearchAmbiguous
    [AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update


-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS licence status. Updates company, address, PinPassword
--   Throws errors if the avsInterface in unavailable or new user would violate uniqueness constraints
upsertAvsUserById :: AvsPersonId -> Handler UserId
upsertAvsUserById api = do
  upd <- runDB (updateAvsUserById api)
  case upd of
    Nothing     -> createAvsUserById Nothing api -- attempts to link to exisiting user vie UserCompanyPersonalNumber
    (Just uid)  -> return uid

-- Licences
setLicence :: (PersistUniqueRead backend, MonadThrow m,
                     MonadHandler m, HandlerSite m ~ UniWorX,
                     BaseBackend backend ~ SqlBackend) =>
                    UserId -> AvsLicence -> ReaderT backend m Bool
setLicence uid lic =
  getBy (UniqueUserAvsUser uid) >>= \case
    Just Entity{entityVal=UserAvs{userAvsPersonId=api}} -> setLicenceAvs api lic
    Nothing -> do
      uname <- userDisplayName <<$>> get uid
      throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname

setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                  AvsPersonId -> AvsLicence -> m Bool
setLicenceAvs apid lic = do
  let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
  (1 ==) <$> setLicencesAvs req


--setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                  Set AvsPersonLicence -> m Int
setLicencesAvs = aux 0
  where
    aux batch0_ok pls
      | Set.null pls = return batch0_ok
      | otherwise = do
        let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
        response <- avsQueryNoCache $ AvsQuerySetLicences batch1
        case response of
          AvsResponseSetLicencesError{..} -> do
            let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
            $logErrorS "AVS" msg
            throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus

          AvsResponseSetLicences msgs -> do
            let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
                ok_ids = Set.map avsResponsePersonID ok
                bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
                batch1_ok = Set.size ok
            forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
              $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
            aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)

{- NOT USED ANYWHERE:
--   Retrieve all currently valid driving licences and check against our database
--   Only react to changes as compared to last seen status in avs.model
synchAvsLicences :: Handler Bool
synchAvsLicences = do
  allLicences   <- avsQueryNoCache AvsQueryGetAllLicences
  deltaLicences <- computeDifferingLicences allLicences
  setResponse   <- setLicencesAvs deltaLicences
  let setOk = setResponse == Set.size deltaLicences
  if setOk
    then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
    else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
  return setOk
-}


data AvsLicenceDifferences = AvsLicenceDifferences
    { avsLicenceDiffRevokeAll      :: Set AvsPersonId   -- revoke all driving licences in AVS (set 0)
    , avsLicenceDiffGrantVorfeld   :: Set AvsPersonId   -- grant apron driving licence in AVS (set 1, upgrade from 0)
    , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId   -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2)
    , avsLicenceDiffGrantRollfeld  :: Set AvsPersonId   -- grant maneuvering area driving licence (set 2)
    }
  deriving (Show)

#ifndef DEVELOPMENT
-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions
  [ avsLicenceDiffRevokeAll
  , avsLicenceDiffGrantVorfeld
  , avsLicenceDiffRevokeRollfeld
  , avsLicenceDiffGrantRollfeld
  ]
#endif

avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
     Set.map (AvsPersonLicence AvsNoLicence)       avsLicenceDiffRevokeAll
  <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  avsLicenceDiffGrantVorfeld
  <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  avsLicenceDiffRevokeRollfeld
  <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld

computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
computeDifferingLicences = fmap (avsLicenceDifferences2personLicences . fst) . getDifferingLicences

type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)

avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]

retrieveDifferingLicences :: Handler (AvsLicenceDifferences, Set AvsPersonId)
retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False

retrieveDifferingLicencesStatus :: Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard)
retrieveDifferingLicencesStatus = retrieveDifferingLicences' True

retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId),  AvsPersonIdMapPersonCard)
retrieveDifferingLicences' getStatus = do
#ifdef DEVELOPMENT
  avsUsrs <- runDBRead $ selectList [] [LimitTo 444]
  let allLicences = AvsResponseGetLicences $ Set.fromList $
        [ AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 77         -- AVS:1 FD:2
        , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678   -- AVS:2 FD:1
        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 5          -- AVS:1 FD:0 (nichts)
        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 2          -- AVS:1 FD:0 (ungültig)
        -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
        ] ++ [AvsPersonLicence (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid
             | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs
             ]
#else
  allLicences  <- avsQueryNoCache AvsQueryGetAllLicences
#endif
  lDiff <- getDifferingLicences allLicences
#ifdef DEVELOPMENT
  let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
      lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
      fakes = Set.fromList $
              [ AvsStatusPerson (AvsPersonId 77      ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
              , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True  AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True  AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
              , AvsStatusPerson (AvsPersonId 5       ) $ Set.fromList [mkAdpc True  AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True  AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
              , AvsStatusPerson (AvsPersonId 2       ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
              ] <>
              [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else
  let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff
  lStat <- if getStatus && notNull statQry
            then avsQueryNoCache (AvsQueryStatus statQry)
              -- `catch` handler
              -- let handler _exception = do
              --       addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry
              --       return $ AvsResponseStatus mempty
            else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
#endif
  return (lDiff, avsResponseStatusMap lStat)


getDifferingLicences :: AvsResponseGetLicences -> Handler (AvsLicenceDifferences, Set AvsPersonId)
getDifferingLicences (AvsResponseGetLicences licences) = do
  now <- liftIO getCurrentTime
  --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld)  licences
  --     rollfeld             = Set.filter    (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
  -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
  let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence)      licences        -- antitone is ok, see test/Utils/TypesSpec -> "Ord AvsPersonLicence"
      rollfeld'      = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
      vorORrollfeld  = Set.map avsLicencePersonID vorORrollfeld'
      rollfeld       = Set.map avsLicencePersonID rollfeld'

      antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBReadUq (Set AvsPersonId,Set AvsPersonId)
      -- antijoinAvsLicences :: forall backend . (BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend)
      --                     => AvsLicence -> Set AvsPersonId -> ReaderT backend (HandlerFor UniWorX) (Set AvsPersonId,Set AvsPersonId)
      antijoinAvsLicences lic avsLics = fmap unwrapIds $
       E.select $ do
        ((_qauli :& _qualUser :& usrAvs) :& excl) <-
          E.from $ (      E.table @Qualification
            `E.innerJoin` E.table @QualificationUser
            `E.on` ( \(quali :& qualUser) ->
                    (quali E.^. QualificationId         E.==. qualUser E.^. QualificationUserQualification)
                -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
              E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
              E.&&. (now `validQualification` qualUser)                                       -- currently valid and not blocked
              )
            `E.innerJoin` E.table @UserAvs
            `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
          ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications
            `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
        E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId)           -- anti join
        return (usrAvs E.?. UserAvsPersonId, excl)

      unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
      unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty
        where
          aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
          aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
          aux _ acc = acc -- should never occur

  ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDBRead $ (,)
    <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
    <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
  let setTo0      = vorfRevoke                    -- revoke driving licences
      setTo1up    = vorfGrant  Set.\\ rollGrant   -- grant apron driving licence
      setTo1down  = rollRevoke Set.\\ vorfRevoke  -- revoke maneuvering area licence, but retain apron driving licence
      setTo2      = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence
      rsChanged   = rollfeld `Set.intersection` Set.unions [vorfRevoke, rollRevoke, setTo1up] -- maneuvering driving licences to downgrade in AVS
      alds = AvsLicenceDifferences
              { avsLicenceDiffRevokeAll      = setTo0
              , avsLicenceDiffGrantVorfeld   = setTo1up
              , avsLicenceDiffRevokeRollfeld = setTo1down
              , avsLicenceDiffGrantRollfeld  = setTo2
              }
  return (alds, rsChanged)
    {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
        A (0,0,0)  -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
        B (0,0,1)  -> ((_,_),(x,_)) : nop; do nothing     -- CHECK since id is returned by roll-query
        C (0,1,0)  -> ((x,_),(_,_)) : set F for id
        D (0,1,1)  -> ((x,_),(x,_)) : set R for id
        E (1,0,0)  -> ((_,x),(_,_)) : set 0 for id
        F (1,0,1)  -> ((_,x),(x,_)) : set 0 for id
        G (1,1,0)  -> ((_,_),(_,_)) : nop
        H (1,1,1)  -> ((_,_),(x,_)) : set R for id
        I (2,0,0)  -> ((_,x),(_,x)) : set 0 for id
        J (2,0,1)  -> ((_,x),(_,_)) : set 0 for id
        K (2,1,0)  -> ((_,_),(_,x)) : set F for id
        L (2,1,1)  -> ((_,_),(_,_)) : nop

        PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
        Results:
            set to 0: determined by vorfeld-unset -- zuerst
            set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
            set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
    -}

-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users
--   If an existing User with internal number is found, an AVS query is executed
guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr -> 
    let avsid = AvsPersonId avsidNr
        maybeAvsUpsert = maybeCatchAll $ upsertAvsUserById avsid
        extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
    in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid
guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno ->
    runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case 
      [Entity _ UserAvs{userAvsUser=uid}] -> Just uid
      _ -> Nothing
guessAvsUser someid = do 
  let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard      
  case discernAvsCardPersonalNo someid of    
    Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid
      -- NOTE: card validity might be outdated, so we must always check with avs
      -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do
      --   let extractUid     (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
      --       extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid
      --   cards <- selectList [UserAvsCardCardNo ==. cardNo] []
      --   case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of 
      --     [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
      --     _ -> return Nothing
    Just cid@(Right _wholeNumber) -> 
      maybeUpsertAvsUserByCard cid >>= \case
        Nothing -> 
          runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case
            [Entity uid _] -> return $ Just uid
            _              -> return Nothing
        uid -> return uid
    Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case
      Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> 
        maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo))
      Right (Just Entity{entityKey=uid}) -> return $ Just uid
      other -> do -- attempt to recover by trying other ids
        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all      
        runDB . runMaybeT $ 
          let someIdent = stripCI someid
          in    MaybeT (getKeyBy $ UniqueEmail          someIdent)
            <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)

-- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid    -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
  try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case
    Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
    other -> do -- attempt to recover by trying other ids
      whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
      apid <- runDB . runMaybeT $ do
        let someIdent = stripCI otherId
        uid <-  MaybeT (getKeyBy $ UniqueEmail          someIdent)
            <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
        MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
      ifMaybeM apid Nothing upsertAvsUserById
            

-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
upsertAvsUserByCard persNo = do
  let qry = case persNo of
              Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
              Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
  AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
  case Set.elems adps of
    []      -> throwM AvsPersonSearchEmpty
    (_:_:_) -> throwM AvsPersonSearchAmbiguous
    [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
      -- do
        -- mbuid <- runDB $ getBy $ UniqueUserAvsId api
        -- case mbuid of
          -- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
          -- Nothing -> upsertAvsUserById api



-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword
--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
upsertAvsUserById api = do
  mbapd <- lookupAvsUser api
  now <- liftIO getCurrentTime
  mbuid <- runDB $ do
    mbuid <- getBy (UniqueUserAvsId api)
    case (mbuid, mbapd) of
      (Nothing, Just AvsDataPerson{..})                         -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
        | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
            $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
            candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
            case candidates of
              [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing)
              (_:_) -> throwM $ AvsUserAmbiguous api
              [] -> do
                upsRes :: Either SomeException (Maybe (Entity User))
                  <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate
                $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
                case upsRes of
                  Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
                  Right Nothing -> do
                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases"
                    return mbuid -- == Nothing -- user could not be created somehow
                  Left err -> do 
                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err
                    return mbuid -- == Nothing -- user could not be created somehow
      (Just Entity{ entityKey = uaid }, _) -> do
        update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch
        return mbuid
      _other -> return mbuid
  $logInfoS "AVS" $ "upsert prestep result: " <> tshow mbuid <> " --- " <> tshow mbapd
  case (mbuid, mbapd) of
    ( _     , Nothing               ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
    (Nothing, Just AvsDataPerson{avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname, ..}) -> do                               -- No LDAP User, but found in AVS; create new user
      let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards
          userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
          pinCard     = Set.lookupMax avsPersonPersonCards
          userPin     = personCard2pin <$> pinCard
          fakeIdent   = CI.mk $ "AVSID:" <> tshow api
          fakeNo      = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo          
          newUsr = AddUserData
            { audTitle            = Nothing
            , audFirstName        = avsFirstName
            , audSurname          = avsSurname
            , audDisplayName      = avsFirstName <> Text.cons ' ' avsSurname
            , audDisplayEmail     = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
            , audMatriculation    = Just $ tshow avsPersonPersonNo
            , audSex              = Nothing
            , audBirthday         = Nothing
            , audMobile           = Nothing
            , audTelephone        = Nothing
            , audFPersonalNumber  = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
            , audFDepartment      = Nothing
            , audPostAddress      = userFirmAddr
            , audPrefersPostal    = True
            , audPinPassword      = userPin
            , audEmail = fakeNo    -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
            , audIdent = fakeIdent -- use AvsPersonId instead
            , audPassword = Nothing
          --, audAuth  = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
            }
      mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
      whenIsJust mbUid $ \uid -> runDB $ do        
        insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing
        forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred
        -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
        -- forM_ cs $  -- only save used cards for the postal address update detection
            \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now
        upsertUserCompany uid mbCompany userFirmAddr
      return mbUid

    (Just (Entity _ UserAvs{userAvsUser=uid})
      , Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword
      let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards          
          userFirmAddr    = plaintextToStoredMarkup <$> mbCoFirmAddr
          pinCard         = Set.lookupMax avsPersonPersonCards
          userPin         = personCard2pin <$> pinCard                          
      runDB $ do        
        update uid  [ UserFirstName             =. avsFirstName      -- update in case of name changes via AVS; might be changed again through LDAP
                    , UserSurname               =. avsSurname
                    , UserDisplayName           =. avsFirstName <> Text.cons ' ' avsSurname
                    , UserMatrikelnummer        =. Just (tshow avsPersonPersonNo)  -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later
                    , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
                    ]     
        oldCards <- selectList [UserAvsCardPersonId ==. api] []
        let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards
        unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do  -- update postal address, unless the exact address had been seen before
          encRecipient :: CryptoUUIDUser <- encrypt uid
          $logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient
          updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr, UserPostLastUpdate =. Just now]
        whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
          unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do
            let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards
            updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged
                        [UserPinPassword =. userPin]
            insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
        upsertUserCompany uid mbCompany userFirmAddr
        forM_ avsPersonPersonCards $ \aCard -> do
          let fcn = getFullCardNo aCard
          -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
          deleteWhere [UserAvsCardCardNo ==. fcn]
          insert_ $ UserAvsCard
            { userAvsCardPersonId  = api
            , userAvsCardCardNo    = fcn
            , userAvsCardCard      = aCard
            , userAvsCardLastSynch = now
            }
      return $ Just uid


lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                  AvsPersonId -> m (Maybe AvsDataPerson)
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)

-- | retrieves complete avs user records for given AvsPersonIds.
--   Note that this requires several AVS-API queries, since
--    - avsQueryPerson does not support querying an AvsPersonId directly
--    - avsQueryStatus only provides limited information
--   avsQuery is used to obtain all card numbers, which are then queried separately an merged
--   May throw Servant.ClientError or AvsExceptions
--   Does not write to our own DB!
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                   Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
lookupAvsUsers apis = do
  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
  AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
  let forFoldlM = $(permuteFun [3,2,1]) foldlM
  forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
      AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
      return $ mergeByPersonId adps acc2


-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
updateReceivers :: UserId -> Handler  (Entity User, [Entity User], Bool)
updateReceivers uid = do
  -- First perform AVS update for receiver
  runDB (getBy (UniqueUserAvsUser uid)) >>= \case 
      Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid
      Nothing -> return ()    
  -- Retrieve updated user and supervisors now
  (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
    <$> getJustEntity uid    
    <*> (E.select $ do
          (usrSuper :& usrAvs) <-
            E.from $     E.table @UserSupervisor            
            `E.leftJoin` E.table @UserAvs
            `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser)
          E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
              E.&&.  (usrSuper E.^. UserSupervisorRerouteNotifications)
          pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId)
        )
  let (superVs, avsIds) = unzip avsSupers
      receiverIDs :: [UserId] = E.unValue <$> superVs      
      toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
      directResult = return (underling, pure underling, True)     -- already contains updated address
  forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById)       -- attempt to update postaddress from AVS  
  if null receiverIDs 
    then directResult
    else do 
      receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
      if null receivers
        then directResult
        else return (underling, receivers, uid `elem` (entityKey <$> receivers))
