-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

module Handler.Firm
  ( getFirmAllR  
  , getFirmR, postFirmR
  )
  where

import Import

-- import Jobs
import Handler.Utils

-- 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 E -- 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


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


getFirmR,  postFirmR :: CompanyShorthand -> Handler Html
getFirmR = postFirmR
postFirmR fsh = do
  cusers <- runDB $ do 
    cusers <- selectList [UserCompanyCompany ==. CompanyKey fsh] []
    selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
  csuper <- runDB $ do 
    csuper <- selectList [UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] []
    selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
  siteLayoutMsg MsgMenuFirms $ do 
    setTitleI MsgMenuFirms
    [whamlet|STUB HANDLER FOR #{fsh} TO DO

      <h3>Supervisors (non-foreign only)
      <ul> 
        $forall u <- csuper
          <li>^{userWidget u}

      <h3>Employees
      <ul>
        $forall u <- cusers
          <li>^{userWidget u}

      In the end, this needs to be a dbTable, of course!
    |]


getFirmAllR :: Handler Html
getFirmAllR = do
  uid <- requireAuthId
  isAdmin <- hasReadAccessTo AdminR
  firmTable <- runDB $ do 
    view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins
  siteLayoutMsg MsgMenuFirms $ do 
    setTitleI MsgMenuFirms
    --     $(widgetFile "firm-all")
    [whamlet|!!!STUB!!!TO DO!!!        
        ^{firmTable}
    |]


type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64)
resultAllCompany :: Lens' AllCompanyTableData Company
resultAllCompany = _dbrOutput . _1 . _entityVal 

resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
resultAllCompanySupervisors = _dbrOutput . _2 . _unValue

resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
resultAllCompanyUsers = _dbrOutput . _3 . _unValue

resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue

fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
fromUserCompany mbFltr cmpy = do 
  usrCmpy <- E.from $ E.table @UserCompany
  let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
  E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr

firmCountUsers        :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsers        = E.subSelectCount . fromUserCompany Nothing

firmCountSupervisors  :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors  = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))      

firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountForeignSupervisors cmpy = E.subSelectCount $ E.distinct $ do
  usrSuper <- E.from $ E.table @UserSupervisor
  E.where_ $  E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser)       cmpy)
     E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)    
  return $ usrSuper E.^. UserSupervisorSupervisor

mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
mkFirmAllTable isAdmin uid = do 
  -- now <- liftIO getCurrentTime
  let        
    resultDBTable = DBTable{..}
      where
        dbtSQLQuery cmpy = do         
          unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
            usrCmpy <- E.from $ E.table @UserCompany
            E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
                E.&&.  usrCmpy E.^. UserCompanyUser E.==. E.val uid
          return (cmpy, firmCountForeignSupervisors cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy)
        dbtRowKey = (E.^. CompanyShorthand)
        dbtProj = dbtProjId
        dbtColonnade = dbColonnade $ mconcat
          [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand))
            sortable (Just "name")        (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> 
              anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm
          , sortable (Just "short")       (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> 
              let fsh = companyShorthand firm 
              in  anchorCell (FirmR fsh) $ toWgt fsh
          , sortable (Just "avsnr")       (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> 
              anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
          , sortable (Just "users")       (i18nCell MsgTableCompanyNrUsers)          $ \(view resultAllCompanyUsers         -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers)         $ \(view resultAllCompanySupervisors   -> nr) -> wgtCell $ word2widget nr
          , sortable (Just "foreigners")  (i18nCell MsgTableCompanyNrForeignSupers)  $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
          ] 
        dbtSorting = mconcat
          [ singletonMap "name"         $ SortColumn (E.^. CompanyName)
          , singletonMap "short"        $ SortColumn (E.^. CompanyShorthand)
          , singletonMap "avsnr"        $ SortColumn (E.^. CompanyAvsId)
          , singletonMap "users"        $ SortColumn firmCountUsers
          , singletonMap "supervisors"  $ SortColumn firmCountSupervisors
          , singletonMap "foreigners"   $ SortColumn firmCountForeignSupervisors
          ]
        dbtFilter = mconcat
          [            
          ]
        dbtFilterUI = mconcat
          [           
          ]
        dbtStyle =  def -- { dbsFilterLayout = defaultDBSFilterLayout }
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "firm"        
        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
--   | 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 `E.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 = E.select $ do 
--           (quser :& qblock) <- E.from $ E.table @QualificationUser 
--             `E.innerJoin` E.table @QualificationUserBlock
--             `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
--           E.where_ $     quser  E.^. QualificationUserQualification E.==. E.val qid
--             E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
--           E.groupBy     (qblock E.^. QualificationUserBlockReason)        
--           let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
--           E.orderBy [E.desc countRows']
--           E.limit 7
--           pure (qblock E.^. QualificationUserBlockReason)
--         mkOption :: E.Value Text -> Option Text
--         mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
--         suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
--         suggestionsBlock   = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.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           $ pure QualificationActRenewData
--           , 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 icnSuper = text2markup " " <> icon IconSupervisor
--                   cs =  [ (cmpName, cmpSpr) 
--                         | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps                        
--                         , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
--                         ]
--                   companies = intercalate (text2markup ", ") $
--                     (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
--               in wgtCell companies
--           , guardMonoid isAdmin colUserMatriclenr
--           -- , 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, selectedUsers) | isAdmin -> do
--       noks <- runDB $ renewValidQualificationUsers qid 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 nowaday grantValidday Nothing
--       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 $ 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")