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


{-# 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
  , getProblemAvsSynchR, postProblemAvsSynchR
  ) 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 Utils.Avs


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


-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton


-- 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 = "Check all licences"       -- 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 AvsQueryStatus -> 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 :: AvsQueryStatus -> Text
    unparseAvsIds (AvsQueryStatus ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids

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

makeAvsContactForm :: Maybe AvsQueryContact -> 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 :: AvsQueryContact -> Text
    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
            AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf}
          $nothing
            AVS nicht konfiguriert!
        |]
  mAvsQuery <- getsYesod $ view _appAvsQuery
  case mAvsQuery of
    Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
    Just AvsQuery{..} -> do
      ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing

      let procFormPerson fr = do
            addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
            res <- avsQueryPerson fr
            case res of
              Left  err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
              Right (AvsResponsePerson pns) -> return $ Just [whamlet|
                  <ul>
                    $forall p <- pns                       
                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
                |]
      mbPerson <- formResultMaybe presult procFormPerson

      ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
      let procFormStatus fr = do
            addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
            res <- avsQueryStatus fr
            case res of
              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
              Right (AvsResponseStatus pns) -> return $ Just [whamlet|
                  <ul>
                    $forall p <- pns 
                      <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
                |]
      mbStatus <- formResultMaybe sresult procFormStatus

      ((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
      let procFormContact fr = do
            addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
            res <- avsQueryContact fr
            case res of
              Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
              Right (AvsResponseContact pns) -> return $ Just [whamlet|
                  <ul>
                    $forall AvsDataContact{..} <- pns 
                      <li>
                        <ul>
                          <li>AvsId: #{tshow avsContactPersonID}
                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
                          <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
                |]
      mbContact <- formResultMaybe cresult 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) -> do
                let msg = tshow (e :: SomeException)
                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
      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 = do
            res <- avsQueryGetAllLicences
            case res of
              (Right (AvsResponseGetLicences lics)) -> do
                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 $ Just [whamlet|
                    <h2>Success:</h2>
                    <ul>
                      $forall AvsPersonLicence{..} <- flics
                        <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
                  |]

              (Left err) -> do
                let msg = tshow err
                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
      mbGetLic <- formResultMaybe getLicRes 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 <- case qryLicRes of
        Nothing -> return Nothing
        (Just BtnCheckLicences) -> do
          res <- try $ do
            allLicences <- throwLeftM avsQueryGetAllLicences
            computeDifferingLicences allLicences
          case res of
            (Right diffs) -> do
              let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
                  r_grant = showLics AvsLicenceRollfeld
                  f_set   = showLics AvsLicenceVorfeld
                  revoke  = showLics AvsNoLicence
              return $ Just [whamlet|
                  <h2>Licence check differences:
                  <h3>Grant R:
                  <p>
                    #{r_grant}
                  <h3>Set to F:
                  <p>
                    #{f_set}
                  <h3>Revoke licence:
                  <p>
                    #{revoke}
                |]
            (Left e) -> do
              let msg = tshow (e :: SomeException)
              return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
        -- (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
                              }
                            |  LicenceTableGrantFDriveData 
                              { licenceTableChangeFDriveQId     :: QualificationId
                              , 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{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus

  --  
  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
  ifMaybeM 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}
        |]
      
  ifMaybeM 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 $ (,,,) 
          <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll      
          <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld   
          <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld 
          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld  
  
  now <- liftIO getCurrentTime
  let nowaday = utctDay now      
      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
          qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
          if qId /= licenceTableChangeFDriveQId 
            then return (-1)
            else do
              uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
              qualificationUserBlocking licenceTableChangeFDriveQId uids $
                    Just $ QualificationBlocked 
                    { qualificationBlockedDay     = nowaday
                    , qualificationBlockedReason  = licenceTableChangeFDriveReason
                    }                     
        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
          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
          (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
  
  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))
                        )                        

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

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

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

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

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

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

instance HasEntity LicenceTableData User where 
  hasEntity = resultUser

instance HasUser LicenceTableData where 
  hasUser   = resultUser . _entityVal


mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable apidStatus dbtIdent aLic apids = do 
  currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
  avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
  now <- liftIO getCurrentTime
  let nowaday = utctDay now            
      -- 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) -> do
        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)
      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) -> avsPersonNoLinkedCell 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 . runDB . 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.^. CompanyName, usrComp E.^. UserCompanySupervisor)
            let companies = intersperse (text2markup ", ") $
                  (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
                icnSuper = text2markup " " <> icon IconSupervisor
            pure $ toWgt $ mconcat companies
        , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview   resultQualification -> q) -> cellMaybe lmsShortCell q
        , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> cellMaybe dayCell d
        , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> cellMaybe dayCell d
        , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> cellMaybe dayCell d
        , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
                                                                                   ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> cellMaybe qualificationBlockedCell b
        , 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 = mconcat
        [ single $ sortUserNameLink queryUser         
        , single ("avspersonno"   , SortColumn $ queryUserAvs       >>> (E.^. UserAvsNoPerson))
        , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
        , single $ sortUserCompany queryUser
        , single ("valid-until"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserValidUntil))
        , single ("last-refresh"  , SortColumn $ queryQualUser      >>> (E.?. QualificationUserLastRefresh))
        , single ("first-held"    , SortColumn $ queryQualUser      >>> (E.?. QualificationUserFirstHeld))
        , single ("blocked-due"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserBlockedDue))
        , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
        ]      

      dbtFilter = mconcat
        [ single $ fltrUserNameEmail   queryUser
        , single ("validity"           , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?                
        , single ( "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)
        ]
      
      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
      qualOpt (Entity qualId qual) = do
        cQualId :: CryptoUUIDQualification <- encrypt qualId
        return $ Option
          { optionDisplay       = CI.original $ qualificationName qual
          , optionInternalValue = qualId
          , optionExternalValue = tshow cQualId
          }        
      aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
      acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
      acts = mconcat
          [ singletonMap LicenceTableChangeAvs    $ pure LicenceTableChangeAvsData
          , if aLic == AvsNoLicence
              then singletonMap LicenceTableRevokeFDrive $ LicenceTableRevokeFDriveData
                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
                    <*> apreq textField (fslI MsgQualificationBlockReason) Nothing
              else singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData 
                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
                    <*> 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{..}



getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
  uid <- decrypt uuid
  Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid  
  mAvsQuery <- getsYesod $ view _appAvsQuery
  resWgt <- case mAvsQuery of
    Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
    Just AvsQuery{..} -> do 
      mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
      mbDataPerson <- lookupAvsUser userAvsPersonId      
      return [whamlet|
        <p>
          Vorläufige Admin Ansicht AVS Daten. 
          Ansicht zeigt aktuelle Daten. 
          Es erfolgte damit aber noch kein Update der FRADrive Daten.
        <p>
          <dl .deflist>
            <dt .deflist__dt>InfoPersonContact <br>
              <i>(bevorzugt)
            <dd .deflist__dd>
              $case mbContact
                $of Left err 
                  Fehler: #{tshow err}
                $of Right contactInfo
                  #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}              
            <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
              <i>(benötigt mehrere AVS Abfragen)
            <dd .deflist__dd>
              $maybe dataPerson <- mbDataPerson
                #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
              $nothing 
                Keine Daten erhalten.        
        <h3>
          Provisorische formatierte Ansicht
        <p> 
          Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. 
          In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
        <p>          
          ^{foldMap jsonWidget mbContact}
        <p>          
          ^{foldMap jsonWidget mbDataPerson}
        |]       
  let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
  siteLayout heading $ do 
    setTitle $ toHtml $ show userAvsNoPerson
    resWgt