683 lines
40 KiB
Haskell
683 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 noks
|
|
when (nterm >0) $ addMessageI Warning $ MsgLmsActTerminated nterm
|
|
reloadKeepGetParams $ QualificationR sid qsh
|
|
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
|
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 $ 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")
|