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


{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
{-# LANGUAGE TypeApplications #-}

module Handler.Admin.Avs
  ( getAdminAvsR, postAdminAvsR
  , getAdminAvsUserR, postAdminAvsUserR
  , getProblemAvsSynchR, postProblemAvsSynchR
  , getProblemAvsErrorR
  ) where

import Import
import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
-- import qualified Data.Aeson.Encode.Pretty as Pretty
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
import qualified Data.Set  as Set
import qualified Data.Map as Map
-- import Database.Persist.Sql (updateWhereCount)

import Handler.Utils
import Handler.Utils.Avs
-- import Handler.Utils.Qualification
import Handler.Utils.Users (getUserPrimaryCompany)
import Handler.Utils.Company (switchAvsUserCompany)

import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Experimental as E hiding (from, on)
import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils        as E
-- import Database.Esqueleto.Utils.TH


exceptionWgt :: SomeException -> Widget
exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]

tryShow :: MonadCatch m => m Widget -> m Widget
tryShow act = try act >>= \case
  Left  err -> return $ exceptionWgt err
  Right res -> return res

-- Button only needed in AVS TEST; further buttons see below
data ButtonAvsTest = BtnCheckLicences   --  | BtnSynchLicences
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
instance Universe ButtonAvsTest
instance Finite ButtonAvsTest

nullaryPathPiece ''ButtonAvsTest camelToPathPiece

instance Button UniWorX ButtonAvsTest where
  btnLabel    BtnCheckLicences = "Show all licence difference to current AVS"       -- could be msg
  -- btnLabel    BtnSynchLicences = "Synchronize all licences" -- could be msg
  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
  -- btnClasses  BtnSynchLicences = [BCIsButton, BCDanger]
-- END Button


avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
avsCardNoField = convertField AvsCardNo avsCardNo textField

avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo
avsInternalPersonalNoField = convertField mkAvsInternalPersonalNo avsInternalPersonalNo textField

makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
  flip (renderAForm FormStandard) html $ AvsQueryPerson
    <$> aopt avsCardNoField (fslI MsgAvsCardNo)             (avsPersonQueryCardNo              <$> tmpl)
    <*> aopt textField      (fslI MsgAvsVersionNo)          (avsPersonQueryVersionNo           <$> tmpl)
    <*> aopt textField      (fslI MsgAvsFirstName)          (avsPersonQueryFirstName           <$> tmpl)
    <*> aopt textField      (fslI MsgAvsLastName)           (avsPersonQueryLastName            <$> tmpl)
    <*> aopt avsInternalPersonalNoField
                            (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo  <$> tmpl)


validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
validateAvsQueryPerson = do
  AvsQueryPerson{..} <- State.get
  guardValidation MsgAvsQueryEmpty $
    is _Just avsPersonQueryCardNo             ||
    is _Just avsPersonQueryFirstName          ||
    is _Just avsPersonQueryLastName           ||
    is _Just avsPersonQueryInternalPersonalNo ||
    is _Just avsPersonQueryVersionNo

makeAvsStatusForm :: Maybe AvsPersonId -> Form AvsQueryStatus
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
  flip (renderAForm FormStandard) html $
    parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
  where
    parseAvsIds :: Text -> AvsQueryStatus
    parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
      where
        nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
        ids = mapMaybe readMay nonemptys
    unparseAvsIds :: AvsPersonId -> Text
    unparseAvsIds = tshow . avsPersonId

validateAvsQueryStatus :: FormValidator AvsQueryStatus Handler ()
validateAvsQueryStatus = do
  AvsQueryStatus ids <- State.get
  guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)

makeAvsContactForm :: Maybe AvsPersonId -> Form AvsQueryContact
makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
  flip (renderAForm FormStandard) html $
    parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
  where
    parseAvsIds :: Text -> AvsQueryContact
    parseAvsIds txt = AvsQueryContact $ Set.fromList ids
      where
        nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
        ids = mapMaybe (fmap AvsObjPersonId . readMay) nonemptys
    unparseAvsIds :: AvsPersonId -> Text
    unparseAvsIds = tshow . avsPersonId
    --unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids

validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
validateAvsQueryContact = do
  AvsQueryContact ids <- State.get
  guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)


avsLicenceOptions :: OptionList AvsLicence
avsLicenceOptions = mkOptionList
  [ Option
    { optionDisplay       = Text.singleton $ licence2char l
    , optionInternalValue = l
    , optionExternalValue = toJsonText l
    }
  | l <- universeF
  ]

