-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel ,Steffen Jost -- -- 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 -- V2 , getLmsLearnersR , getLmsLearnersDirectR , getLmsReportR , postLmsReportR , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR , getLmsOrphansR -- -- , 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 (updateWhereCount) -- deleteWhereCount -- 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 } lmsTable <- runDB $ do view _2 <$> mkLmsAllTable isAdmin siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms $(i18nWidgetFile "lms-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, 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 resultAllQualificationOrphans :: Lens' AllQualificationTableData Word64 resultAllQualificationOrphans = _dbrOutput . _4 . _unValue mkLmsAllTable :: Bool -> DB (Any, Widget) mkLmsAllTable isAdmin = do svs <- getSupervisees True 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 Ex.^. LmsUserStatus) corphans = Ex.subSelectCount $ do lorphan <- Ex.from $ Ex.table @LmsOrphan Ex.where_ $ lorphan Ex.^. LmsOrphanQualification Ex.==. quali Ex.^. QualificationId -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem return (quali, cactive, cusers, corphans) 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, SomeMessage MsgTableDiffDaysTooltip]) $ (textCell . formatCalendarDiffDays . fromDays ) . view (resultAllQualification . _qualificationAuditDuration) , sortable (Just "qel-renew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew) $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews) , sortable (Just "qel-limit") (i18nCell MsgTableLmsElearningLimit & cellTooltip MsgQualificationElearningLimitExplain) $ 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 , adminable Nothing (i18nCell MsgLmsOrphans) $ wgtCell . word2widget . view resultAllQualificationOrphans ] 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 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)) ) -- due to GHC staging restrictions, we use the preprocessor instead #define LMS_TABLE_JOIN "IIL" queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser = $(sqlMIXproj LMS_TABLE_JOIN 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlMIXproj LMS_TABLE_JOIN 2) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) queryLmsUser = $(sqlMIXproj LMS_TABLE_JOIN 3) queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualBlock = $(sqlMIXproj LMS_TABLE_JOIN 4) 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 | LmsActReset | LmsActRestart | LmsActTerminate deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActTerminateData | 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 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 -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps now <- liftIO getCurrentTime let nowaday = utctDay now 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 -- ) , ("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 ) , ("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 MsgCompanyPersonalNumberFraport) , 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' (fslI MsgFilterLmsValid) , prismAForm (singletonFilter "long-valid" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsLongValid) , prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt boolField' (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 msgTerminateInfo <- messageIconI Info IconNotificationNonactive MsgLmsActTerminateInfo ((lmsRes, lmsTable), Entity qid quali, lmsQualiReused) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationLmsReuses = reuseQuali, qualificationElearningStart = elearnStart, qualificationRefreshWithin = refreshWithin}} <- 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 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 , singletonMap LmsActTerminate $ bool pure (<$ aformMessage msgTerminateInfo) (elearnStart && isJust refreshWithin) LmsActTerminateData ] 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|

_{MsgPrintJobAcknowledgements} ^{userWidget recipient}