diff --git a/routes b/routes index be87d159d..5b5e5db07 100644 --- a/routes +++ b/routes @@ -266,7 +266,7 @@ -- /qualification/#CryptoUUIDUser/ -- maybe distingquish via URL? -- SAP export -/qualifications/sap/direct QualificationSAPDirectR GET !token +/qualifications/sap/direct QualificationSAPDirectR GET -- !token -- OSIS CSV Export Demo /lms LmsAllR GET POST /lms/#SchoolId LmsSchoolR GET @@ -278,7 +278,6 @@ /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST -- development only /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -/lms/#SchoolId/#QualificationShorthand/fake LmsFakeR GET POST -- TODO: delete this testing URL /lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST /lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST -- development only /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1dd2c68e1..7c7aac815 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -187,7 +187,7 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed -breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production +-- breadcrumb (LmsFakeR ssh qsh) = i18nCrumb MsgMenuLmsFake $ Just $ LmsR ssh qsh -- TODO: remove in production breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing breadcrumb ForProfileR{} = i18nCrumb MsgBreadcrumbProfile Nothing @@ -713,11 +713,11 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the } , return NavHeader { navHeaderRole = NavHeaderPrimary - , navIcon = IconMenuQualifications + , navIcon = IconMenuQualification , navLink = NavLink { navLabel = MsgMenuQualifications - , navRoute = QualificationsAllR - , navAccess' = NavAccessTrue + , navRoute = QualificationAllR + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId , navType = NavTypeLink { navModal = False } , navQuick' = mempty , navForceActive = False @@ -2325,9 +2325,9 @@ pageActions (LmsR sid qsh) = return , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } - , NavPageActionSecondary { - navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh - } + -- , NavPageActionSecondary { + -- navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh + -- } ] pageActions (LmsLSR sid qsh pagLimit pagOffset) = return [ NavPageActionPrimary @@ -2367,9 +2367,9 @@ pageActions (LmsLSR sid qsh pagLimit pagOffset) = return , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } - , NavPageActionSecondary { - navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh - } + -- , NavPageActionSecondary { + -- navLink = defNavLink MsgMenuLmsFake $ LmsFakeR sid qsh + -- } ] pageActions ApiDocsR = return [ NavPageActionPrimary diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index d2eafeecd..8e53bdba8 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,7 +11,7 @@ module Handler.LMS , getLmsSchoolR , getLmsR , postLmsR , getLmsLSR , postLmsLSR - , getLmsEditR , postLmsEditR + -- , getLmsEditR , postLmsEditR , getLmsUsersR , getLmsUsersDirectR , getLmsUserlistR , postLmsUserlistR , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR @@ -67,7 +67,7 @@ instance Button UniWorX ButtonManualLms where getLmsSchoolR :: SchoolId -> Handler Html -getLmsSchoolR ssh = redirect (LmsAllR, [("qualification-overview-school", toPathPiece ssh)]) +getLmsSchoolR ssh = redirect (LmsAllR, [("lms-overview-school", toPathPiece ssh)]) getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR @@ -119,10 +119,10 @@ mkLmsAllTable isAdmin = do cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - E.&&. validQualification (utctDay now) quser + Ex.&&. validQualification (utctDay now) quser -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem return (quali, cactive, cusers) - dbtRowKey = (E.^. QualificationId) + dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? adminable = if isAdmin then sortable else \_ _ _ -> mempty dbtColonnade = dbColonnade $ mconcat @@ -177,7 +177,7 @@ mkLmsAllTable isAdmin = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "qualification-overview" + dbtIdent = "lms-overview" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] @@ -188,9 +188,9 @@ mkLmsAllTable isAdmin = do -getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsEditR = postLmsEditR -postLmsEditR = error "TODO" +-- getLmsEditR, postLmsEditR :: SchoolId -> QualificationShorthand -> Handler Html +-- getLmsEditR = postLmsEditR +-- postLmsEditR = error "TODO" data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 56da21e2a..d8a76807f 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -15,30 +15,39 @@ module Handler.Qualification import Import +import Jobs import Handler.Utils -- import Handler.Utils.Csv --- import Handler.Utils.LMS +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.Conduit.List as C +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 (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationAllR :: Handler Html getQualificationAllR = do -- TODO just a stub - lmsTable <- runDB $ do - view _2 <$> mkLmsAllTable + qualiTable <- runDB $ do + view _2 <$> mkQualificationAllTable siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "qualification-all") @@ -53,34 +62,41 @@ 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 -mkLmsAllTable :: DB (Any, Widget) -mkLmsAllTable = do - now <- liftIO getCurrentTime + +mkQualificationAllTable :: DB (Any, Widget) +mkQualificationAllTable = do + svs <- getSupervisees + now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where dbtSQLQuery quali = do - let cusers = Ex.subSelectCount $ 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_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId + Ex.where_ $ filterSvs quser cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId - E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now) - -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem + Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser return (quali, cactive, cusers) - dbtRowKey = (E.^. QualificationId) + 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 + anchorCell (QualificationR (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 + in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ @@ -90,10 +106,13 @@ mkLmsAllTable = do -- , 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 MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) - $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n - , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal - -- \(view resultAllQualificationTotal -> n) -> wgtCell $ word2widget n + , 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 [ @@ -126,9 +145,82 @@ mkLmsAllTable = do -getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html -getQualificationEditR = postQualificationEditR -postQualificationEditR = error "TODO" +-- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html +-- getQualificationEditR = postQualificationEditR +-- postQualificationEditR = error "TODO" + + +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) @@ -144,7 +236,8 @@ 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)) + +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -155,100 +248,317 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -instance HasEntity LmsTableData User where - hasEntity = resultUser +resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] +resultPrintAck = _dbrOutput . _4 . _unValue . _Just + +instance HasEntity LmsTableData User where + hasEntity = resultUser instance HasUser LmsTableData where hasUser = resultUser . _entityVal -mkLmsTable :: Entity Qualification -> DB (Any, Widget) -mkLmsTable (Entity qid quali) = do +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 - resultDBTable = DBTable{..} + 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 - dbtSQLQuery = runReaderT $ do - qualUser <- asks queryQualUser - user <- asks queryUser - lmsUser <- asks queryLmsUser - lift $ do - E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - 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 - E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification - return (qualUser, user, lmsUser) - dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? - dbtColonnade = dbColonnade $ mconcat - [ colUserNameLinkHdr MsgLmsUser AdminUserR - , colUserEmail - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d + 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-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} +