getAdminAvsR,  postAdminAvsR :: Handler Html
getAdminAvsR = postAdminAvsR
postAdminAvsR = do
  mbAvsConf <- getsYesod $ view _appAvsConf
  let avsWgt = [whamlet|
          $maybe avsConf <- mbAvsConf
            <h2>
              AVS Konfiguration
            <ul>
              <li>
                Host:  #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
              <li>
                Timeout sekundäre AVS Abfragen: #{avsTimeout avsConf}s
              <li>
                Cache Gültigkeit sekundäre AVS Abfragen: #{tshow (avsCacheExpiry avsConf)}
          $nothing
            AVS nicht konfiguriert!
        |]

  ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing

  let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
      procFormPerson (fixAvsQueryPerson -> fr) = do
        addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
        try (avsQuery fr) >>= \case
          Left err  -> return $ Just (Just $ exceptionWgt err, Nothing)
          Right (AvsResponsePerson pns) -> do
            let mapid = case Set.toList pns of
                          [AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
                          _ -> Nothing
                wgt = [whamlet|
                        <ul>
                          $forall p <- pns
                            <li>^{jsonWidget p}
                      |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
            return $ Just (toMaybe (notNull pns) wgt, mapid)
  (mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson

  ((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
  let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
      procFormStatus fr = do
        addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
        tryShow $ do
          AvsResponseStatus pns <- avsQuery fr
          return [whamlet|
              <ul>
                $forall p <- pns
                  <li>^{jsonWidget p}
            |]
  mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)

  ((cresult', cwidget), cenctype) <- runFormPost $ makeAvsContactForm mapid
  let cresult = cresult' <|> maybe FormMissing (FormSuccess . AvsQueryContact . Set.singleton . AvsObjPersonId) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
      procFormContact fr = do
        addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
        tryShow $ do
          AvsResponseContact pns <- avsQuery fr
          return [whamlet|
              <ul>
                $forall AvsDataContact{..} <- pns
                  <li>
                    <ul>
                      <li>AvsId: #{tshow avsContactPersonID}
                      <li>^{jsonWidget avsContactPersonInfo}
                      <li>^{jsonWidget avsContactFirmInfo}
            |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
  mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)


  ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
  let procFormCrUsr fr = do
        -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
        res <- try $ guessAvsUser fr
        case res of
          (Right (Just uid)) -> do
            uuid :: CryptoUUIDUser <- encrypt uid
            return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
          (Right Nothing) ->
            return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
          (Left e) -> return $ Just $ exceptionWgt e
  mbCrUser <- formResultMaybe crUsrRes procFormCrUsr

  ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
    flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
                                                <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
                                                <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
  let procFormGetLic fr = tryShow $ do
        AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
        let flics = Set.toList $ Set.filter lfltr lics
            lfltr = case fr of -- not pretty, but it'll do
                (Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
                (Just idmin, Nothing,    Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
                (Nothing   , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
                (Nothing   , Nothing,    Just lic) -> \AvsPersonLicence{..} ->  avsLicenceRampLicence == lic
                (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
                (Just idmin, Nothing,    Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
                (Nothing   , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
                (Nothing   , Nothing,    Nothing ) -> const True
        addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
        return [whamlet|
              <h2>Success:</h2>
              <ul>
                $forall AvsPersonLicence{..} <- flics
                  <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
            |]
  mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)

  ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
    flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
                                                <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
  let procFormSetLic (aid, lic) = do
        res <- try $ setLicenceAvs (AvsPersonId aid) lic
        case res of
          (Right True) ->
            return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
          (Right False) ->
            return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
          (Left e) -> do
            let msg = tshow (e :: SomeException)
            return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
  mbSetLic <- formResultMaybe setLicRes procFormSetLic


  (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
  (mbQryLic :: Maybe Widget, mbAutoDiffs :: Maybe Html) <- case qryLicRes of
    Nothing -> return mempty
    (Just BtnCheckLicences) -> do
      res <- try $ do
        allLicences <- avsQueryNoCache AvsQueryGetAllLicences
        computeDifferingLicences allLicences
      basediffs <- case res of
        (Right diffs) -> do
          let showLics l =
                let chgs = Set.filter ((l ==) . avsLicenceRampLicence) diffs
                in if Set.null chgs
                    then ("[ ]", 0)
                    else (Text.intercalate ", " (tshow . avsLicencePersonID <$> Set.toList chgs), Set.size chgs)
              (r_grant, rg_size) = showLics AvsLicenceRollfeld
              (f_set  , fs_size) = showLics AvsLicenceVorfeld
              (revoke , rv_size) = showLics AvsNoLicence
          return $ Just [whamlet|
              <h2>Licence check AVS-ID differences:
              <dl .deflist>
                <dt .deflist__dt>Grant R (#{rg_size}):
                <dd .deflist__dd>#{r_grant}

                <dt .deflist__dt>Set to F (#{fs_size}):
                <dd .deflist__dd>#{f_set}

                <dt .deflist__dt>Revoke licence (#{rv_size}):
                <dd .deflist__dd>#{revoke}
            |]
        (Left e) -> do
          let msg = tshow (e :: SomeException)
          return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
      autoDiffs <- do
        -- what follows is copy of the code from Jobs.Handler.SynchroniseAvs.dispatchJobSynchroniseAvsLicences modified to not do anything actually
        AvsLicenceSynchConf
          { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
          , avsLicenceSynchReasonFilter = reasonFilter
          , avsLicenceSynchMaxChanges   = maxChanges
          } <- getsYesod $ view _appAvsLicenceSynchConf
        guardMonoidM (synchLevel > 0) $ do
          let showApids apids
                | null apids = "[ ]"
                | otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
              procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
              procLic aLic up apids
                | n <- Set.size apids, n > 0 =
                  let subtype   = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
                  in if NTop (Just n) <= NTop maxChanges
                      then
                        [shamlet|
                          <dt .deflist__dt>#{subtype} (#{n}):
                          <dd .deflist__dd>#{showApids apids}
                        |]
                      else
                        [shamlet|
                          <dt .deflist__dt>#{subtype} (#{n}):
                          <dd .deflist__dd>Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}
                        |]
                | otherwise = mempty

          (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
          -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
          reasonFltrdIds <- ifNothingM reasonFilter mempty $ \reasons -> do
            now <- liftIO getCurrentTime
            firmBlocks <- runDBRead $ E.select $ do
              (uavs :& _qualUser :& qblock) <- X.from $ E.table @UserAvs
                `E.innerJoin` E.table @QualificationUser      `X.on` (\( uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
                `E.innerJoin` E.table @QualificationUserBlock `X.on` (\(_uavs :& qualUser :& qblock) ->
                    qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
                    E.&&. qblock `isLatestBlockBefore'` E.val now)
              E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
                    E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld])
              return $ uavs E.^. UserAvsPersonId
            return $ Set.fromList $ map E.unValue firmBlocks

          let fltrIds
                | synchLevel >= 5 = id
                | synchLevel >= 3 = flip Set.difference   reasonFltrdIds
                | otherwise       = flip Set.difference $ reasonFltrdIds `Set.union` rsChanged

              l1 = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
              l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
              l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
              l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
              avsIdChanges = [shamlet|
                  <h3>
                    Next automatic AVS-ID licence synchronisation:
                  <dl .deflist>
                    ^{l4}
                    ^{l3}
                    ^{l2}
                    ^{l1}
                    $maybe reason <- reasonFilter
                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
                      <dd .deflist__dd>#{showApids reasonFltrdIds}
                |]
          ----------------------------------------------------
          -- translate AVS-IDs to AVS-NOs for convenience only
          avsidnos <- runDBRead $ E.select $ do
            ua <- X.from $ E.table @UserAvs
            E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
            return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
          let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
              translate = setMapMaybe (`Map.lookup` id2no)
              l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence       False $ translate $ fltrIds avsLicenceDiffRevokeAll        --revoke    Vorfeld and maybe also Rollfeld
              l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld  True  $ translate $ fltrIds avsLicenceDiffGrantVorfeld     --grant     Vorfeld
              l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld  False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld   --downgrade Rollfeld -> Vorfeld
              l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True  $ translate $ fltrIds avsLicenceDiffGrantRollfeld    --grant     Rollfeld
              autoNoDiffs =  [shamlet|
                  <h3>
                    Next automatic licence changes translated to human readable AVS-Numbers, if known:
                  <dl .deflist>
                    ^{l4'}
                    ^{l3'}
                    ^{l2'}
                    ^{l1'}
                    $maybe reason <- reasonFilter
                      <dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
                      <dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
                |]
          return $ Just $ avsIdChanges <> autoNoDiffs
      return (basediffs, autoDiffs)

    -- (Just BtnSynchLicences) -> do
    --   res <- try synchAvsLicences
    --   case res of
    --     (Right True) ->
    --       return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
    --     (Right False) ->
    --       return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
    --     (Left e) -> do
    --       let msg = tshow (e :: SomeException)
    --       return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]

  actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
  siteLayoutMsg MsgMenuAvs $ do
    setTitleI MsgMenuAvs
    let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
        personForm  = wrapFormHere pwidget  penctype
        statusForm  = wrapFormHere swidget  senctype
        contactForm = wrapFormHere cwidget  cenctype
        crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
        getLicForm  = wrapFormHere getLicWgt getLicEnctype
        setLicForm  = wrapFormHere setLicWgt setLicEnctype
    -- TODO: use i18nWidgetFile instead if this is to become permanent
    $(widgetFile "avs")

{-

type SynchTableExpr = (                   E.SqlExpr (E.Value AvsPersonId)
                        `E.LeftOuterJoin` E.SqlExpr (Entity UserAvs)
                        `E.LeftOuterJoin` ( E.SqlExpr (Entity Qualification)
                          `E.InnerJoin`     E.SqlExpr (Entity QualificationUser)
                          `E.InnerJoin`     E.SqlExpr (Entity User)
                      ))

type SynchDBRow = (E.Value AvsPersonId, E.Value AvsLicence, Entity Qualification, Entity QualificationUser, Entity User)
-}

-- Buttons only needed for AVS Synching
data ButtonAvsImportUnknown = BtnAvsImportUnknown
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
instance Universe ButtonAvsImportUnknown
instance Finite   ButtonAvsImportUnknown
nullaryPathPiece ''ButtonAvsImportUnknown camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonAvsImportUnknown id
instance Button UniWorX ButtonAvsImportUnknown where
  btnClasses  BtnAvsImportUnknown = [BCIsButton, BCPrimary]

data ButtonAvsRevokeUnknown = BtnAvsRevokeUnknown
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
instance Universe ButtonAvsRevokeUnknown
instance Finite   ButtonAvsRevokeUnknown
nullaryPathPiece ''ButtonAvsRevokeUnknown camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonAvsRevokeUnknown id
instance Button UniWorX ButtonAvsRevokeUnknown where
  btnClasses  BtnAvsRevokeUnknown  = [BCIsButton, BCDanger]


data LicenceTableAction =  LicenceTableChangeAvs
                        |  LicenceTableRevokeFDrive
                        |  LicenceTableGrantFDrive
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LicenceTableAction id

data LicenceTableActionData =  LicenceTableChangeAvsData
                            |  LicenceTableRevokeFDriveData
                              { licenceTableChangeFDriveQId     :: QualificationId
                              , licenceTableChangeFDriveReason  :: Text
                              , licenceTableChangeFDriveNotify  :: Bool
                              }
                            |  LicenceTableGrantFDriveData
                              { licenceTableChangeFDriveQId     :: QualificationId
                              , licenceTableChangeFDriveReason  :: Text
                              , licenceTableChangeFDriveEnd     :: Day
                              , licenceTableChangeFDriveRenew   :: Maybe Bool
                              }
  deriving (Eq, Ord, Read, Show, Generic)


postProblemAvsSynchR,  getProblemAvsSynchR :: Handler Html
postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do
  let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
      catchAllAvs    = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
  ((AvsLicenceDifferences{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
  let mkLicTbl = mkLicenceTable apidStatus rsChanged
  --
  unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
    runDB $ E.select $ do
      (toZero :& usrAvs) <- X.from $
        E.toValues neZeros `E.leftJoin` E.table @UserAvs
        `X.on` (\(toZero :& usrAvs) -> usrAvs E.?. UserAvsPersonId E.==. E.just toZero)
      E.where_ $ E.isNothing (usrAvs E.?. UserAvsPersonId)
      pure toZero
  let unknownLicenceOwners    = E.unValue <$> unknownLicenceOwners'
      numUnknownLicenceOwners = length unknownLicenceOwners

  (btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown
  ifNothingM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do
    res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job
    let procRes (Right _)                           = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty)
        --TODO: continue here!
        --procRes (Left (AvsUserAmbiguous api))     = (Sum 0, Set.singleton api, mempty, mempty)
        --procRes (Left (AvsUserUnknownByAvs api))  = (Sum 0, mempty, Set.singleton api, mempty)
        procRes (Left (err :: SomeException))       = (Sum 0, mempty, mempty, Set.singleton $ tshow err)
        (Sum oks, ambis, unkns, errs) = foldMap procRes res
        ms = if oks == numUnknownLicenceOwners then Success else Warning
    unless (null ambis) $ addMessageModal Error (i18n $ MsgAvsImportAmbiguous $ length ambis) (Right (text2widget $ tshow ambis))
    unless (null unkns) $ addMessageModal Error (i18n $ MsgAvsImportUnknowns  $ length unkns) (Right (text2widget $ tshow unkns))
    unless (null errs)  $ addMessageModal Error (i18n MsgAvsCommunicationError)               (Right (text2widget $ tshow errs ))
    addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
    redirect ProblemAvsSynchR

  (btnRevokeUnknownWgt, btnRevokeUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsRevokeUnknown
  let revokeUnknownExecWgt   = btnRevokeUnknownWgt
      revokeUnknownSafetyWgt = [whamlet|
          <div .form-group >
            <div .form-group__input>
              <div .buttongroup>
                ^{modalBtn}
        |]
      modalBtn = btnModal MsgBtnAvsRevokeUnknown (btnClasses BtnAvsRevokeUnknown) (Right youSureWgt)
      youSureWgt = [whamlet|
          <h1>
            _{MsgAvsRevokeFor (length unknownLicenceOwners)}
          <p>
            ^{revokeUnknownExecWgt}
        |]

  ifNothingM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do
    let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
        no_revokes = Set.size revokes
    oks <- catchAllAvs $ setLicencesAvs revokes
    if oks < no_revokes
      then addMessageI Error MsgRevokeUnknownLicencesFail
      else addMessageI Info  MsgRevokeUnknownLicencesOk
    redirect ProblemAvsSynchR

  -- licence differences
  ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,)
          <$> mkLicTbl "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll
          <*> mkLicTbl "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld
          <*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld
          <*> mkLicTbl "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld

  now <- liftIO getCurrentTime
  let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
      procRes aLic (LicenceTableChangeAvsData       , apids) = do
        oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
        let no_req = Set.size apids
            mkind = if oks < no_req || no_req < 0 then Warning else Success
        addMessageI mkind $ MsgAvsSetLicences aLic oks no_req
        redirect ProblemAvsSynchR -- reload to update all tables

      procRes alic (LicenceTableRevokeFDriveData{..}, apids) = do
        oks <- runDB $ do
          qIds <- selectKeysList [QualificationAvsLicence ==. Just alic] []          -- sanity check
          if licenceTableChangeFDriveQId `notElem` qIds
            then return (-1)
            else do
              uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
              qualificationUserBlocking licenceTableChangeFDriveQId uids False Nothing (Left licenceTableChangeFDriveReason) licenceTableChangeFDriveNotify
        if | oks < 0                      -> addMessageI Error   $ MsgRevokeFraDriveLicencesError alic
           | oks > 0, oks == length apids -> addMessageI Success $ MsgRevokeFraDriveLicences      alic oks
           | otherwise                    -> addMessageI Warning $ MsgRevokeFraDriveLicences      alic oks
        redirect ProblemAvsSynchR -- must be outside runDB

      procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
        (n, Qualification{qualificationShorthand}) <- runDB $ do
          uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
          -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
          void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
          (length uids,) <$> get404 licenceTableChangeFDriveQId
        addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
        redirect ProblemAvsSynchR -- must be outside runDB

  formResult tres2      $ procRes AvsLicenceRollfeld
  formResult tres1down  $ procRes AvsLicenceVorfeld
  formResult tres1up    $ procRes AvsLicenceVorfeld
  formResult tres0      $ procRes AvsNoLicence

  AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf
  siteLayoutMsg MsgAvsTitleLicenceSynch $ do
    setTitleI   MsgAvsTitleLicenceSynch
    $(i18nWidgetFile "avs-synchronisation")

type LicenceTableExpr = (                   E.SqlExpr (Entity UserAvs)
                          `E.InnerJoin`     E.SqlExpr (Entity User)
                          `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUser))
                          `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Qualification))
                          `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
                        )

queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs)
queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)

queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
queryUser    = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1)

queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
queryQualUser      = $(E.sqlLOJproj 4 2)

queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
queryQualification = $(E.sqlLOJproj 4 3)

queryQualBlock :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(E.sqlLOJproj 4 4)

type LicenceTableData = DBRow (Entity UserAvs, Entity User, Maybe (Entity QualificationUser), Maybe (Entity Qualification), Maybe (Entity QualificationUserBlock))

resultUserAvs :: Lens' LicenceTableData (Entity UserAvs)
resultUserAvs = _dbrOutput . _1

resultUser :: Lens' LicenceTableData (Entity User)
resultUser = _dbrOutput . _2

resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _3 . _Just

resultQualification :: Traversal' LicenceTableData (Entity Qualification)
resultQualification = _dbrOutput . _4 . _Just

resultQualBlock :: Traversal' LicenceTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _5 . _Just

instance HasEntity LicenceTableData User where
  hasEntity = resultUser

instance HasUser LicenceTableData where
  hasUser = resultUser . _entityVal

-- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser
--   hasQualificationUser = resultQualUser . _entityVal

mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
  (currentRoute, usrHasAvsRerr) <- liftHandler $ (,)
    <$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute)
    <*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR)
  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName]
  now <- liftIO getCurrentTime

  let nowaday = utctDay now
      avsQids = entityKey <$> avsQualifications
      qualOpts = pure $ qualificationsOptionList avsQualifications
      -- fltrLic qual = if
      --   | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)         -- could be R, F, both or none at all, but has licence in AVS
      --   | otherwise            -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
      fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)
      -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:
      dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do
        E.on $  qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId
          E.&&. qblock `isLatestBlockBefore` E.val now
        E.on $ qual E.?. QualificationId  E.==. qualUser E.?. QualificationUserQualification
        E.on $ user E.^. UserId           E.=?. qualUser E.?. QualificationUserUser
        E.on $ user E.^. UserId           E.==. usrAvs   E.^. UserAvsUser
        E.where_ $ fltrLic qual
            E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
        return (usrAvs, user, qualUser, qual, qblock)
      dbtRowKey =  queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
      -- Not sure what changes here:
      dbtProj = dbtProjId -- Simple $ \(userAvs, user, qualUsr, quali) -> return (userAvs, user, qualUsr, quali)
      dbtColonnade = mconcat
        [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
                                --  (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal
        , colUserNameLink AdminUserR
        , sortable (Just "avspersonno")  (i18nCell MsgAvsPersonNo)    $ \(view  resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
        -- , colUserCompany
        , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
            companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
              E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
              E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
              E.orderBy [E.asc (comp E.^. CompanyName)]
              return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
            let icnSuper  = toWidget $ text2markup " " <> icon IconSupervisor
                companies =
                  (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'

            pure $ intercalate (text2widget "; ") companies
        , sortable (Just "qualification") (i18nCell MsgTableQualifications) $
            if aLic /= AvsLicenceVorfeld
              then
                \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
              else
                \row ->
                  let q       = row ^? resultQualification
                      apid    = row ^. resultUserAvs . _userAvsPersonId
                      warnCell c = if Set.member apid rsChanged
                        then c <> spacerCell <> wgtCell usrHasAvsRerr    -- expected to be effectively dead code in practice, but we never know
                        else c
                  in warnCell $ cellMaybe lmsShortCell q
        , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> cellMaybe dayCell d
        , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> cellMaybe dayCell d
        -- , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> cellMaybe dayCell d
        , sortable (Just "valid-until")      (i18nCell MsgLmsQualificationValidUntil)  $ \row ->
            cellMaybe (qualificationValidUntilCell                nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
        , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
            cellMaybe (qualificationValidReasonCell' Nothing True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser)
        , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal  & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                   ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
        , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
        ]
      dbtSorting = Map.fromList
        [ sortUserNameLink queryUser
        , ("avspersonno"   , SortColumn          $ queryUserAvs        >>> (E.^. UserAvsNoPerson))
        , ("qualification" , SortColumn          $ queryQualification  >>> (E.?. QualificationShorthand))
        , sortUserCompany queryUser
        , ("valid-until"   , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
        , ("last-refresh"  , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserLastRefresh))
        , ("first-held"    , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserFirstHeld))
        , ("blocked"       , SortColumnNeverNull $ queryQualBlock      >>> (E.?. QualificationUserBlockFrom))
        , ("schedule-renew", SortColumnNullsInv  $ queryQualUser       >>> (E.?. QualificationUserScheduleRenewal))
        -- , ("validity"      , SortColumn          $ queryQualUser       >>> (E.?. QualificationUserValidUntil))
        ]

      dbtFilter = Map.fromList
        [ fltrUserNameEmail   queryUser
        , ("validity"           , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
        , ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
              E.from $ \(usrComp `E.InnerJoin` comp) -> do
                let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                    testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
                    testcrit = maybe testname testnumber $ readMay $ CI.original criterion
                E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser    E.==. queryUser row E.^. UserId E.&&. testcrit
            )
        ]
      dbtFilterUI mPrev = mconcat
        [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
        , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
        , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
        ]

      aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications

      -- Block identical to Handler/Qualifications TODO: refactor
      getBlockReasons unblk = E.select $ do
          (quser :& qblock) <- X.from $ E.table @QualificationUser
            `E.innerJoin` E.table @QualificationUserBlock
            `X.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
          E.where_ $   ((quser  E.^. QualificationUserQualification) `E.in_` E.valList avsQids)
            E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
          E.groupBy     (qblock E.^. QualificationUserBlockReason)
          let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
          E.orderBy [E.desc countRows']
          E.limit 7
          pure (qblock E.^. QualificationUserBlockReason)
      suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
      suggestionsBlock   = mkOptionListText <$> runDBRead (getBlockReasons E.not__)
      suggestionsUnblock = mkOptionListText <$> runDBRead (getBlockReasons id)

      acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
      acts = mconcat
          [ singletonMap LicenceTableChangeAvs    $ pure LicenceTableChangeAvsData
          , if aLic == AvsNoLicence
              then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                    <*> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason) Nothing
                    <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)       (fslI MsgQualificationBlockNotify) (Just False)

              else singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData
                    <$> apreq (selectField qualOpts) (fslI MsgQualificationName) aLicQid
                    <*> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason) Nothing
                    <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
                    <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing
          ]
      dbtParams = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Just $ SomeRoute currentRoute
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard
                   $  (, mempty) . First . Just
                  <$> multiActionA acts (fslI MsgTableAction) (Just LicenceTableChangeAvs)
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
      dbtCsvEncode = noCsvEncode
      dbtCsvDecode = Nothing
      dbtExtraReps = []
      dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
      validator = def & defaultSorting [SortAscBy "user-name"]
      postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
                  -> FormResult (      LicenceTableActionData, Set AvsPersonId)
      postprocess inp = do
        (First (Just act), usrMap) <- inp
        let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
        return (act, usrSet)

  over _1 postprocess <$> dbTable validator DBTable{..}



data UserAvsAction = UserAvsSwitchCompany
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''UserAvsAction id
instance Button UniWorX UserAvsAction where
  btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]


getAdminAvsUserR,  postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR = postAdminAvsUserR
postAdminAvsUserR uuid = do
    isModal <- hasCustomHeader HeaderIsModal

    uid <- decrypt uuid
    Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
    -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
    let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
        -- fltrIdStatus  = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
    mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
    -- mbStatus  <- try $ fmap fltrIdStatus  $ avsQuery $ AvsQueryStatus  $ Set.singleton                  userAvsPersonId
    mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
    let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
    compDict <- if 1 >= length compsUsed
      then return mempty -- switch company only sensible if there is more than one company to choose
      else do
        let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
            switchCompFormHandler availComps      _  | 1 >= length availComps = return mempty    -- don't offer a form if there is only one company
            switchCompFormHandler availComps mbPrime = do
                let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
                    switchCompForm = (,)
                      <$> apopt hiddenField "" (Just uuid)
                      <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
                      <*  aopt (buttonField UserAvsSwitchCompany) "" Nothing
                    switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
                    switchCompValidate = do
                      (uuid_rcvd,_) <- State.get
                      guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
                ((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
                formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
                    lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
                    problems <- liftHandler . runDB $ do
                      (usrUp, problems) <- switchAvsUserCompany True False uid cid
                      update uid usrUp
                      forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
                    forM_ problems (\p -> do
                        -- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
                        tell . pure =<< messageI Warning p
                      )
                    let ok = if null problems then Success else Error
                    tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
                  )
                return $ wrapForm spWgt
                  def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
        (availComps, primName, primId) <- runDB $ do
          mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
          mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
          -- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
          comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed]  [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
          return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp)
        -- formDict <- Map.traverseWithKey runSwitchFrom compDict
        swForm <- switchCompFormHandler availComps primId
        return (primName, swForm)

    msgWarningTooltip <- messageI Warning MsgMessageWarning
    let warnBolt = messageTooltip msgWarningTooltip
        heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
    siteLayout heading $ do
      setTitle $ toHtml $ show userAvsNoPerson
      let contactWgt = case mbContact of
            Left err -> exceptionWgt err
            Right (AvsResponseContact adcs) ->
              if null adcs
                then [whamlet|_{MsgAvsPersonSearchEmpty}|]
                else
                  let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
                  in  mconcat cs
          cardsWgt = case mbStatus of
            Left err -> exceptionWgt err
            Right (AvsResponseStatus asts) ->
              if null asts
                then [whamlet|_{MsgAvsStatusSearchEmpty}|]
                else
                  let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
                  in mconcat cs
      [whamlet|
        <p>
          ^{contactWgt}
        <p>
          ^{cardsWgt}
        <p>
          _{MsgAvsCurrentData}
      |]
  where
    mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
    mkContactWgt warnBolt reqAvsNo AvsDataContact
      { -- avsContactPersonID = _api
        avsContactPersonInfo = AvsPersonInfo{..}
      , avsContactFirmInfo   = AvsFirmInfo{ avsFirmFirm = firmName }
      } =
      let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
      [whamlet|
        <section .profile>
          <dl .deflist.profile-dl>
            $if avsNoOk
              <dt .deflist__dt>
                _{MsgAvsPersonNo}
              <dd .deflist__dd>
                #{avsInfoPersonNo}
                ^{warnBolt}
                _{MsgAvsPersonNoMismatch}
            <dt .deflist__dt>
              _{MsgAvsLastName}
            <dd .deflist__dd>
              #{avsInfoLastName}
            <dt .deflist__dt>
              _{MsgAvsFirstName}
            <dd .deflist__dd>
              #{avsInfoFirstName}
            <dt .deflist__dt>
              _{MsgAvsPrimaryCompany}
            <dd .deflist__dd>
              #{firmName}
            $maybe bday <- avsInfoDateOfBirth
              <dt .deflist__dt>
                _{MsgAdminUserBirthday}
              <dd .deflist__dd>
                ^{formatTimeW SelFormatDate bday}
            <dt .deflist__dt>
              _{MsgAvsLicence}
            <dd .deflist__dd>
              $maybe licence <- parseAvsLicence avsInfoRampLicence
                _{licence}
              $nothing
                _{MsgAvsNoLicenceGuest}
      |]

    -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
    mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
    mkCardsWgt (mbPrimName, swForm) crds
      | null crds = [whamlet|_{MsgAvsCardsEmpty}|]
      | otherwise = do
        let hasCompany     = isJust $ Set.foldr ((<|>) . avsDataFirm)       Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
            hasIssueDate   = isJust $ Set.foldr ((<|>) . avsDataIssueDate)  Nothing crds
            hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo)    Nothing crds
        [whamlet|
          <div .scrolltable .scrolltable-bordered>
            <table .table .table--striped>
              <thead>
                <tr .table__row .table__row--head>
                  <th .table__th>_{MsgAvsCardNo}
                  <th .table__th>_{MsgTableAvsCardValid}
                  <th .table__th>_{MsgAvsCardColor}
                  <th .table__th>_{MsgAvsCardAreas}
                  $if hasIssueDate
                    <th .table__th>_{MsgTableAvsCardIssueDate}
                  $if hasValidToDate
                    <th .table__th>_{MsgTableAvsCardValidTo}
                  $if hasCompany
                    <th .table__th>_{MsgTableCompany}
                    <th .table__th>_{MsgAvsPrimaryCompany}
              <tbody>
                $forall c <- Set.toDescList crds
                  $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
                    <tr .table__row>
                      <td .table__td>
                        #{tshowAvsFullCardNo (getFullCardNo c)}
                      <td .table__td>
                        #{boolSymbol avsDataValid}
                      <td .table__td>
                        _{avsDataCardColor}
                      <td .table__td>
                        $forall a <- avsDataCardAreas
                          #{a} #
                      $if hasIssueDate
                        <td .table__td>
                          $maybe d <- avsDataIssueDate
                            ^{formatTimeW SelFormatDate d}
                      $if hasValidToDate
                        <td .table__td>
                          $maybe d <- avsDataValidTo
                            ^{formatTimeW SelFormatDate d}
                      $if hasCompany
                        <td .table__td>
                          $maybe f <- avsDataFirm
                            #{f}
                        <td .table__td>
                          $maybe f <- avsDataFirm
                            $with fci <- stripCI f
                              $maybe primName <- mbPrimName
                                $if (primName == fci)
                                  _{MsgAvsPrimaryCompany}
            <p>
              ^{swForm}
        |]



instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
  hasEntity = _dbrOutput . _2

instance HasUser (DBRow (Entity UserAvs, Entity User)) where
  hasUser = _dbrOutput . _2 . _entityVal

getProblemAvsErrorR :: Handler Html
getProblemAvsErrorR = do
  let
    avsSyncErrDBTable = DBTable{..}
      where
        dbtIdent :: Text
        dbtIdent = "avs-errors"
        dbtSQLQuery (usravs `E.InnerJoin` user) = do
          E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
          E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
          return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
        querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
        querryUsrAvs   = $(E.sqlIJproj 2 1)
        querryUser   :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
        querryUser     = $(E.sqlIJproj 2 2)
        reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
        reserrUsrAvs  = _dbrOutput . _1
        -- reserrUser   :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
        -- reserrUser    = _dbrOutput . _2
        dbtRowKey = querryUsrAvs >>> (E.^. UserAvsId)
        dbtProj = dbtProjId
        dbtColonnade = dbColonnade $ mconcat
          [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
          , sortable (Just "avs-nr")          (i18nCell MsgAvsPersonNo)
              $ avsPersonNoLinkedCell . view reserrUsrAvs
          , sortable Nothing                  (i18nCell MsgAvsPersonId)
              $ numCell             . view (reserrUsrAvs . _entityVal . _userAvsPersonId . _AvsPersonId)
          , sortable (Just "avs-last-synch")  (i18nCell MsgLastAvsSynchronisation)
              $ dateTimeCell        . view (reserrUsrAvs . _entityVal . _userAvsLastSynch)
          , sortable (Just "avs-last-error")  (i18nCell MsgLastAvsSynchError)
              $ cellMaybe textCell  . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
          ]
        dbtSorting = Map.fromList
          [  sortUserNameLink querryUser
          , ("avs-nr"        , SortColumn          $ querryUsrAvs >>> (E.^. UserAvsNoPerson))
          , ("avs-last-synch", SortColumnNullsInv  $ querryUsrAvs >>> (E.^. UserAvsLastSynch))
          , ("avs-last-error", SortColumn          $ querryUsrAvs >>> (E.^. UserAvsLastSynchError))
          ]
        dbtFilter = Map.fromList
          [ fltrUserNameEmail querryUser
          , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (E.^. UserAvsLastSynchError))
          ]
        dbtFilterUI mPrev = mconcat
          [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
          , prismAForm (singletonFilter "avs-last-error" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgLastAvsSynchError)
          ]
        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtCsvEncode = Nothing
        dbtCsvDecode = Nothing
        dbtExtraReps = []
    avsSyncErrDBTableValidator = def & defaultSorting [SortDescBy "avs-last-synch"]
    mkAvsSynchErrorTable :: DB (Any, Widget)
    mkAvsSynchErrorTable = dbTable avsSyncErrDBTableValidator avsSyncErrDBTable
  avsSyncErrTbl <- runDB (snd <$> mkAvsSynchErrorTable)
  siteLayoutMsg MsgMenuAvsSynchError $ do
    setTitleI MsgMenuAvsSynchError
    [whamlet|^{avsSyncErrTbl}|]