833 lines
47 KiB
Haskell
833 lines
47 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,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.LMS
|
|
( getLmsAllR , postLmsAllR
|
|
, getLmsSchoolR
|
|
, getLmsR , postLmsR
|
|
, getLmsIdentR
|
|
, getLmsEditR , postLmsEditR
|
|
-- V2
|
|
, getLmsLearnersR , getLmsLearnersDirectR
|
|
, getLmsReportR , postLmsReportR
|
|
, getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR
|
|
--
|
|
, getLmsFakeR , postLmsFakeR
|
|
, getLmsUserR
|
|
, getLmsUserSchoolR
|
|
, getLmsUserAllR
|
|
)
|
|
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.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 Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
|
-- V2
|
|
import Handler.LMS.Learners as Handler.LMS
|
|
import Handler.LMS.Report as Handler.LMS
|
|
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
|
|
|
|
|
|
-- Button only needed here
|
|
data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
|
|
instance Universe ButtonManualLms
|
|
instance Finite ButtonManualLms
|
|
|
|
nullaryPathPiece ''ButtonManualLms camelToPathPiece
|
|
embedRenderMessage ''UniWorX ''ButtonManualLms id
|
|
|
|
instance Button UniWorX ButtonManualLms where
|
|
btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary]
|
|
btnClasses BtnLmsDequeue = [BCIsButton, BCPrimary]
|
|
|
|
|
|
getLmsSchoolR :: SchoolId -> Handler Html
|
|
getLmsSchoolR ssh = redirect (LmsAllR, [("lms-overview-school", toPathPiece ssh)])
|
|
|
|
getLmsAllR, postLmsAllR :: Handler Html
|
|
getLmsAllR = postLmsAllR
|
|
postLmsAllR = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
mbJLQenqueue <- getsYesod $ view _appJobLmsQualificationsEnqueueHour
|
|
mbJLQdequeue <- getsYesod $ view _appJobLmsQualificationsDequeueHour
|
|
-- TODO: Move this functionality elsewhere without the need for `isAdmin`
|
|
mbBtnForm <- if not isAdmin then return Nothing else do
|
|
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
|
|
case btnResult of
|
|
(FormSuccess BtnLmsEnqueue) ->
|
|
queueJob' JobLmsQualificationsEnqueue
|
|
>> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
|
|
(FormSuccess BtnLmsDequeue) ->
|
|
queueJob' JobLmsQualificationsDequeue
|
|
>> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
|
|
FormMissing -> return ()
|
|
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
|
|
return $ Just $ wrapForm btnWdgt def
|
|
{ formAction = Just $ SomeRoute LmsAllR
|
|
, formEncoding = btnEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
|
|
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
|
lmsTable <- runDB $ do
|
|
view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays
|
|
siteLayoutMsg MsgMenuLms $ do
|
|
setTitleI MsgMenuLms
|
|
$(i18nWidgetFile "lms-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
|
|
|
|
|
|
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
|
|
mkLmsAllTable isAdmin lmsDeletionDays = do
|
|
svs <- getSupervisees
|
|
let
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery quali = do
|
|
let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
|
|
Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
|
|
cusers = Ex.subSelectCount $ do
|
|
luser <- Ex.from $ Ex.table @LmsUser
|
|
Ex.where_ $ filterSvs luser
|
|
cactive = Ex.subSelectCount $ do
|
|
luser <- Ex.from $ Ex.table @LmsUser
|
|
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
|
|
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
|
|
return (quali, cactive, cusers)
|
|
dbtRowKey = (Ex.^. QualificationId)
|
|
dbtProj = dbtProjId
|
|
adminable = if isAdmin then sortable else \_ _ _ -> mempty
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ colSchool $ resultAllQualification . _qualificationSchool
|
|
, sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) ->
|
|
let qsh = qualificationShorthand quali in
|
|
anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qsh
|
|
, sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) ->
|
|
let qsh = qualificationShorthand quali
|
|
qnm = qualificationName quali
|
|
in anchorCell (LmsR (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 MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
|
|
, 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 Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
|
|
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
|
|
, sortable (Just "qel-renew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew)
|
|
$ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews)
|
|
, sortable (Just "qel-limit") (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimit)
|
|
$ cellMaybe numCell . view (resultAllQualification . _qualificationElearningLimit)
|
|
, sortable (Just "qel-reuse") (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) ->
|
|
let icn = IconOK -- change icon here, if desired
|
|
in case mbSapId of
|
|
Nothing -> mempty
|
|
Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty
|
|
Just _ -> iconCell icn
|
|
, adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
|
|
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
|
|
, adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
|
|
-- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n
|
|
]
|
|
dbtSorting = mconcat
|
|
[
|
|
sortSchool $ to (E.^. QualificationSchool)
|
|
, singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand)
|
|
, singletonMap "qname" $ SortColumn (E.^. QualificationName)
|
|
, singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart)
|
|
, singletonMap "qel-renew" $ SortColumn (E.^. QualificationElearningRenews)
|
|
, singletonMap "qel-limit" $ SortColumn (E.^. QualificationElearningLimit)
|
|
, singletonMap "qel-reuse" $ SortColumn (E.^. QualificationLmsReuses)
|
|
]
|
|
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 = "lms-overview"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy "school", SortAscBy "qshort"]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
|
|
|
|
getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsEditR = postLmsEditR
|
|
postLmsEditR = error "TODO: STUB"
|
|
|
|
|
|
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
|
|
{ ltcDisplayName :: UserDisplayName
|
|
, ltcEmail :: UserEmail
|
|
, ltcCompany :: Maybe Text
|
|
, ltcValidUntil :: Day
|
|
, ltcLastRefresh :: Day
|
|
, ltcFirstHeld :: Day
|
|
, ltcBlockStatus :: Maybe Bool
|
|
, ltcBlockFrom :: Maybe UTCTime
|
|
, ltcLmsIdent :: LmsIdent
|
|
, ltcLmsStatus :: Maybe LmsStatus
|
|
, ltcLmsStatusDay :: Maybe UTCTime
|
|
, ltcLmsStarted :: UTCTime
|
|
, ltcLmsDatePin :: UTCTime
|
|
, ltcLmsReceived :: Maybe UTCTime
|
|
, ltcLmsNotified :: Maybe UTCTime
|
|
, ltcLmsEnded :: Maybe UTCTime
|
|
}
|
|
deriving Generic
|
|
makeLenses_ ''LmsTableCsv
|
|
|
|
ltcExample :: LmsTableCsv
|
|
ltcExample = LmsTableCsv
|
|
{ ltcDisplayName = "Max Mustermann"
|
|
, ltcEmail = "m.mustermann@example.com"
|
|
, ltcCompany = Just "Example Brothers LLC"
|
|
, ltcValidUntil = succ compDay
|
|
, ltcLastRefresh = compDay
|
|
, ltcFirstHeld = pred $ pred compDay
|
|
, ltcBlockStatus = Nothing
|
|
, ltcBlockFrom = Nothing
|
|
, ltcLmsIdent = LmsIdent "abcdefgh"
|
|
, ltcLmsStatus = Just LmsSuccess
|
|
, ltcLmsStatusDay = Just compTime
|
|
, ltcLmsStarted = compTime
|
|
, ltcLmsDatePin = compTime
|
|
, ltcLmsReceived = Nothing
|
|
, ltcLmsNotified = Nothing
|
|
, ltcLmsEnded = Nothing
|
|
}
|
|
where
|
|
compTime :: UTCTime
|
|
compTime = $compileTime
|
|
compDay :: Day
|
|
compDay = utctDay compTime
|
|
|
|
ltcOptions :: Csv.Options
|
|
ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
|
|
where
|
|
renameLtc "ltcDisplayName" = "licensee"
|
|
renameLtc "ltcLmsDatePin" = prefixLms "pin-created"
|
|
renameLtc "ltcLmsReceived" = prefixLms "last-update"
|
|
renameLtc other = replaceLtc $ camelToPathPiece' 1 other
|
|
replaceLtc ('l':'m':'s':'-':t) = prefixLms t
|
|
replaceLtc other = other
|
|
prefixLms = ("e-learn-" <>)
|
|
|
|
instance Csv.ToNamedRecord LmsTableCsv where
|
|
toNamedRecord = Csv.genericToNamedRecord ltcOptions
|
|
|
|
instance Csv.DefaultOrdered LmsTableCsv where
|
|
headerOrder = Csv.genericHeaderOrder ltcOptions
|
|
|
|
instance CsvColumnsExplained LmsTableCsv where
|
|
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
|
|
[ ('ltcDisplayName , SomeMessage MsgLmsUser)
|
|
, ('ltcEmail , SomeMessage MsgTableLmsEmail)
|
|
, ('ltcCompany , SomeMessage MsgTablePrimeCompany)
|
|
, ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
|
, ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
|
, ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
|
|
, ('ltcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
|
|
, ('ltcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
|
, ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
|
|
, ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
|
|
, ('ltcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
|
|
, ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
|
|
, ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin)
|
|
, ('ltcLmsReceived , SomeMessage MsgTableLmsReceived)
|
|
, ('ltcLmsEnded , SomeMessage MsgTableLmsEnded)
|
|
]
|
|
|
|
|
|
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
`E.InnerJoin` E.SqlExpr (Entity LmsUser)
|
|
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
|
|
|
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
|
|
queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
|
|
|
|
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
|
|
|
|
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
|
|
queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
|
|
|
queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
|
queryQualBlock = $(sqlLOJproj 2 2)
|
|
|
|
|
|
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool)
|
|
|
|
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
|
|
resultQualUser = _dbrOutput . _1
|
|
|
|
resultUser :: Lens' LmsTableData (Entity User)
|
|
resultUser = _dbrOutput . _2
|
|
|
|
resultLmsUser :: Lens' LmsTableData (Entity LmsUser)
|
|
resultLmsUser = _dbrOutput . _3
|
|
|
|
resultQualBlock :: Traversal' LmsTableData (Entity QualificationUserBlock)
|
|
resultQualBlock = _dbrOutput . _4 . _Just
|
|
|
|
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
|
|
resultPrintAck = _dbrOutput . _5 . _unValue . _Just
|
|
|
|
resultCompanyId :: Traversal' LmsTableData CompanyId
|
|
resultCompanyId = _dbrOutput . _6 . _unValue . _Just
|
|
|
|
resultValidQualification :: Lens' LmsTableData Bool
|
|
resultValidQualification = _dbrOutput . _7 . _unValue
|
|
|
|
instance HasEntity LmsTableData User where
|
|
hasEntity = resultUser
|
|
|
|
instance HasUser LmsTableData where
|
|
hasUser = resultUser . _entityVal
|
|
|
|
instance HasEntity LmsTableData QualificationUser where
|
|
hasEntity = resultQualUser
|
|
|
|
instance HasQualificationUser LmsTableData where
|
|
hasQualificationUser = resultQualUser . _entityVal
|
|
|
|
data LmsTableAction = LmsActNotify
|
|
| LmsActRenewNotify
|
|
| LmsActRenewPin
|
|
| LmsActReset
|
|
| LmsActRestart
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''LmsTableAction id
|
|
|
|
data LmsTableActionData = LmsActNotifyData
|
|
| LmsActRenewNotifyData
|
|
| LmsActRenewPinData -- no longer used
|
|
| LmsActResetData
|
|
{ lmsActRestartExtend :: Maybe Integer
|
|
, lmsActRestartUnblock :: Maybe Bool
|
|
, lmsActRestartNotify :: Maybe Bool
|
|
}
|
|
| LmsActRestartData
|
|
{ lmsActRestartExtend :: Maybe Integer
|
|
, lmsActRestartUnblock :: Maybe Bool
|
|
, lmsActRestartNotify :: Maybe Bool
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
isNotifyAct :: LmsTableActionData -> Bool
|
|
isNotifyAct LmsActNotifyData = True
|
|
isNotifyAct LmsActRenewNotifyData = True
|
|
isNotifyAct _ = False
|
|
|
|
isRenewPinAct :: LmsTableActionData -> Bool
|
|
isRenewPinAct LmsActRenewNotifyData = True
|
|
isRenewPinAct LmsActRenewPinData = True
|
|
isRenewPinAct _ = False
|
|
|
|
isResetAct :: LmsTableActionData -> Bool
|
|
isResetAct LmsActResetData{} = True
|
|
isResetAct _ = False
|
|
|
|
isResetRestartAct :: LmsTableActionData -> Bool
|
|
isResetRestartAct LmsActRestartData{} = True
|
|
isResetRestartAct other = isResetAct other
|
|
|
|
|
|
lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr
|
|
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
|
, E.SqlExpr (Entity User)
|
|
, E.SqlExpr (Entity LmsUser)
|
|
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
|
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
|
|
, E.SqlExpr (E.Value (Maybe CompanyId))
|
|
, E.SqlExpr (E.Value Bool)
|
|
)
|
|
lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
|
-- RECALL: another outer join on PrintJob did not work out well, since
|
|
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
|
|
-- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all;
|
|
-- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest
|
|
E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
|
E.&&. qualBlock `isLatestBlockBefore` E.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_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
|
|
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
|
|
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
|
|
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
|
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
|
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
|
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
|
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
|
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, selectCompanyUserPrime user, validQualification now qualUser)
|
|
|
|
|
|
mkLmsTable :: ( Functor h, ToSortable h
|
|
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols
|
|
)
|
|
=> Bool
|
|
-> Entity Qualification
|
|
-> Map LmsTableAction (AForm Handler LmsTableActionData)
|
|
-> ((CompanyId -> CompanyName) -> cols)
|
|
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
|
|
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
|
|
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|
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
|
|
|
|
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
|
|
dbtIdent :: Text
|
|
dbtIdent = "lms"
|
|
dbtSQLQuery = lmsTableQuery now qid
|
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = cols getCompanyName
|
|
dbtSorting = Map.fromList
|
|
[ sortUserNameLink queryUser
|
|
, sortUserEmail queryUser
|
|
, sortUserMatriclenr queryUser
|
|
, ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
|
-- , ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
|
|
, ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
|
, ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
|
, ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
|
, ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
|
, ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
|
|
, ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
|
|
-- , ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
|
|
, ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
|
|
, queryLmsUser row E.^. LmsUserNotified
|
|
](queryLmsUser row E.^. LmsUserStarted))
|
|
|
|
, ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
|
|
, ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
|
|
, ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
|
|
, ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
|
|
, ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
|
|
, ("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)
|
|
)
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameEmail queryUser
|
|
, ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
|
|
, ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
|
|
-- , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
|
|
, ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
|
-- , ("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
|
|
-- )
|
|
, ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
|
|
, ("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))) ))
|
|
, ("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 $ ciOriginal criterion
|
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
|
)
|
|
, 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
|
|
)
|
|
]
|
|
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 "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
|
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
|
, prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
|
|
, prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
|
|
-- , if isNothing mbRenewal then mempty
|
|
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
|
]
|
|
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 ltcExample
|
|
, dbtCsvExampleData = Just [ltcExample]
|
|
}
|
|
where
|
|
doEncode' :: LmsTableData -> LmsTableCsv
|
|
doEncode' = LmsTableCsv
|
|
<$> view (resultUser . _entityVal . _userDisplayName)
|
|
<*> view (resultUser . _entityVal . _userDisplayEmail)
|
|
<*> preview (resultCompanyId . to getCompanyName . _CI)
|
|
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
|
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
|
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld)
|
|
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockUnblock . _not)
|
|
<*> preview (resultQualBlock . _entityVal . _qualificationUserBlockFrom)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserIdent)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserStatus)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserStatusDay)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserStarted)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserDatePin)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
|
|
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
|
|
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
|
|
DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
|
|
-- acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
|
|
-- acts = mconcat
|
|
-- [ singletonMap LmsActNotify $ pure LmsActNotifyData
|
|
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
|
|
-- ]
|
|
postprocess :: FormResult (First act', DBFormResult UserId Bool LmsTableData)
|
|
-> FormResult ( act', 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 LmsTableActionData, DBFormResult UserId Bool LmsTableActionData))
|
|
-- resultDBTableValidator = def
|
|
-- & defaultSorting [SortAscBy csvLmsIdent]
|
|
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
|
|
getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsR = postLmsR
|
|
postLmsR sid qsh = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
msgResetInfo <- messageIconI Info IconNotificationNonactive MsgLmsActResetInfo
|
|
msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning
|
|
|
|
((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do
|
|
qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali}} <- getBy404 $ SchoolQualificationShort sid qsh
|
|
lmsQualiReused <- traverseJoin get reuseQuali
|
|
let acts :: Map LmsTableAction (AForm Handler LmsTableActionData)
|
|
acts = mconcat
|
|
[ singletonMap LmsActNotify $ pure LmsActNotifyData
|
|
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
|
|
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
|
|
, singletonMap LmsActReset $ LmsActResetData
|
|
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
|
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
|
|
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
|
|
<* aformMessage msgResetInfo
|
|
, singletonMap LmsActRestart $ LmsActRestartData
|
|
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
|
|
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
|
|
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
|
|
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
|
|
<* aformMessage msgRestartWarning
|
|
]
|
|
colChoices getCompanyName = mconcat
|
|
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
|
|
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
|
|
, colUserEmail
|
|
, sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) ->
|
|
maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False
|
|
, 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) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
|
|
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row ->
|
|
qualificationValidReasonCell'' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row (row ^. resultValidQualification) -- TODO: resultValidQualification for debugging only
|
|
-- DEBUG
|
|
-- , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging
|
|
-- DEBUG
|
|
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
|
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
|
, sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid
|
|
, sortable (Just "pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
|
|
) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin
|
|
, sortable (Just "status") (i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin $ qent ^. _entityVal . _qualificationAuditDuration))
|
|
$ \(view $ resultLmsUser . _entityVal -> lmsUserVal) -> lmsStatusCell isAdmin Nothing lmsUserVal
|
|
, sortable (Just "started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d
|
|
, sortable (Just "datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d
|
|
, sortable (Just "received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
|
|
--, sortable (Just "notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
|
|
, sortable (Just "notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
|
|
-- 4 Cases:
|
|
-- - No notification: LmsUserNotified == Nothing
|
|
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
|
|
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
|
|
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
|
|
let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
|
|
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
|
|
recipient = row ^. hasUser
|
|
letterDates = row ^? resultPrintAck
|
|
lastLetterDate = headDef Nothing =<< letterDates
|
|
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
|
|
notNotified = isNothing notifyDate
|
|
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
|
|
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
|
|
| Just d <- lastLetterDate -> dateTimeCell d
|
|
| otherwise -> i18nCell MsgPrintJobUnacknowledged
|
|
lprLink :: Route UniWorX = lmsident & (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
|
|
cAckDates = case letterDates of
|
|
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
|
|
<h1>
|
|
_{MsgPrintJobAcknowledgements} ^{userWidget recipient}
|
|
<ul>
|
|
$forall mbackdate <- ackDates
|
|
<li>
|
|
#{iconLetter} #
|
|
$maybe ackdate <- mbackdate
|
|
^{formatTimeW SelFormatDateTime ackdate}
|
|
$nothing
|
|
_{MsgPrintJobUnacknowledged}
|
|
<p>
|
|
<a href=@{lprLink}>
|
|
_{MsgPrintJobs}
|
|
|]
|
|
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
|
|
_ -> mempty
|
|
|
|
in if notNotified
|
|
then mempty
|
|
else cIcon <> spacerCell <> cDate <> cAckDates
|
|
-- , sortable (Just "notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
|
|
, sortable (Just "ended") (i18nLms MsgTableLmsEnded) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d
|
|
]
|
|
where
|
|
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
|
i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg
|
|
psValidator = def & defaultSorting [SortDescBy "started", SortDescBy "status"]
|
|
tbl <- mkLmsTable isAdmin qent acts colChoices psValidator
|
|
return (tbl, qent, lmsQualiReused)
|
|
|
|
formResult lmsRes $ \case
|
|
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
|
|
|
|
(action, selectedUsers) | isResetRestartAct action -> do
|
|
let usersList = Set.toList selectedUsers
|
|
numUsers = Set.size selectedUsers
|
|
isReset = isResetAct action
|
|
actRestartExtend = action & lmsActRestartExtend
|
|
actRestartUnblock = action & lmsActRestartUnblock
|
|
actRestartNotify = action & lmsActRestartNotify
|
|
|
|
chgUsers <- runDB $ do
|
|
when (actRestartUnblock == Just True) $ do
|
|
oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify)
|
|
addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
|
|
|
|
whenIsJust actRestartExtend $ \extDays -> do
|
|
let cutoff = addDays extDays nowaday
|
|
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
|
|
[ QualificationUserQualification ==. qid
|
|
, QualificationUserUser <-. usersList
|
|
, QualificationUserValidUntil <. cutoff
|
|
] []
|
|
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
|
|
|
|
fromIntegral <$> (if isReset
|
|
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmless, but delays reset until lock is effective
|
|
++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired]))
|
|
(bcons actRestartNotify (LmsUserNotified =. Nothing) [LmsUserResetTries =. True])
|
|
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
|
|
)
|
|
|
|
unless isReset $
|
|
forM_ selectedUsers $ \uid ->
|
|
queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
|
|
|
runDB $ forM_ selectedUsers $ \uid ->
|
|
audit $ TransactionLmsReset
|
|
{ transactionQualification = qid
|
|
, transactionLmsUser = uid
|
|
, transactionLmsReset = isReset
|
|
, transactionLmsResetExtend = actRestartExtend
|
|
, transactionLmsResetUnblock = actRestartUnblock
|
|
, transactionLmsResetNotify = actRestartNotify
|
|
}
|
|
|
|
let mStatus = bool Success Warning $ chgUsers < numUsers
|
|
addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
|
|
reloadKeepGetParams $ LmsR sid qsh
|
|
|
|
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
|
|
numExaminees <- runDB $ do
|
|
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
|
|
, LmsUserEnded ==. Nothing -- not yet deleted
|
|
, LmsUserStatus ==. Nothing -- not yet decided
|
|
, LmsUserUser <-. Set.toList selectedUsers -- selected
|
|
] []
|
|
forM_ okUsers $ \(Entity lid LmsUser {lmsUserUser = uid, lmsUserQualification = qid'}) -> do
|
|
when (isRenewPinAct action) $ do
|
|
newPin <- liftIO randomLMSpw
|
|
update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True]
|
|
when (isNotifyAct action) $
|
|
queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
|
|
return $ length okUsers
|
|
let numSelected = length selectedUsers
|
|
diffSelected = numSelected - numExaminees
|
|
mstat = bool Success Warning $ diffSelected /= 0
|
|
when (isRenewPinAct action) $ addMessageI mstat $ MsgLmsPinRenewal numExaminees
|
|
when (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees
|
|
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
|
|
reloadKeepGetParams $ LmsR sid qsh
|
|
_ -> addMessageI Error MsgUnauthorized -- should not happen
|
|
|
|
let heading = citext2widget $ "LMS " <> qualificationName quali
|
|
siteLayout heading $ do
|
|
setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
|
|
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
|
$(widgetFile "lms")
|
|
|
|
-- redirect to a specific lms user
|
|
getLmsIdentR :: SchoolId -> QualificationShorthand -> LmsIdent -> Handler Html
|
|
getLmsIdentR sid qid ident = redirect (LmsR sid qid, [("lms-ident", toPathPiece ident)])
|
|
|
|
-- intended to be viewed primarily in a modal, wie lmsStatusCell
|
|
getLmsUserAllR :: CryptoUUIDUser -> Handler Html
|
|
getLmsUserAllR = viewLmsUserR Nothing Nothing
|
|
|
|
getLmsUserSchoolR :: CryptoUUIDUser -> SchoolId -> Handler Html
|
|
getLmsUserSchoolR uuid sid = viewLmsUserR (Just sid) Nothing uuid
|
|
|
|
getLmsUserR :: SchoolId -> QualificationShorthand -> CryptoUUIDUser -> Handler Html
|
|
getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)
|
|
|
|
viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
|
|
viewLmsUserR msid mqsh uuid = do
|
|
uid <- decrypt uuid
|
|
now <- liftIO getCurrentTime
|
|
(user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
|
|
usr <- get404 uid
|
|
qs <- Ex.select $ do
|
|
(qual :& qualUsr :& lmsUsr) <-
|
|
Ex.from $ Ex.table @Qualification
|
|
`Ex.leftJoin` Ex.table @QualificationUser
|
|
`Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid
|
|
E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
|
|
)
|
|
`Ex.leftJoin` Ex.table @LmsUser
|
|
`Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid
|
|
E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
|
|
)
|
|
Ex.where_ $ E.and $
|
|
(E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
|
|
[ (qual E.^. QualificationSchool E.==.) . E.val <$> msid
|
|
, (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh
|
|
]
|
|
Ex.orderBy [Ex.asc $ qual E.^. QualificationShorthand]
|
|
pure (qual, qualUsr, lmsUsr, validQualification' now qualUsr)
|
|
bs :: Map.Map QualificationUserId [(Entity QualificationUserBlock, Ex.Value (Maybe UserDisplayName))]
|
|
<- foldMapM (\(_, mbqu, _, _) -> case mbqu of
|
|
Nothing -> pure mempty
|
|
Just (Entity quid _) -> do
|
|
blocks <- Ex.select $ do
|
|
(qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
|
|
`Ex.leftJoin` Ex.table @User
|
|
`Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
|
|
Ex.where_ $ qBlock Ex.^. QualificationUserBlockQualificationUser Ex.==. Ex.val quid
|
|
Ex.orderBy [Ex.desc (qBlock Ex.^. QualificationUserBlockFrom)]
|
|
pure (qBlock, qbUsr Ex.?. UserDisplayName)
|
|
return $ Map.singleton quid blocks
|
|
) qs
|
|
return (usr, qs, Map.filter notNull bs)
|
|
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
|
|
siteLayout heading $ do
|
|
setTitle $ toHtml userDisplayName
|
|
$(widgetFile "lms-user")
|