-- SPDX-FileCopyrightText: 2022 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.Qualification ( getQualificationAllR , getQualificationSchoolR , getQualificationR ) where import Import -- import Jobs import Handler.Utils -- import Handler.Utils.Csv -- 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 qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below? -- avoids repetition of local definitions single :: (k,a) -> Map k a single = uncurry Map.singleton getQualificationSchoolR :: SchoolId -> Handler Html getQualificationSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)]) --TODO: revert URL getQualificationAllR :: Handler Html getQualificationAllR = do -- TODO just a stub qualiTable <- runDB $ do view _2 <$> mkQualificationAllTable siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "qualification-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification resultAllQualification = _dbrOutput . _1 . _entityVal resultAllQualificationActive :: Lens' AllQualificationTableData Word64 resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue getSupervisees :: DB (Set UserId) getSupervisees = do uid <- requireAuthId svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] return $ Set.insert uid $ Set.fromAscList svs mkQualificationAllTable :: DB (Any, Widget) mkQualificationAllTable = do svs <- getSupervisees now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where dbtSQLQuery quali = do let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.&&. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs cusers = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? 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 --TODO: revert URL , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali qnm = qualificationName quali in anchorCell (LmsR (qualificationSchool quali) qsh) $ toWgt qnm --TODO: revert URL , 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) -> tickmarkCell $ isJust mbSapId , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal ] dbtSorting = mconcat [ sortSchool $ to (E.^. QualificationSchool) , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) , singletonMap "qname" $ SortColumn (E.^. QualificationName) , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) ] 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 = "qualification-overview" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] resultDBTableValidator = def & defaultSorting [SortAscBy "school", SortAscBy "qshort"] dbTable resultDBTableValidator resultDBTable -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html -- getQualificationEditR = postQualificationEditR -- postQualificationEditR = error "TODO" getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR postQualificationR = error "TODO: STUB" -- data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. -- { ltcDisplayName :: UserDisplayName -- , ltcEmail :: UserEmail -- , ltcValidUntil :: Day -- , ltcLastRefresh :: Day -- , ltcFirstHeld :: Day -- , ltcBlockedDue :: Maybe QualificationBlocked -- , ltcLmsIdent :: Maybe LmsIdent -- , ltcLmsStatus :: Maybe LmsStatus -- , ltcLmsStarted :: Maybe UTCTime -- , ltcLmsDatePin :: Maybe UTCTime -- , ltcLmsReceived :: Maybe UTCTime -- , ltcLmsNotified :: Maybe UTCTime -- , ltcLmsEnded :: Maybe UTCTime -- } -- deriving Generic -- makeLenses_ ''LmsTableCsv -- ltcExample :: LmsTableCsv -- ltcExample = LmsTableCsv -- { ltcDisplayName = "Max Mustermann" -- , ltcEmail = "m.mustermann@does.not.exist" -- , ltcValidUntil = compDay -- , ltcLastRefresh = compDay -- , ltcFirstHeld = compDay -- , ltcBlockedDue = Nothing -- , ltcLmsIdent = Nothing -- , ltcLmsStatus = Nothing -- , ltcLmsStarted = Just compTime -- , ltcLmsDatePin = Nothing -- , 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, MsgLmsUser) -- , ('ltcEmail , MsgTableLmsEmail) -- , ('ltcValidUntil , MsgLmsQualificationValidUntil) -- , ('ltcLastRefresh, MsgTableQualificationLastRefresh) -- , ('ltcFirstHeld , MsgTableQualificationFirstHeld) -- , ('ltcLmsIdent , MsgTableLmsIdent) -- , ('ltcLmsStatus , MsgTableLmsStatus) -- , ('ltcLmsStarted , MsgTableLmsStarted) -- , ('ltcLmsDatePin , MsgTableLmsDatePin) -- , ('ltcLmsReceived, MsgTableLmsReceived) -- , ('ltcLmsEnded , MsgTableLmsEnded) -- ] -- type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) -- `E.InnerJoin` E.SqlExpr (Entity User) -- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) -- queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) -- queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) -- queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -- queryLmsUser = $(sqlLOJproj 2 2) -- type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) -- resultQualUser :: Lens' LmsTableData (Entity QualificationUser) -- resultQualUser = _dbrOutput . _1 -- resultUser :: Lens' LmsTableData (Entity User) -- resultUser = _dbrOutput . _2 -- resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) -- resultLmsUser = _dbrOutput . _3 . _Just -- resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] -- resultPrintAck = _dbrOutput . _4 . _unValue . _Just -- instance HasEntity LmsTableData User where -- hasEntity = resultUser -- instance HasUser LmsTableData where -- hasUser = resultUser . _entityVal -- data LmsTableAction = LmsActNotify -- | LmsActRenewNotify -- | LmsActRenewPin -- 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 -- deriving (Eq, Ord, Read, Show, Generic) -- isNotifyAct :: LmsTableActionData -> Bool -- isNotifyAct LmsActNotifyData = True -- isNotifyAct LmsActRenewNotifyData = True -- isNotifyAct LmsActRenewPinData = False -- isRenewPinAct :: LmsTableActionData -> Bool -- isRenewPinAct LmsActNotifyData = False -- isRenewPinAct LmsActRenewNotifyData = True -- isRenewPinAct LmsActRenewPinData = True -- lmsTableQuery :: QualificationId -> LmsTableExpr -> Int64 -> Int64 -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -- , E.SqlExpr (Entity User) -- , E.SqlExpr (Maybe (Entity LmsUser)) -- , 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.LeftOuterJoin` lmsUser) nlimit noffset = 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 noExsists on printJob join condition works, but only deliver single value; -- -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest -- 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 -- when (nlimit > 0) $ E.limit nlimit >> E.offset (nlimit * noffset) -- FIXME Pagination does not work here somehow -- -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- -- 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, printAcknowledged) -- newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } -- instance Default LmsTableFilterProj where -- def = LmsTableFilterProj -- { ltProjFilterMayAccess = Nothing } -- makeLenses_ ''LmsTableFilterProj -- mkLmsTable :: forall h p cols act act'. -- ( Functor h, ToSortable h -- , Ord act, PathPiece act, RenderMessage UniWorX act -- , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols -- ) -- => Int64 -> Int64 -- -> Bool -- -> Entity Qualification -- -> Map act (AForm Handler act') -- -> cols -- -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -- -> DB (FormResult (act', Set UserId), Widget) -- mkLmsTable nlimit noffset isAdmin (Entity qid quali) acts cols psValidator = do -- now <- liftIO getCurrentTime -- -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here -- let -- currentRoute = QualificationR (qualificationSchool quali) (qualificationShorthand quali) -- nowaday = utctDay now -- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday -- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) -- dbtIdent :: Text -- dbtIdent = "qualification" -- dbtSQLQuery q = lmsTableQuery qid q nlimit noffset -- dbtRowKey = queryUser >>> (E.^. UserId) -- --dbtProj = dbtProjFilteredPostId -- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- qusr <- view $ _dbtProjRow . resultQualUser -- user <- view $ _dbtProjRow . resultUser -- lusr <- preview $ _dbtProjRow . resultLmsUser -- pjac <- preview $ _dbtProjRow . resultPrintAck -- forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do -- euid <- encrypt $ user ^. _entityKey -- guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins! -- return (qusr,user,lusr,E.Value pjac) -- dbtColonnade = cols -- dbtSorting = mconcat -- [ single $ sortUserNameLink queryUser -- , single $ sortUserEmail queryUser -- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) -- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) -- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) -- , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) -- , single ("schedule-renew", SortColumn $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) -- , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) -- , single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin)) -- , single ("lms-received" , SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived)) -- , single ("lms-notified" , SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date -- , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) -- ] -- dbtFilter = mconcat -- [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) -- , single $ fltrUserNameEmail queryUser -- , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) -- -- , single ("lms-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 nowaday)) -- , 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 ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) -- ] -- dbtFilterUI mPrev = mconcat -- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev -- , prismAForm (singletonFilter "lms-ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) -- -- , prismAForm (singletonFilter "lms-status" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus) -- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) -- , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified) -- , 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 . _userEmail) -- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) -- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) -- <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) -- <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) -- <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) -- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) -- <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) -- <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) -- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) -- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge -- <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) -- dbtCsvDecode = Nothing -- dbtExtraReps = [] -- dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else -- DBParamsForm -- { dbParamsFormMethod = POST -- , dbParamsFormAction = 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{..} -- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html -- getQualificationR = postQualificationR -- postQualificationR sid qsh = do -- let nlimit = 5000 -- TODO: remove me -- noffset = 0 -- isAdmin <- hasReadAccessTo AdminR -- currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler -- ((lmsRes, qualificationTable), 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 -- ] -- colChoices = mconcat -- [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" -- , colUserNameLinkHdr MsgLmsUser AdminUserR -- , colUserEmail -- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d -- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d -- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d -- , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip -- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b -- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip -- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification -- , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid -- , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status -- , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d -- --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d -- , sortable (Just "lms-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 = join $ 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 :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) -- cAckDates = case letterDates of -- Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| --

-- _{MsgPrintJobAcknowledgements} ^{userWidget recipient} --