-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.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
{-# LANGUAGE TypeApplications #-}

module Handler.Qualification
  ( getQualificationAllR
  , getQualificationSchoolR
  , getQualificationR, postQualificationR
  )
  where

import Import

-- import Jobs
import Handler.Utils
import Handler.Utils.Users
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           Database.Esqueleto.Experimental ((:&)(..))
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
  isAdmin <- hasReadAccessTo AdminR
  qualiTable <- runDB $ do
    view _2 <$> mkQualificationAllTable isAdmin
  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


mkQualificationAllTable :: Bool -> DB (Any, Widget)
mkQualificationAllTable isAdmin = do 
  svs <- getSupervisees 
  now <- liftIO getCurrentTime
  let    
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery quali = do         
          let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId                  
                         Ex.&&. (E.val isAdmin E.||. 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 now quser
          return (quali, cactive, cusers)                          
        dbtRowKey = (Ex.^. QualificationId)
        dbtProj = dbtProjId
        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    & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip  , SomeMessage MsgTableDiffDaysTooltip]) $
              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshWithin)
          , sortable Nothing (i18nCell MsgQualificationRefreshReminder  & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
              foldMap (textCell . formatCalendarDiffDays             ) . view (resultAllQualification . _qualificationRefreshReminder)                   
          , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
          , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) 
                                                                        $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
          , 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)
          , singletonMap "noteexpiry"   $ SortColumn (E.^. QualificationExpiryNotification)
          ]
        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
  , qtcCompany        :: Maybe Text
  , qtcCompanyNumbers :: CsvSemicolonList Int
  , qtcValidUntil     :: Day
  , qtcLastRefresh    :: Day
  , qtcBlockStatus    :: Maybe Bool
  , qtcBlockFrom      :: Maybe UTCTime  
  , qtcScheduleRenewal:: Bool
  , qtcLmsStatusTxt   :: Maybe Text
  , qtcLmsStatusDay   :: Maybe UTCTime
  }
  deriving Generic
makeLenses_ ''QualificationTableCsv

