-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.LMS ( getLmsAllR , postLmsAllR , getLmsSchoolR , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR , getLmsResultR , postLmsResultR , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR , getLmsFakeR , postLmsFakeR , getLmsUserR , getLmsUserSchoolR , getLmsUserAllR ) where import Import import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.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) import Handler.LMS.Users as Handler.LMS import Handler.LMS.Userlist as Handler.LMS import Handler.LMS.Result as Handler.LMS import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! -- avoids repetition of local definitions single :: (k,a) -> Map k a single = uncurry Map.singleton -- 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, BCDefault] getLmsSchoolR :: SchoolId -> Handler Html getLmsSchoolR ssh = redirect (LmsAllR, [("lms-overview-school", toPathPiece ssh)]) getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR postLmsAllR = do isAdmin <- hasReadAccessTo AdminR mbQcheck <- getsYesod $ view _appQualificationCheckHour -- 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 $(widgetFile "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 -> DB (Any, Widget) mkLmsAllTable isAdmin = 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 & cellTooltip 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) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) , 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) ] 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 , ltcCompanyNumbers :: CsvSemicolonList Int , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day , ltcBlockStatus :: Maybe Bool , ltcBlockFrom :: Maybe UTCTime , ltcLmsIdent :: LmsIdent , ltcLmsStatus :: Maybe LmsStatus , ltcLmsStatusDay :: Maybe Day , 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, SecondaryJobs Inc" , ltcCompanyNumbers = CsvSemicolonList [27,69] , ltcValidUntil = succ compDay , ltcLastRefresh = compDay , ltcFirstHeld = pred $ pred compDay , ltcBlockStatus = Nothing , ltcBlockFrom = Nothing , ltcLmsIdent = LmsIdent "abcdefgh" , ltcLmsStatus = Just LmsSuccess , ltcLmsStatusDay = Just $ pred compDay , 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 MsgTableCompanies) , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('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]), [Entity UserCompany]) 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 resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] resultCompanyUser = _dbrOutput . _6 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 | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe LmsTableAction instance Finite LmsTableAction nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id -- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActRenewPinData -- no longer used | 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 lmsTableQuery :: 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 ) lmsTableQuery 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 typr of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder return (qualUser, user, lmsUser, qualBlock, printAcknowledged) 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) -> (Map CompanyId Company -> 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 $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks) -> do cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) -- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) , single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) , single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , single ("ident" , FilterColumn . E.mkContainsFilterWith LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) -- , single ("status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- | otherwise -> E.true -- ) , single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId testcrit = maybe testname testnumber $ readMay $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of Nothing -> E.false Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) ) , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) , 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 (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (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) <*> (view resultCompanyUser >>= getCompanies) <*> (view resultCompanyUser >>= getCompanyNos) <*> 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) getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of [] -> pure Nothing somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) 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 msgRestartWarning <- messageIconI Warning IconWarning MsgLmsActRestartWarning ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) acts = mconcat [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData , 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 cmpMap = mconcat [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] companies = intercalate (text2markup ", ") $ (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , colUserMatriclenr -- , 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 , 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}