680 lines
38 KiB
Haskell
680 lines
38 KiB
Haskell
-- 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")
|