diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index aa5915d87..ed44037e4 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -162,4 +162,6 @@ LmsOrphans: Verwaiste Logins LmsOrphanNr n@Int: #{n} verwaiste E‑Learning Logins für diese Qualifikation erkannt. LmsOrphanSeenFirst: Zuerst erkannt LmsOrphanSeenLast: Zuletzt erhalten -LmsOrphanDeletedLast: Zuletzt Löschung beantragt \ No newline at end of file +LmsOrphanDeletedLast: Zuletzt Löschung beantragt +LmsOrphanReason: Bemerkung +LmsOrphanPreviewFltr: Vorschau Löschungen bei nächstem Abruf \ No newline at end of file diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index ced6ea766..b030131b5 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -162,4 +162,6 @@ LmsOrphans: Orphaned logins LmsOrphanNr n@Int: #{n} orphaned e‑learning login detected for this qualification. LmsOrphanSeenFirst: First seen LmsOrphanSeenLast: Last seen -LmsOrphanDeletedLast: Deletion requested \ No newline at end of file +LmsOrphanDeletedLast: Deletion requested +LmsOrphanReason: Note +LmsOrphanPreviewFltr: Preview deletions next synch diff --git a/models/lms.model b/models/lms.model index 06a614e27..996094e18 100644 --- a/models/lms.model +++ b/models/lms.model @@ -172,5 +172,6 @@ LmsOrphan seenFirst UTCTime default=now() -- first time reported by LMS seenLast UTCTime default=now() -- last acknowledgement by LMS, deletion uses QualificationAuditDuration deletedLast UTCTime Maybe -- last deletion request sent to LMS + reason Text Maybe -- to mark explicit e-learning deletions, etc UniqueLmsOrphan qualification ident -- unlike other tables, LMS Idents must only be unique within qualification, allowing orphans to be handled independently deriving Generic Show \ No newline at end of file diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 1145c4d95..8f871ac5a 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -185,15 +185,36 @@ getLmsLearnersR sid qsh = do setTitleI MsgMenuLmsLearners lmsTable -getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent -getLmsLearnersDirectR sid qsh = do - -- $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid + +data OrphanParams = OrphanParams { cutoff_seen_first, cutoff_deleted_last, cutoff_seen_last :: UTCTime, orphan_max_batch :: Int64 } + deriving (Show, Generic, Binary) + +selectOrphans :: QualificationId -> UTCTime -> DB ([Entity LmsOrphan], OrphanParams) +selectOrphans qid now = do lmsConf <- getsYesod $ view _appLmsConf - now <- liftIO getCurrentTime let cutoff_seen_first = addLocalDays (negate $ lmsConf ^. _lmsOrphanDeletionDays) now cutoff_deleted_last = addHours (negate $ lmsConf ^. _lmsOrphanRepeatHours) now cutoff_seen_last = cutoff_deleted_last orphan_max_batch = lmsConf ^. _lmsOrphanDeletionBatch + orphans <- Ex.select $ do + orv <- Ex.from $ Ex.table @LmsOrphan + Ex.where_ $ Ex.val qid Ex.==. orv Ex.^. LmsOrphanQualification + Ex.&&. Ex.val cutoff_seen_first Ex.>=. orv Ex.^. LmsOrphanSeenFirst -- has been seen for while + Ex.&&. Ex.val cutoff_seen_last Ex.<=. orv Ex.^. LmsOrphanSeenLast -- was still seen recently + Ex.&&. Ex.val cutoff_deleted_last E.<~. orv Ex.^. LmsOrphanDeletedLast -- not already recently deleted + Ex.&&. Ex.notExists (do -- not currently used anywhere (LmsIdent share the namespace) + lusr <- Ex.from $ Ex.table @LmsUser + Ex.where_ $ lusr Ex.^. LmsUserIdent Ex.==. orv Ex.^.LmsOrphanIdent + ) + Ex.orderBy [Ex.desc $ orv Ex.^. LmsOrphanDeletedLast, Ex.asc $ orv Ex.^. LmsOrphanSeenLast] -- Note for PostgreSQL: DESC == DESC NULLS FIRST + Ex.limit orphan_max_batch + return orv + return (orphans, OrphanParams{..}) + + +getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent +getLmsLearnersDirectR sid qsh = do + -- $logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid (lms_users, orphans, cutoff, qshs) <- runDB $ do (qid, cutoff) <- getQidCutoff sid qsh qidsReuse <- selectList [QualificationLmsReuses ==. Just qid] [] @@ -216,19 +237,8 @@ getLmsLearnersDirectR sid qsh = do , csvLUTstaff = LmsBool False } -} - orphans <- Ex.select $ do - orv <- Ex.from $ Ex.table @LmsOrphan - Ex.where_ $ Ex.val qid Ex.==. orv Ex.^. LmsOrphanQualification - Ex.&&. Ex.val cutoff_seen_first Ex.>=. orv Ex.^. LmsOrphanSeenFirst -- has been seen for while - Ex.&&. Ex.val cutoff_seen_last Ex.<=. orv Ex.^. LmsOrphanSeenLast -- was still seen recently - Ex.&&. Ex.val cutoff_deleted_last E.<~. orv Ex.^. LmsOrphanDeletedLast -- not already recently deleted - Ex.&&. Ex.notExists (do -- not currently used anywhere (LmsIdent share the namespace) - lusr <- Ex.from $ Ex.table @LmsUser - Ex.where_ $ lusr Ex.^. LmsUserIdent Ex.==. orv Ex.^.LmsOrphanIdent - ) - Ex.orderBy [Ex.desc $ orv Ex.^. LmsOrphanDeletedLast, Ex.asc $ orv Ex.^. LmsOrphanSeenLast] -- Note for PostgreSQL: DESC == DESC NULLS FIRST - Ex.limit orphan_max_batch - return orv + now <- liftIO getCurrentTime + orphans <- fst <$> selectOrphans qid now updateWhere [LmsOrphanId <-. fmap entityKey orphans] [LmsOrphanDeletedLast =. Just now] return (lms_users, orphans, cutoff, qshs) @@ -260,29 +270,25 @@ getLmsLearnersDirectR sid qsh = do getLmsOrphansR :: SchoolId -> QualificationShorthand -> Handler Html getLmsOrphansR sid qsh = do - lmsConf <- getsYesod $ view _appLmsConf - now <- liftIO getCurrentTime - let cutoff_seen_first = addLocalDays (negate $ lmsConf ^. _lmsOrphanDeletionDays) now - cutoff_deleted_last = addHours (negate $ lmsConf ^. _lmsOrphanRepeatHours) now - cutoff_seen_last = cutoff_deleted_last - orphan_max_batch = lmsConf ^. _lmsOrphanDeletionBatch - - orvTable <- fmap snd $ runDB $ do + (orvTable,OrphanParams{..}) <-runDB $ do + now <- liftIO getCurrentTime qid <- getKeyBy404 $ SchoolQualificationShort sid qsh + (next_orphans, ops) <- $(memcachedByHere) (Just . Right $ 1 * diffMinute) [st|next-orphan-preview-#{tshow qid}|] (over _1 (map entityKey) <$> selectOrphans qid now) let orvDBTable = DBTable{..} where - -- resultOrphan = _dbrOutput . _entityVal + -- resultOrphan = _dbrOutput . _entityVal -- would need explicit type to work dbtSQLQuery orv = do E.where_ $ orv E.^. LmsOrphanQualification E.==. E.val qid return orv dbtRowKey = (E.^. LmsOrphanId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) -> textCell lid + [ sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "seen-first") (i18nCell MsgLmsOrphanSeenFirst) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenFirst -> d) -> dateTimeCell d , sortable (Just "seen-last") (i18nCell MsgLmsOrphanSeenLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanSeenLast -> d) -> dateTimeCell d , sortable (Just "deleted-last") (i18nCell MsgLmsOrphanDeletedLast) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanDeletedLast -> d) -> foldMap dateTimeCell d + , sortable (Just "note") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> foldMap textCell t ] dbtSorting = Map.fromList [ ("ident" , SortColumn (E.^. LmsOrphanIdent)) @@ -291,10 +297,15 @@ getLmsOrphansR sid qsh = do , ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast)) ] dbtFilter = Map.fromList - [ ("ident" , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent)) + [ ("preview" , FilterColumn $ \row (getLast -> criterion) -> case criterion of + Just True -> (row E.^. LmsOrphanId) `E.in_` E.valList next_orphans + _ -> E.true + ) + , ("ident" , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent)) ] dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) + [ prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def @@ -304,7 +315,8 @@ getLmsOrphansR sid qsh = do dbtCsvDecode = Nothing dbtExtraReps = [] orvDBTableValidator = def & defaultSorting [SortAscBy "seen-first", SortDescBy "deleted-last"] - dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget) + tbl <- snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget)) + return (tbl,ops) siteLayoutMsg MsgLmsOrphans $ do setTitleI MsgLmsOrphans diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index c36444cb1..b09d2acb7 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -407,6 +407,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> E.val now E.<&> E.val now E.<&> E.nothing + E.<&> E.nothing ) (\_old _new -> [ LmsOrphanSeenLast E.=. E.val now