-- 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
  , getProblemAvsSynchR, postProblemAvsSynchR
  ) where

import Import
import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
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 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 needed only here
data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
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 = catMaybes $ 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)


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
  mAvsQuery <- getsYesod $ view _appAvsQuery
  case mAvsQuery of
    Nothing -> return mempty
    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>#{tshow p}
                |]
      mbPerson <- formResultMaybe presult procFormPerson

      ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
      let procFormStatus fr = do
            addMessage Info $ text2Html $ "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>#{tshow p}
                |]
      mbStatus <- formResultMaybe sresult procFormStatus

      ((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 $ upsertAvsUser 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
            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)
-}


data ButtonAvsSynch = BtnImportUnknownAvsIds | BtnRevokeAvsLicences
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAvsSynch
instance Finite   ButtonAvsSynch

nullaryPathPiece ''ButtonAvsSynch camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonAvsSynch id

instance Button UniWorX ButtonAvsSynch where
  btnClasses  BtnImportUnknownAvsIds = [BCIsButton, BCPrimary]
  btnClasses  BtnRevokeAvsLicences   = [BCIsButton, BCDanger]


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

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

data LicenceTableActionData =  LicenceTableChangeAvsData
                            |  LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later
                            |  LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId
                                                           , licenceTableChangeFDriveEnd :: Day
                                                           }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)


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
  AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences

  --  
  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
  (btnUnknownWgt, btnUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDAbsUnknownLicences
  case btnUnknownRes of
    Nothing -> return ()
    (Just BtnImportUnknownAvsIds)  -> catchAllAvs $ do 
      res <- 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

    (Just BtnRevokeAvsLicences) -> catchAllAvs $ do
      let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
          no_revokes = Set.size revokes
      oks <- 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 "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll      
          <*> mkLicenceTable "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld   
          <*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld 
          <*> mkLicenceTable "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld  
  
  now <- liftIO getCurrentTime
  let nowaday = utctDay now      
      procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
      procRes aLic (LicenceTableChangeAvsData       , apids) = catchAllAvs $ do 
        oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
        let no_req = Set.size apids
            mkind = if oks < no_req then Warning else Success
        addMessageI mkind $ MsgAvsSetLicences aLic oks no_req                  
        redirect ProblemAvsSynchR -- reload to update all tables 
      procRes alic (LicenceTableRevokeFDriveData, apids) = do 
        runDB $ do
          qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic
          uas <- selectList [UserAvsPersonId <-. Set.toList apids] []
          let uids    = view _userAvsUser <$> uas
              endday  = pred nowaday
              crits   = [QualificationUserQualification ==. qId, QualificationUserUser <-. uids]
          oks <- fromIntegral <$> updateWhereCount crits [QualificationUserValidUntil =. endday, QualificationUserLastRefresh =. nowaday]
          qus <- selectList crits []
          forM_ qus $ \qu ->
            audit TransactionQualificationUserEdit
              { transactionQualificationUser        = qu ^. _entityKey
              , transactionQualification            = qId    -- qu ^. _qualificationUserQualification
              , transactionUser                     = qu ^. _qualificationUserUser
              , transactionQualificationValidUntil  = endday -- qu ^. _qualificationUserValidUntil
              }
          if oks /= length qus || oks /= Set.size apids
            then do 
              $logErrorS "AVS" $ "Revoke FRADrive licences discrepancy! Requested: " <> tshow (Set.size apids) <> " Updated: " <> tshow oks <> " Found: " <> tshow (length qus)
              liftHandler $ addMessageI Error   $ MsgRevokeFraDriveLicences alic oks
            else 
              liftHandler $ addMessageI Success $ MsgRevokeFraDriveLicences alic oks
        redirect ProblemAvsSynchR -- must be outside runDB 

      procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
        (n, Qualification{qualificationShorthand}) <- runDB $ do 
          uas <- selectList [UserAvsPersonId <-. Set.toList apids] []
          let uids = view _userAvsUser <$> uas
          -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
          forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd
          (length uids,) <$> get404 licenceTableChangeFDriveQId
        addMessageI Success $ 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 :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable 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)
        E.limit 200 -- TODO: why does pagination not work here?
        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)
      dbtProj = dbtProjFilteredPostId
      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) -> avsPersonNoCell a
        -- , colUserCompany 
        , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(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 qualificationShortCell 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
        ]
      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))
        ]      

      dbtFilter = mconcat
        [ single $ fltrUserNameEmail   queryUser
        , single ("validity"           , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?                
        , single ( "user-company", FilterColumn $ \(queryUser -> user) criteria -> if
                | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise ->
                    E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do
                      E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                      E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId)
                          E.&&.  E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria)
            )                 
        ]
      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 $ pure LicenceTableRevokeFDriveData
              else singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData 
                    <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
                    <*> apopt dayField (fslI MsgLmsQualificationValidUntil) 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 [SortDescBy "column-label"]
      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{..}