Steffen
468af9de9d
LmsR is intended to be seen by Fraport Admins only, while QualificationR is intended to be seen by Supervisors (in the future). The LMS reuse information might confuse non-admins and is irrelevant to them.
681 lines
39 KiB
Haskell
681 lines
39 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <S.Jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Handler.Qualification
|
|
( getQualificationAllR
|
|
, getQualificationSchoolR
|
|
, getQualificationR, postQualificationR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Jobs
|
|
import Handler.Utils
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.LMS
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Csv as Csv
|
|
import qualified Data.Text as T
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Conduit.List as C
|
|
import Database.Persist.Sql (updateWhereCount)
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
-- import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
-- import Handler.Utils.Qualification (validQualification)
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
getQualificationSchoolR :: SchoolId -> Handler Html
|
|
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
|
|
|
|
getQualificationAllR :: Handler Html
|
|
getQualificationAllR = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
qualiTable <- runDB $ do
|
|
view _2 <$> mkQualificationAllTable isAdmin
|
|
siteLayoutMsg MsgMenuQualifications $ do
|
|
setTitleI MsgMenuQualifications
|
|
$(widgetFile "qualification-all")
|
|
|
|
type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64)
|
|
resultAllQualification :: Lens' AllQualificationTableData Qualification
|
|
resultAllQualification = _dbrOutput . _1 . _entityVal
|
|
|
|
resultAllQualificationActive :: Lens' AllQualificationTableData Word64
|
|
resultAllQualificationActive = _dbrOutput . _2 . _unValue
|
|
|
|
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
|
|
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
|
|
|
|
|
mkQualificationAllTable :: Bool -> DB (Any, Widget)
|
|
mkQualificationAllTable isAdmin = do
|
|
svs <- getSupervisees
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery quali = do
|
|
let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
|
|
Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs)
|
|
cusers = Ex.subSelectCount $ do
|
|
quser <- Ex.from $ Ex.table @QualificationUser
|
|
Ex.where_ $ filterSvs quser
|
|
cactive = Ex.subSelectCount $ do
|
|
quser <- Ex.from $ Ex.table @QualificationUser
|
|
Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser
|
|
return (quali, cactive, cusers)
|
|
dbtRowKey = (Ex.^. QualificationId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ colSchool $ resultAllQualification . _qualificationSchool
|
|
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
|
|
let qsh = qualificationShorthand quali in
|
|
anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh
|
|
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
|
|
let qsh = qualificationShorthand quali
|
|
qnm = qualificationName quali
|
|
in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm
|
|
, sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) ->
|
|
maybeCell (qualificationDescription quali) markupCellLargeModal
|
|
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
|
|
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
|
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
|
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
|
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
|
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
|
, sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
|
|
$ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
|
|
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
|
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
|
|
-- , sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip)
|
|
-- $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell
|
|
, 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
|
|
| QualificationActStartELearning
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
instance Universe QualificationTableAction
|
|
instance Finite QualificationTableAction
|
|
nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''QualificationTableAction id
|
|
|
|
{-
|
|
isAdminAct :: QualificationTableAction -> Bool
|
|
isAdminAct QualificationActExpire = False
|
|
isAdminAct QualificationActUnexpire = False
|
|
isAdminAct QualificationActBlockSupervisor = False
|
|
isAdminAct _ = True
|
|
-}
|
|
|
|
data QualificationTableActionData
|
|
= QualificationActExpireData
|
|
| QualificationActUnexpireData
|
|
| QualificationActBlockSupervisorData
|
|
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
|
|
| QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool }
|
|
| QualificationActRenewData { qualTableActChangeReason :: Text }
|
|
| QualificationActGrantData { qualTableActGrantUntil :: Day }
|
|
| QualificationActStartELearningData -- { qualTableActELearnUntil :: Maybe 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] [Desc UserCompanyPriority, Asc UserCompanyCompany, LimitTo 1]
|
|
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",SortColumnNullsInv $ \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))) ))
|
|
, fltrAVSCardNos queryUser
|
|
, 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)
|
|
, fltrAVSCardNosUI mPrev
|
|
, 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, lmsQualiReused) <- runDB $ do
|
|
qent@Entity{
|
|
entityKey=qid
|
|
, entityVal=Qualification{
|
|
qualificationAuditDuration=auditMonths
|
|
, qualificationValidDuration=validMonths
|
|
, qualificationLmsReuses =reuseQuali
|
|
}} <- getBy404 $ SchoolQualificationShort sid qsh
|
|
lmsQualiReused <- traverseJoin get reuseQuali
|
|
-- Block copied to Handler/Qualifications TODO: refactor
|
|
let getBlockReasons unblk = Ex.select $ do
|
|
(quser :& qblock) <- Ex.from $ Ex.table @QualificationUser
|
|
`Ex.innerJoin` Ex.table @QualificationUserBlock
|
|
`Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser)
|
|
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid
|
|
Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock)
|
|
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
|
|
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
|
|
Ex.orderBy [Ex.desc countRows']
|
|
Ex.limit 7
|
|
pure (qblock Ex.^. QualificationUserBlockReason)
|
|
mkOption :: Ex.Value Text -> Option Text
|
|
mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
|
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
|
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_)
|
|
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
|
|
dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
|
|
acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
|
acts = mconcat $
|
|
[ singletonMap QualificationActExpire $ pure QualificationActExpireData
|
|
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData
|
|
<$ aformMessage msgUnexpire
|
|
] ++ bool
|
|
-- nonAdmin actions, ie. Supervisor
|
|
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
|
|
-- Admin-only actions
|
|
[ singletonMap QualificationActUnblock $ QualificationActUnblockData
|
|
<$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
|
, singletonMap QualificationActBlock $ QualificationActBlockData
|
|
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
|
|
, singletonMap QualificationActRenew $ QualificationActRenewData
|
|
<$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing
|
|
, singletonMap QualificationActGrant $ QualificationActGrantData
|
|
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
|
<* aformMessage msgGrantWarning
|
|
, singletonMap QualificationActStartELearning $ pure QualificationActStartELearningData
|
|
-- <$> aopt dayField (fslI MsgQualificationReduceValidUntil) Nothing
|
|
] 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 MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
|
|
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
|
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
|
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
|
]
|
|
in intercalate spacerCell cs
|
|
, guardMonoid isAdmin $ colUserMatriclenr isAdmin
|
|
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
|
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
|
|
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
|
qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
|
|
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
|
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
|
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
|
|
$ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
|
|
-- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change.
|
|
-- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion!
|
|
-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip)
|
|
-- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
|
|
]
|
|
psValidator = def & defaultSorting [SortDescBy "last-refresh"]
|
|
tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
|
|
return (tbl, qent, lmsQualiReused)
|
|
|
|
formResult lmsRes $ \case
|
|
(QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do
|
|
noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers
|
|
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
|
runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
|
|
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
(QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do
|
|
-- whenIsJust mbExpDay $ \expDay ->
|
|
-- when expDay > nowaday $
|
|
-- -- updateWhere [QualificationUserQualification ==. qid, QualificationUserUser <-. selectedUsers, QualificationUserValidUntil >. expDay] [QualificationUserValidUntil =. expDay] -- DO NOT USE: no audit
|
|
-- NOTE: if needed, create function Handler.Utils.Qualification.updateQualificationUser qid QualificationChangeReason -> Day -> [UserId] -> DB Int
|
|
validQualHolderEnts <- runDB $ selectValidQualifications qid selectedUsers now
|
|
let validQualHolders = view (_entityVal . _qualificationUserUser) <$> validQualHolderEnts
|
|
jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid
|
|
let nrTodo = length selectedUsers
|
|
nrEnqueued = length $ catMaybes jobs
|
|
addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo
|
|
-- transaction audit identical to automatic start, performed by JobLmsEnqueueUser
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
(action, selectedUsers) | isExpiryAct action -> do
|
|
let isUnexpire = action == QualificationActUnexpireData
|
|
upd <- runDB $ do
|
|
forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
|
|
{ transactionUser = uid
|
|
, transactionQualification = qid
|
|
, transactionQualificationScheduleRenewal = Just isUnexpire
|
|
}
|
|
updateWhereCount
|
|
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
|
|
[QualificationUserScheduleRenewal =. isUnexpire]
|
|
let msgKind = if upd > 0 then Success else Warning
|
|
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
|
addMessageI msgKind msgVal
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
|
|
let selUserIds = Set.toList selectedUsers
|
|
(unblock, reason) = case action of
|
|
QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
|
|
QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
|
|
QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
|
|
_ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
|
|
notify = case action of
|
|
QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
|
|
_ -> False
|
|
|
|
oks <- runDB $ do
|
|
when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
|
|
qualificationUserBlocking qid selUserIds unblock Nothing reason notify
|
|
let nrq = length selectedUsers
|
|
warnLevel = if
|
|
| oks < 0 -> Error
|
|
| oks == nrq -> Success
|
|
| otherwise -> Warning
|
|
fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock
|
|
addMessageI warnLevel $ fbmsg qsh oks nrq
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
_ -> addMessageI Error MsgInvalidFormAction
|
|
|
|
let heading = citext2widget $ qualificationName quali
|
|
siteLayout heading $ do
|
|
setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
|
$(widgetFile "qualification")
|