Jost, Steffen
92ff99a36e
Previously, the form for granting tutorial users a qualification suggested the minimum of all expiry dates, if there where several course qualficiations. This lead to some users being granted driving licences being valid for only one month. The expiry date can now be left blank, using the validDuration of the selected qualification instead. The default is blank, if there are more than one course qualification having disagreeing qualification dates.
684 lines
40 KiB
Haskell
684 lines
40 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2025 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
|
|
, getQualificationNewR, postQualificationNewR
|
|
, getQualificationEditR, postQualificationEditR
|
|
)
|
|
where
|
|
|
|
import Import
|
|
|
|
import Jobs
|
|
import Handler.Utils
|
|
import Handler.Utils.Users
|
|
import Handler.Utils.LMS
|
|
import Handler.Utils.Company
|
|
|
|
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)
|
|
import Handler.Qualification.Edit as Handler.Qualification
|
|
|
|
|
|
getQualificationSchoolR :: SchoolId -> Handler Html
|
|
-- getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
|
|
getQualificationSchoolR ssh = do
|
|
qualiTable <- runDB $ view _2 <$> mkQualificationAllTable (Just ssh)
|
|
let heading = SomeMessages " " [SomeMessage MsgMenuQualifications, SomeMessage $ unSchoolKey ssh]
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
$(widgetFile "qualification-all")
|
|
|
|
getQualificationAllR :: Handler Html
|
|
getQualificationAllR = do
|
|
qualiTable <- runDB $ view _2 <$> mkQualificationAllTable Nothing
|
|
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 :: Maybe SchoolId -> DB (Any, Widget)
|
|
mkQualificationAllTable ssh = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
svs <- getSupervisees False
|
|
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
|
|
whenIsJust ssh $ E.where_ . ((quali Ex.^. QualificationSchool) E.==.) . E.val
|
|
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 (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
|
|
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
|
|
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
|
|
in tickmarkCell $ elearnstart && isJust reminder
|
|
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
|
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
|
$ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification)
|
|
-- , sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
|
|
-- $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
|
|
-- , 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
|
|
[
|
|
-- guardMonoid (isNothing ssh) 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
|
|
|
|
|
|
data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
|
{ qtcDisplayName :: UserDisplayName
|
|
, qtcEmail :: UserEmail
|
|
, qtcCompany :: Maybe Text
|
|
, 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"
|
|
, 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 MsgTablePrimeCompany)
|
|
, ('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), E.Value (Maybe CompanyId))
|
|
|
|
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
|
|
|
|
resultCompanyId :: Traversal' QualificationTableData CompanyId
|
|
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
|
|
|
|
|
|
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))
|
|
, E.SqlExpr (E.Value (Maybe CompanyId))
|
|
)
|
|
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, selectCompanyUserPrime user)
|
|
|
|
|
|
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)
|
|
-> ((CompanyId -> CompanyName) -> 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 True
|
|
now <- liftIO getCurrentTime
|
|
-- lookup all companies
|
|
cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do
|
|
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
|
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
|
let
|
|
getCompanyName :: CompanyId -> CompanyName
|
|
getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure
|
|
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 = dbtProjId
|
|
dbtColonnade = cols getCompanyName
|
|
dbtSorting = Map.fromList
|
|
[ sortUserNameLink queryUser
|
|
, sortUserEmail queryUser
|
|
, sortUserMatriclenr queryUser
|
|
, ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
|
, ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
|
, ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
|
, ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
|
, ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
|
, ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
|
|
, E.joinV (queryLmsUser row E.?. LmsUserNotified)
|
|
, queryLmsUser row E.?. LmsUserStarted])
|
|
, ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
|
, ("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)
|
|
)
|
|
-- , ("validity", SortColumn $ queryQualUser >>> validQualification now)
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameEmail queryUser
|
|
, ("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
|
|
, ("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
|
|
)
|
|
, ("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
|
|
)
|
|
, ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
|
, ("long-valid",
|
|
let cutoff = if
|
|
| Just refWithin <- qualificationRefreshWithin quali -> computeNewValidDate' (refWithin <> calendarDay) nowaday -- longer valid than renewal
|
|
| Just valDuration <- qualificationValidDuration quali -> computeNewValidDate (valDuration `div` 2) nowaday -- or longer valid than half the duration
|
|
| otherwise -> computeNewValidDate' (calendarYear <> calendarDay) nowaday -- or a year and a day
|
|
in FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>. E.val cutoff) . (E.^. QualificationUserValidUntil)) -- for use with boolField
|
|
-- in FilterColumn $ \(queryQualUser -> quser) (getLast -> criterion) -> if -- for use with checkboxField
|
|
-- | Just True <- criterion -> quser E.^. QualificationUserValidUntil E.>=. E.val cutoff
|
|
-- | otherwise -> E.true
|
|
)
|
|
, ("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
|
|
)
|
|
, ("tobe-notified", FilterColumn $ \row criterion -> if
|
|
| Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
|
|
| otherwise -> E.true
|
|
)
|
|
, ("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 MsgCompanyPersonalNumberFraport)
|
|
, fltrAVSCardNosUI mPrev
|
|
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
|
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgFilterLmsValid)
|
|
, prismAForm (singletonFilter "long-valid" . maybePrism _PathPiece) mPrev $ aopt boolField' (fslI MsgFilterLmsLongValid)
|
|
, 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)
|
|
<*> preview (resultCompanyId . to getCompanyName . _CI)
|
|
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
|
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
|
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
|
<*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
|
|
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
|
<*> getStatusPlusTxt
|
|
<*> getStatusPlusDay
|
|
|
|
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=lmsAuditDays
|
|
, 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 9
|
|
pure (qblock Ex.^. QualificationUserBlockReason)
|
|
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
|
suggestionsBlock = mkOptionListText <$> runDB (getBlockReasons Ex.not_)
|
|
suggestionsUnblock = mkOptionListText <$> runDB (getBlockReasons id)
|
|
dayExpiry = flip computeNewValidDate nowaday <$> 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 getCompanyName = mconcat
|
|
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, colUserNameModalHdr MsgLmsUser linkUserName
|
|
, colUserEmail
|
|
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
|
|
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
|
|
, 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 lmsAuditDays))
|
|
$ \(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
|
|
let selUsrs = Set.toList selectedUsers
|
|
(noks,nterm) <- runDB $ (,)
|
|
<$> renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing selUsrs
|
|
<*> terminateLms (LmsOrphanReasonManualRenewal renewReason) qid selUsrs
|
|
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks
|
|
when (nterm >0) $ addMessageI Warning $ MsgLmsActTerminated nterm
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
(QualificationActGrantData grantValidDay, selectedUsers) | isAdmin -> do
|
|
grantValidDayText <- formatTime SelFormatDate grantValidDay
|
|
nterm <- runDB $ do
|
|
forM_ selectedUsers $ upsertQualificationUser qid now grantValidDay Nothing "Admin"
|
|
terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidDay) qid $ Set.toList selectedUsers
|
|
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh grantValidDayText $ Set.size selectedUsers
|
|
when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
|
|
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
|
|
addMessageOutOfI (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")
|