qtcExample :: QualificationTableCsv
qtcExample = QualificationTableCsv
    { qtcDisplayName    = "Max Mustermann"
    , qtcEmail          = "m.mustermann@example.com"
    , qtcCompany        = Just "Example Brothers LLC, SecondaryJobs Inc"
    , qtcCompanyNumbers = CsvSemicolonList [27,69]
    , qtcValidUntil     = compDay
    , qtcLastRefresh    = compDay
    , qtcBlockStatus    = Nothing
    , qtcBlockFrom      = Nothing    
    , qtcScheduleRenewal= True
    , qtcLmsStatusTxt   = Just "Success"
    , qtcLmsStatusDay   = Just compTime
    }
  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 = ("elearn-" <>)

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    , SomeMessage MsgLmsUser)
    , ('qtcEmail          , SomeMessage MsgTableLmsEmail)
    , ('qtcCompany        , SomeMessage MsgTableCompanies)
    , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
    , ('qtcValidUntil     , SomeMessage MsgLmsQualificationValidUntil)
    , ('qtcLastRefresh    , SomeMessage MsgTableQualificationLastRefresh)
    , ('qtcBlockStatus    , SomeMessage MsgInfoQualificationBlockStatus)
    , ('qtcBlockFrom      , SomeMessage MsgInfoQualificationBlockFrom)
    , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
    , ('qtcLmsStatusTxt   , SomeMessage MsgTableLmsStatus)
    , ('qtcLmsStatusDay   , SomeMessage MsgTableLmsStatusDay)    
    ]


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

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

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

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

queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 3 3)

type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])

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

resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
resultQualBlock = _dbrOutput . _4 . _Just

resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5


instance HasEntity QualificationTableData User where
  hasEntity = resultUser

instance HasUser QualificationTableData where
  hasUser = resultUser . _entityVal

instance HasEntity QualificationTableData QualificationUser where
  hasEntity = resultQualUser

instance HasQualificationUser QualificationTableData where
  hasQualificationUser = resultQualUser . _entityVal

-- instance HasEntity QualificationUserBlock where
--   hasQualificationUserBlock = resultQualBlock


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

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

{-
isAdminAct :: QualificationTableAction -> Bool
isAdminAct QualificationActExpire           = False
isAdminAct QualificationActUnexpire         = False
isAdminAct QualificationActBlockSupervisor  = False
isAdminAct _ = True
-}

data QualificationTableActionData 
  = QualificationActExpireData 
  | QualificationActUnexpireData  
  | QualificationActBlockSupervisorData
  | QualificationActBlockData           { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
  | QualificationActUnblockData         { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
  | QualificationActRenewData           { qualTableActChangeReason :: Text}
  | QualificationActGrantData           { qualTableActGrantUntil  :: Day }   
  deriving (Eq, Ord, 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

blockActRemoveSupervisors :: QualificationTableActionData -> Bool
blockActRemoveSupervisors QualificationActBlockSupervisorData  = True
blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res
blockActRemoveSupervisors _ = 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` lmsUse) = 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)

qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
  -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
                , E.SqlExpr (Entity User)
                , E.SqlExpr (Maybe (Entity LmsUser))
                , E.SqlExpr (Maybe (Entity QualificationUserBlock))
                )
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
  -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
  -- 
    E.on $  qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
      E.&&. qualBlock `isLatestBlockBefore` E.val now
    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, qualBlock)


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)           
           -> (Map CompanyId Company -> 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  
  -- lookup all companies   
  cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do 
    cmps <- selectList [] [] -- [Asc CompanyShorthand]
    return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
  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 now qid fltrSvs
    dbtRowKey = queryUser >>> (E.^. UserId)
    dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
      -- cmps <- 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 (entityKey usr)
      --   E.orderBy [E.asc (comp E.^. CompanyName)]
      --   return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
      cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
      return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
    dbtColonnade = cols cmpMap
    dbtSorting = mconcat
      [ single $ sortUserNameLink   queryUser
      , single $ sortUserEmail      queryUser
      , single $ sortUserMatriclenr queryUser
      , single ("first-held"    , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
      , single ("last-refresh"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
      , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
      , single ("valid-until"   , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
      , single ("blocked"       , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
      , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
                                                                           , E.joinV (queryLmsUser row E.?. LmsUserNotified)
                                                                           ,          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)
              )
      -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
      ]
    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 ("avs-card"  , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
            Nothing -> E.false
            Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
                E.on     $ usrAvs E.^. UserAvsPersonId  E.==. avsCard E.^. UserAvsCardPersonId  
                E.where_ $ usrAvs E.^. UserAvsUser      E.==. user    E.^. UserId
                    E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
          )
      , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
          | Set.null criteria -> E.true
          | otherwise         -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
        )
      , 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 now))
      , 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
        )
      , single ("tobe-notified", FilterColumn $ \row criterion ->
          if  | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
              | otherwise -> E.true
        )
      , single ("status"  , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
      ]
    dbtFilterUI mPrev = mconcat
      [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
      , prismAForm (singletonFilter "user-company")                             mPrev $ aopt textField (fslI MsgTableCompany)
      , prismAForm (singletonFilter "personal-number" )                         mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
      , prismAForm (singletonFilter "avs-card" )                                mPrev $ aopt textField (fslI MsgAvsCardNo)
      , prismAForm (singletonFilter "avs-number" )                              mPrev $ aopt textField (fslI MsgAvsPersonNo)            
      , 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)
      , prismAForm (singletonFilter "tobe-notified"    . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
      , prismAForm (singletonFilter "status"           . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
      ]
    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     resultCompanyUser >>= getCompanies)
          <*> (view     resultCompanyUser >>= getCompanyNos)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
          <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)                  
          <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
          <*>  preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)          
          <*>  view    (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
          <*>  getStatusPlusTxt
          <*>  getStatusPlusDay
        getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of 
          []        -> pure   Nothing
          somecmps  -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
        getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))

        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 . _lmsUserStatusDay)) >>= \case 
            lsd@(Just _) -> return lsd
            Nothing -> 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
  msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
  msgUnexpire     <- messageIconI Info    IconWarning MsgQualificationActUnexpireWarning
  now <- liftIO getCurrentTime
  let nowaday = utctDay now
  ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
    qent@Entity{
        entityKey=qid
      , entityVal=Qualification{
          qualificationAuditDuration=auditMonths
        , qualificationValidDuration=validMonths
      }} <- getBy404 $ SchoolQualificationShort sid qsh

    -- Block copied to Handler/Qualifications TODO: refactor
    let getBlockReasons unblk = Ex.select $ do 
          (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser 
            `Ex.innerJoin` Ex.table @QualificationUserBlock
            `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
          Ex.where_ $     quser  Ex.^. QualificationUserQualification Ex.==. Ex.val qid
            Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
          Ex.groupBy     (qblock Ex.^. QualificationUserBlockReason)        
          let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
          Ex.orderBy [Ex.desc countRows']
          Ex.limit 7
          pure (qblock Ex.^. QualificationUserBlockReason)
        mkOption :: Ex.Value Text -> Option Text
        mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
        suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
        suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_)
        suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
        dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
        acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
        acts = mconcat $
          [ singletonMap QualificationActExpire   $ pure QualificationActExpireData
          , singletonMap QualificationActUnexpire $      QualificationActUnexpireData 
              <$ aformMessage msgUnexpire        
          ] ++ bool 
          -- nonAdmin actions, ie. Supervisor
          [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] 
          -- Admin-only actions
          [ singletonMap QualificationActUnblock         $      QualificationActUnblockData
              <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock)  (fslI MsgQualificationGrantReason)             Nothing
              <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
          , singletonMap QualificationActBlock           $      QualificationActBlockData 
              <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationBlockReason)             Nothing
              <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockNotify)            (Just False)
              <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant)      (fslI MsgQualificationBlockRemoveSupervisor)  (Just False)
          , singletonMap QualificationActRenew           $      QualificationActRenewData
              <$> apreq (textField & cfStrip & addDatalist suggestionsBlock)    (fslI MsgQualificationRenewReason)             Nothing
          , singletonMap QualificationActGrant           $      QualificationActGrantData 
                <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
                <*  aformMessage msgGrantWarning
          ] isAdmin
        linkLmsUser     = toMaybe isAdmin (LmsUserR sid qsh)
        linkUserName    = bool ForProfileR ForProfileDataR isAdmin        
        colChoices cmpMap = mconcat
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserNameModalHdr MsgLmsUser linkUserName
          , colUserEmail          
          , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
              let cs =  [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
                        | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
                        , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap                        
                        ]
              in intercalate spacerCell cs
          , guardMonoid isAdmin $ colUserMatriclenr isAdmin
          -- , sortable (Just "validity")      (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
          , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $    \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
          , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$    \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d          
          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)  (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
          , sortable (Just "blocked")       (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> 
              qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
          , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
                                                                                    )     $ \(   view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
          , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
                                                                                          $ \(preview $ resultLmsUser  . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
          , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
          ]
        psValidator = def & defaultSorting [SortDescBy "last-refresh"]
    tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
    return (tbl, qent)
  
  formResult lmsRes $ \case
    (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
      noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers      
      addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
      reloadKeepGetParams $ QualificationR sid qsh
    (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do      
      runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
      addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
      reloadKeepGetParams $ QualificationR sid qsh
    (action, selectedUsers) | isExpiryAct action -> do      
      let isUnexpire = action == QualificationActUnexpireData
      upd <- runDB $ do
        forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
          { transactionUser                         = uid
          , transactionQualification                = qid
          , transactionQualificationScheduleRenewal = Just isUnexpire
          }
        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      
      let selUserIds = Set.toList selectedUsers
          (unblock, reason) = case action of 
              QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)              
              QualificationActBlockData{..}       -> (False, Left qualTableActBlockReason)
              QualificationActUnblockData{..}     -> (True , Left qualTableActBlockReason)
              _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
          notify = case action of 
              QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
              _ -> False
          
      oks <- runDB $ do 
        when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
        qualificationUserBlocking qid selUserIds unblock Nothing reason notify
      let nrq = length selectedUsers
          warnLevel = if
            | oks < 0    -> Error
            | oks == nrq -> Success
            | otherwise  -> Warning
          fbmsg = if unblock then MsgQualificationStatusUnblock else 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")
