-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@cip.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.Qualification
  ( getQualificationAllR
  , getQualificationSchoolR
  , getQualificationR, postQualificationR
  )
  where

import Import

-- import Jobs
import Handler.Utils
-- import Handler.Utils.Csv
import Handler.Utils.LMS


import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Csv as Csv
import qualified Data.Text as T
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C
import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E
-- import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH


-- import Handler.Utils.Qualification (validQualification)

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


getQualificationSchoolR :: SchoolId -> Handler Html
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])

getQualificationAllR :: Handler Html
getQualificationAllR = do -- TODO just a stub
  qualiTable <- runDB $ do
    view _2 <$> mkQualificationAllTable  
  siteLayoutMsg MsgMenuQualifications $ do
    setTitleI MsgMenuQualifications
    $(widgetFile "qualification-all")

type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
resultAllQualification :: Lens' AllQualificationTableData Qualification
resultAllQualification = _dbrOutput . _1 . _entityVal 

resultAllQualificationActive :: Lens' AllQualificationTableData Word64
resultAllQualificationActive = _dbrOutput . _2 . _unValue

resultAllQualificationTotal  :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal  = _dbrOutput . _3 . _unValue

getSupervisees :: DB (Set UserId)
getSupervisees = do 
  uid <- requireAuthId
  svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
  return $ Set.insert uid $ Set.fromAscList svs 


mkQualificationAllTable :: DB (Any, Widget)
mkQualificationAllTable = do 
  svs <- getSupervisees 
  now <- liftIO getCurrentTime
  let    
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery quali = do         
          let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId                  
                         Ex.&&. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs
              cusers = Ex.subSelectCount $ do 
                quser <- Ex.from $ Ex.table @QualificationUser
                Ex.where_ $ filterSvs quser 
              cactive = Ex.subSelectCount $ do 
                quser <- Ex.from $ Ex.table @QualificationUser
                Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser
          return (quali, cactive, cusers)                          
        dbtRowKey = (Ex.^. QualificationId)
        dbtProj = dbtProjId -- TODO: or dbtProjSimple what is the difference?
        dbtColonnade = dbColonnade $ mconcat
          [ colSchool $ resultAllQualification . _qualificationSchool
          , sortable (Just "qshort")        (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> 
              let qsh = qualificationShorthand quali in 
              anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
          , sortable (Just "qname")         (i18nCell MsgQualificationName)  $ \(view resultAllQualification -> quali) -> 
              let qsh = qualificationShorthand quali
                  qnm = qualificationName quali 
              in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
          , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
              maybeCell (qualificationDescription quali) markupCellLargeModal
          , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ 
              foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
          , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltip MsgTableDiffDaysTooltip) $
              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)          
          -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin)   $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) 
                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
          , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) 
                  $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
          , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)  
                  $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId
          , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
                  $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n                
          , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal                     
          ] 
        dbtSorting = mconcat
          [
            sortSchool $ to (E.^. QualificationSchool)
          , singletonMap "qshort"       $ SortColumn (E.^. QualificationShorthand)
          , singletonMap "qname"        $ SortColumn (E.^. QualificationName)
          , singletonMap "qelearning"   $ SortColumn (E.^. QualificationElearningStart)
          ]
        dbtFilter = mconcat
          [
            fltrSchool $ to (E.^. QualificationSchool)
          , singletonMap "qelearning"   . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart)
          ]
        dbtFilterUI = mconcat
          [
            fltrSchoolUI
          , \mPrev -> prismAForm (singletonFilter "qelearning"   . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning)
          ]
        dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "qualification-overview"        
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing
        dbtExtraReps = []

    resultDBTableValidator = def
      & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
  dbTable resultDBTableValidator resultDBTable



-- getQualificationEditR,  postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
-- getQualificationEditR = postQualificationEditR 
-- postQualificationEditR = error "TODO"

data QualificationTableCsv = QualificationTableCsv   -- Q..T..C.. -> qtc..
  { qtcDisplayName  :: UserDisplayName
  , qtcEmail        :: UserEmail
  , qtcValidUntil   :: Day
  , qtcLastRefresh  :: Day
  , qtcBlocked      :: Maybe Day    
  , qtcLmsStatusTxt :: Maybe Text
  , qtcLmsStatusDay :: Maybe Day
  }
  deriving Generic
makeLenses_ ''QualificationTableCsv

qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv
    { qtcDisplayName  = "Max Mustermann"
    , qtcEmail        = "m.mustermann@example.com"
    , qtcValidUntil   = compDay
    , qtcLastRefresh  = compDay    
    , qtcBlocked      = Nothing    
    , qtcLmsStatusTxt = Just "Success"
    , qtcLmsStatusDay = Just compDay
    }
  where
    compTime :: UTCTime
    compTime = $compileTime
    compDay :: Day
    compDay = utctDay compTime

qtcOptions :: Csv.Options
qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
  where
    renameLtc "qtcDisplayName" = "licensee"
    renameLtc other = replaceLtc $ camelToPathPiece' 1 other
    replaceLtc ('l':'m':'s':'-':t) = prefixLms t
    replaceLtc other = other
    prefixLms = ("e-learn-" <>)

