chore(firm): initial stub

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -133,6 +133,8 @@ MenuLmsFake: Testnutzer generieren
 MenuLmsLearners: Export Benutzer E‑Learning
 MenuLmsReport: Ergebnisse E‑Learning
 
+MenuFirms: Firmen
+
 MenuSap: SAP Schnittstelle
 
 MenuAvs: AVS Schnittstelle

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -134,6 +134,8 @@ MenuLmsFake: Generate Test Users
 MenuLmsLearners: E‑learning Users
 MenuLmsReport: E‑learning Results
 
+MenuFirms: Companies
+
 MenuSap: SAP Interface 
 
 MenuAvs: AVS Interface

routes

@@ -113,6 +113,8 @@
 /for/#CryptoUUIDUser/user         ForProfileR       GET POST    !supervisor !self
 /for/#CryptoUUIDUser/user/profile ForProfileDataR   GET         !supervisor !self
 
+/firm                      FirmAllR            GET
+/firm/#CompanyShorthand    FirmR               GET POST
 
 /exam-office               ExamOfficeR                         !exam-office:
   /                        EOExamsR            GET POST        !system-exam-office

src/Application.hs

@@ -159,6 +159,7 @@ import Handler.SAP
 import Handler.PrintCenter
 import Handler.ApiDocs
 import Handler.Swagger
+import Handler.Firm
 
 import ServantApi () -- YesodSubDispatch instances
 import Servant.API

src/Foundation/Navigation.hs

@@ -123,6 +123,9 @@ breadcrumb ProblemFbutNoR       = i18nCrumb MsgProblemsRWithoutFHeading   $ Just
 breadcrumb ProblemAvsSynchR     = i18nCrumb MsgProblemsAvsSynchHeading    $ Just AdminProblemsR
 breadcrumb ProblemAvsErrorR     = i18nCrumb MsgProblemsAvsErrorHeading    $ Just ProblemAvsSynchR
 
+breadcrumb FirmAllR         = i18nCrumb MsgMenuFirms            Nothing
+breadcrumb FirmR            = i18nCrumb MsgMenuFirms          $ Just FirmAllR
+
 breadcrumb PrintCenterR     = i18nCrumb MsgMenuApc              Nothing
 breadcrumb PrintSendR       = i18nCrumb MsgMenuPrintSend      $ Just PrintCenterR
 breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload  $ Just PrintCenterR

src/Handler/Firm.hs

@@ -0,0 +1,663 @@
+-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+{-# 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 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
+
+
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
+
+getFirmAllR :: Handler Html
+getFirmAllR = do
+  siteLayoutMsg MsgMenuFirms $ do 
+    setTitleI MsgMenuFirms
+    [whamlet|STUB TO DO|]
+
+
+getFirmR,  postFirmR :: CompanyShorthand -> Handler Html
+getFirmR = postFirmR
+postFirmR _ = do
+  siteLayoutMsg MsgMenuFirms $ do 
+    setTitleI MsgMenuFirms
+    [whamlet|STUB TO DO|]
+
+
+--   isAdmin <- hasReadAccessTo AdminR
+--   firmTable <- runDB $ do
+--     view _2 <$> mkFirmAllTable isAdmin
+--   siteLayoutMsg MsgMenuFirms $ do
+--     setTitleI MsgMenuFirms
+--     $(widgetFile "firm-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
+--   | 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           $ 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")