instance Csv.ToNamedRecord QualificationTableCsv where
  toNamedRecord = Csv.genericToNamedRecord qtcOptions

instance Csv.DefaultOrdered QualificationTableCsv where
  headerOrder = Csv.genericHeaderOrder qtcOptions

instance CsvColumnsExplained QualificationTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
    [ ('qtcDisplayName, MsgLmsUser)
    , ('qtcEmail      , MsgTableLmsEmail)
    , ('qtcValidUntil , MsgLmsQualificationValidUntil)
    , ('qtcLastRefresh, MsgTableQualificationLastRefresh)        
    , ('qtcLmsStatusTxt, MsgTableLmsStatus)
    , ('qtcLmsStatusDay, MsgTableLmsStatusDay)    
    ]


type QualificationTableExpr = (         E.SqlExpr (Entity QualificationUser)
                      `E.InnerJoin`     E.SqlExpr (Entity User)
                    ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))

queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)

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

queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 2 2)


type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser))

resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1

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

resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just


instance HasEntity QualificationTableData User where
  hasEntity = resultUser

instance HasUser QualificationTableData where
  hasUser = resultUser . _entityVal

data QualificationTableAction 
  = QualificationActExpire 
  | QualificationActUnexpire
  | QualificationActBlockSupervisor
  | QualificationActBlock
  | QualificationActUnblock
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe QualificationTableAction
instance Finite QualificationTableAction
nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''QualificationTableAction id

-- Not yet needed, since there is no additional data for now:
data QualificationTableActionData 
  = QualificationActExpireData 
  | QualificationActUnexpireData  
  | QualificationActBlockSupervisorData
  | QualificationActBlockData   { qualTableActBlockReason :: Text}
  | QualificationActUnblockData
  deriving (Eq, Ord, Read, Show, Generic)

isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData    = True
isExpiryAct QualificationActUnexpireData  = True
isExpiryAct _ = False

isBlockAct :: QualificationTableActionData -> Bool
isBlockAct QualificationActBlockSupervisorData  = True
isBlockAct QualificationActBlockData{}          = True
isBlockAct QualificationActUnblockData          = True
isBlockAct _ = False

qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
  -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
                , E.SqlExpr (Entity User)
                , E.SqlExpr (Maybe (Entity LmsUser))
                )
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
    E.on $ user E.^. UserId E.=?. lmsUser  E.?. LmsUserUser
            E.&&. E.val qid E.=?. lmsUser  E.?. LmsUserQualification            -- NOTE: condition was once erroneously placed in where-clause, which does not work
    E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
    E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
    return (qualUser, user, lmsUser)


mkQualificationTable ::
              ( Functor h, ToSortable h
              , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool                                        QualificationTableData))) cols
              )
           => Bool
           -> Entity Qualification
           -> Map QualificationTableAction (AForm Handler QualificationTableActionData)           
           -> cols
           -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
           -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
  svs <- getSupervisees
  now <- liftIO getCurrentTime  
  let
    nowaday = utctDay now
    mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
    csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
    dbtIdent :: Text
    dbtIdent = "qualification"
    fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
    dbtSQLQuery = qualificationTableQuery qid fltrSvs
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjId -- FilteredPostId
    dbtColonnade = cols
    dbtSorting = mconcat
      [ single $ sortUserNameLink queryUser
      , single $ sortUserEmail    queryUser      
      , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
      , single ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))      
      , single ("blocked-due"   , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
      -- , single ("lms-started"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
      -- , single ("lms-status"    , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
      , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
                                                                  , queryLmsUser row E.?. LmsUserStarted])
      , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))                                                                        
      , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
                E.orderBy [E.asc (comp E.^. CompanyName)]
                return (comp E.^. CompanyName)
              )
      ]
    dbtFilter = mconcat
      [ single $ fltrUserNameEmail   queryUser
      , single ("avs-number"  , FilterColumn . E.mkExistsFilter $ \row criterion ->
              E.from $ \usrAvs -> -- do 
                E.where_ $ usrAvs E.^. UserAvsUser      E.==. queryUser row E.^. UserId
                    E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
                          (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
      , 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
        )                                  
      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
      , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
          if | Just renewal <- mbRenewal
             , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
                                          E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
             | otherwise -> E.true
        )
      ]
    dbtFilterUI mPrev = mconcat
      [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
      , prismAForm (singletonFilter "avs-number" )  mPrev $ aopt textField (fslI MsgAvsPersonNo)
      , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
      , if isNothing mbRenewal then mempty
        else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
      ]
    dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
    dbtCsvEncode = Just DBTCsvEncode
      { dbtCsvExportForm   = pure ()
      , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
      , dbtCsvName         = csvName
      , dbtCsvSheetName    = csvName
      , dbtCsvNoExportData = Just id
      , dbtCsvHeader       = const $ return $ Csv.headerOrder qtcExample
      , dbtCsvExampleData  = Just [qtcExample]
      }
      where
        doEncode' :: QualificationTableData -> QualificationTableCsv
        doEncode' = QualificationTableCsv
          <$>  view    (resultUser     . _entityVal . _userDisplayName)
          <*>  view    (resultUser     . _entityVal . _userDisplayEmail)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)                  
          <*>  preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay)          
          <*>  getStatusPlusTxt
          <*>  getStatusPlusDay
        getStatusPlusTxt = 
          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case 
            Just LmsBlocked{} -> return $ Just "Failed"
            Just LmsExpired{} -> return $ Just "Expired"
            Just LmsSuccess{} -> return $ Just "Success"
            Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
              preview (resultLmsUser  . _entityVal . _lmsUserStarted)
        getStatusPlusDay = 
          (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus)) >>= \case 
            Just ls -> return $ Just $ lmsStatusDay ls
            Nothing -> utctDay <<$>> preview (resultLmsUser  . _entityVal . _lmsUserStarted)
          
    dbtCsvDecode = Nothing
    dbtExtraReps = []    
    dbtParams = DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Nothing
      , dbParamsFormAttrs  = []
      , dbParamsFormSubmit = FormSubmit
      , dbParamsFormAdditional
          = renderAForm FormStandard
                $  (, mempty) . First . Just
              <$> multiActionA acts (fslI MsgTableAction) Nothing
      , dbParamsFormEvaluate = liftHandler . runFormPost
      , dbParamsFormResult   = id
      , dbParamsFormIdent    = def
      }

    postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)
                -> FormResult (      QualificationTableActionData, Set UserId)
    postprocess inp = do
        (First (Just act), usrMap) <- inp
        let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
        return (act, usrSet)

    -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData))
    -- resultDBTableValidator = def
      -- & defaultSorting [SortAscBy csvLmsIdent]
  over _1 postprocess <$> dbTable psValidator DBTable{..}

getQualificationR,  postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
getQualificationR = postQualificationR
postQualificationR sid qsh = do  
  isAdmin <- hasReadAccessTo AdminR
  ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
    qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh
    let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
        acts = mconcat $
          [ singletonMap QualificationActExpire   $ pure QualificationActExpireData
          , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData          
          ] ++ bool 
          [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin Supervisor
          [ singletonMap QualificationActUnblock         $ pure QualificationActUnblockData
          , singletonMap QualificationActBlock           $      QualificationActBlockData 
              <$> apreq textField (fslI MsgQualificationBlockReason) Nothing
          ] isAdmin
        linkLmsUser     = toMaybe isAdmin LmsUserR
        linkUserName    = bool ForProfileR                      ForProfileDataR          isAdmin
        blockedDueCell  = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
        colChoices = mconcat
          [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
          , colUserNameModalHdr MsgLmsUser linkUserName
          , colUserEmail
          , 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 "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
          , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple
                                                                                    )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b)  -> blockedDueCell b
          , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal  & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                    )  $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
          -- , sortable (Just "lms-started")   (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted)  
          --                                                                              $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStarted  -> d) -> foldMap dateTimeCell d
          -- , sortable (Just "lms-status")    (i18nCell MsgTableLmsStatus)               $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStatus -> status)  -> foldMap lmsStatusCell $ join status          
          , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
                                                                                       $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusPlusCell linkLmsUser) lu                                                                                       
          ]
        psValidator = def & defaultSorting [SortDescBy "last-refresh"]
    tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
    return (tbl, qent)
  
  formResult lmsRes $ \case    
    (action, selectedUsers) | isExpiryAct action -> do
      let isUnexpire = action == QualificationActUnexpireData
      upd <- runDB $ updateWhereCount
              [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
              [QualificationUserScheduleRenewal =. isUnexpire]
      let msgKind = if upd > 0  then Success else Warning
          msgVal  = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
      addMessageI msgKind msgVal
      reloadKeepGetParams $ QualificationR sid qsh
    (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData)  -> do
      now <- liftIO getCurrentTime
      let nowaday = utctDay now 
          qubr = case action of 
              QualificationActUnblockData         -> Nothing
              QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday
              QualificationActBlockData{..}       -> Just $ QualificationBlocked
                                                      { qualificationBlockedDay     = nowaday
                                                      , qualificationBlockedReason  = qualTableActBlockReason
                                                      }
              _ -> error "Handle.Qualification.isBlockAct returned non-block action"
      oks <- runDB $ qualificationUserBlocking qid (Set.toList selectedUsers) qubr
      let nrq = length selectedUsers
          warnLevel = if
            | oks < 0    -> Error
            | oks == nrq -> Success
            | otherwise  -> Warning
          fbmsg = if
            | isNothing qubr -> MsgQualificationStatusUnblock
            | otherwise      -> MsgQualificationStatusBlock
      addMessageI warnLevel $ fbmsg qsh oks nrq
      reloadKeepGetParams $ QualificationR sid qsh
    _ -> addMessageI Error MsgInvalidFormAction

  let heading = citext2widget $ qualificationName quali
  siteLayout heading $ do
    setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
    $(widgetFile "qualification")
