-- SPDX-FileCopyrightText: 2023-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances module Handler.LMS.Learners ( getLmsLearnersR , getLmsLearnersDirectR , getLmsOrphansR ) where import Import import Handler.Utils import Handler.Utils.Csv import Handler.Utils.LMS import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as Text 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.Utils as E data LmsUserTableCsv = LmsUserTableCsv -- for csv export only { csvLUTident :: LmsIdent , csvLUTpin :: Text , csvLUTresetPin, csvLUTdelete, csvLUTstaff -- V1 , csvLUTresetTries, csvLUTlock :: LmsBool -- V2 } deriving Generic makeLenses_ ''LmsUserTableCsv lmsUserDelete2csv :: LmsIdent -> LmsUserTableCsv lmsUserDelete2csv lid = LmsUserTableCsv { csvLUTident = lid , csvLUTpin = "00000000" , csvLUTresetPin = LmsBool False , csvLUTdelete = LmsBool True , csvLUTstaff = LmsBool False , csvLUTresetTries= LmsBool False , csvLUTlock = LmsBool True } -- | Mundane conversion needed for direct download without dbTable only lmsUser2csv :: UTCTime -> LmsUser -> LmsUserTableCsv lmsUser2csv cutoff lu@LmsUser{..} = LmsUserTableCsv { csvLUTident = lmsUserIdent , csvLUTpin = lmsUserPin , csvLUTresetPin = LmsBool lmsUserResetPin , csvLUTdelete = LmsBool (lmsUserToDelete cutoff lu) , csvLUTstaff = LmsBool (lmsUserStaff lu) , csvLUTresetTries= LmsBool (lmsUserToResetTries lu) -- TODO: verify this works as intended! , csvLUTlock = LmsBool (lmsUserToLock lu) } -- csv without headers instance Csv.ToRecord LmsUserTableCsv instance Csv.FromRecord LmsUserTableCsv -- csv with headers lmsUserTableCsvHeader :: Csv.Header lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff, csvLmsResetTries, csvLmsLock ] instance ToNamedRecord LmsUserTableCsv where toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord [ csvLmsIdent Csv..= csvLUTident , csvLmsPin Csv..= csvLUTpin , csvLmsResetPin Csv..= csvLUTresetPin , csvLmsDelete Csv..= csvLUTdelete , csvLmsStaff Csv..= csvLUTstaff , csvLmsResetTries Csv..= csvLUTresetTries , csvLmsLock Csv..= csvLUTlock ] instance FromNamedRecord LmsUserTableCsv where parseNamedRecord (lsfHeaderTranslate -> csv) = LmsUserTableCsv <$> csv Csv..: csvLmsIdent <*> csv Csv..: csvLmsPin <*> csv Csv..: csvLmsResetPin <*> csv Csv..: csvLmsDelete <*> csv Csv..: csvLmsStaff <*> csv Csv..: csvLmsResetTries <*> csv Csv..: csvLmsLock instance CsvColumnsExplained LmsUserTableCsv where csvColumnsExplanations _ = Map.fromList [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) , (csvLmsPin , msg2widget MsgCsvColumnLmsPin) , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin) , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete) , (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff) , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries) , (csvLmsLock , msg2widget MsgCsvColumnLmsLock) ] mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget) mkUserTable _sid qsh qid cutoff = do dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let userDBTable = DBTable{..} where dbtSQLQuery lmsuser = do E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) return lmsuser dbtRowKey = (E.^. LmsUserId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete cutoff -> del ) -> ifIconCell del IconRemoveUser , sortable Nothing (i18nCell MsgTableLmsStaff) $ \(view $ _dbrOutput . _entityVal . _lmsUserStaff -> staff) -> ifIconCell staff IconOK , sortable (Just csvLmsResetTries)(i18nCell MsgTableLmsResetTries) $ \(view $ _dbrOutput . _entityVal . _lmsUserToResetTries -> reset) -> ifIconCell reset IconResetTries , sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsUserToLock -> lock ) -> ifIconCell lock IconLocked ] dbtSorting = Map.fromList [ (csvLmsIdent , SortColumn (E.^. LmsUserIdent)) , (csvLmsPin , SortColumn (E.^. LmsUserPin)) , (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin)) , (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff)) -- , (csvLmsStaff , E.false) -- currently always false , (csvLmsResetTries , SortColumn lmsUserToResetTriesExpr) , (csvLmsLock , SortColumn lmsUserToLockExpr) ] dbtFilter = Map.fromList [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsUserIdent )) , (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin)) ] dbtFilterUI = \mPrev -> mconcat [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgTableLmsResetPin) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-user" dbtCsvEncode = Just DBTCsvEncode {..} where dbtCsvExportForm = pure () dbtCsvNoExportData = Just id dbtCsvExampleData = Nothing dbtCsvHeader = const $ return lmsUserTableCsvHeader dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) doEncode' = LmsUserTableCsv <$> view (_dbrOutput . _entityVal . _lmsUserIdent) <*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete cutoff . _lmsBool) <*> view (_dbrOutput . _entityVal . to lmsUserStaff . _lmsBool) <*> view (_dbrOutput . _entityVal . to lmsUserToResetTries . _lmsBool) <*> view (_dbrOutput . _entityVal . to lmsUserToLock . _lmsBool) dbtCsvDecode = Nothing dbtExtraReps = [] userDBTableValidator = def & defaultSorting [SortAscBy csvLmsIdent] dbTable userDBTableValidator userDBTable getQidCutoff :: SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime) getQidCutoff sid qsh = do Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh now <- liftIO getCurrentTime let cutoff = lmsDeletionDate now auditDur return (qid, cutoff) getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsLearnersR sid qsh = do (lmsTable, nr_orphans) <- runDB $ do (qid, cutoff) <- getQidCutoff sid qsh lmsTable <- view _2 <$> mkUserTable sid qsh qid cutoff nr_orphans <- count [LmsOrphanQualification ==. qid] return (lmsTable, nr_orphans) when (nr_orphans > 0) $ addMessageI Warning $ MsgLmsOrphanNr nr_orphans siteLayoutMsg MsgMenuLmsLearners $ do setTitleI MsgMenuLmsLearners lmsTable selectOrphans :: QualificationId -> UTCTime -> DB [(LmsOrphanId, LmsIdent)] selectOrphans qid now = do lmsConf <- getsYesod $ view _appLmsConf 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 $(E.unValueN 2) <<$>> ( 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 E.^. LmsOrphanId, orv E.^. LmsOrphanIdent) ) 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] [] let qids = qid : (entityKey <$> qidsReuse) qshs = qsh : (qualificationShorthand . entityVal <$> qidsReuse) lms_users <- selectList [ LmsUserQualification <-. qids , LmsUserEnded ==. Nothing -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta ] [Asc LmsUserStarted, Asc LmsUserIdent] {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it Ex.select $ do lmsuser <- Ex.from $ Ex.table @LmsUser Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) pure $ LmsUserTableCsv { csvLUTident = lmsuser Ex.^. LmsUserIdent , csvLUTpin = lmsuser Ex.^. LmsUserPin , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus) , csvLUTstaff = LmsBool False } -} now <- liftIO getCurrentTime orphans <- selectOrphans qid now updateWhere [LmsOrphanId <-. map fst orphans] [LmsOrphanDeletedLast =. Just now] return (lms_users, orphans, cutoff, qshs) LmsConf{..} <- getsYesod $ view _appLmsConf let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} csvRendered = toCsvRendered lmsUserTableCsvHeader $ (lmsUser2csv cutoff . entityVal <$> lms_users) <> (lmsUserDelete2csv . snd <$> orphans) fmtOpts = (review csvPreset CsvPresetRFC) { csvIncludeHeader = lmsDownloadHeader , csvDelimiter = lmsDownloadDelimiter , csvUseCrLf = lmsDownloadCrLf } csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users orv_nr = length orphans msg0 = "Success. LMS learners direct download file " <> csvSheetName <> " containing " <> tshow nr <> " rows for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs) msg1 = ". Orphaned LMS idents marked for deletion: " <> tshow orv_nr msg = if orv_nr > 0 then msg0 <> msg1 else msg1 $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "") -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod getLmsOrphansR :: SchoolId -> QualificationShorthand -> Handler Html getLmsOrphansR sid qsh = do orvTable <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh let orvDBTable = DBTable{..} where queryOrphan = id -- 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 "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 "reason") (i18nCell MsgLmsOrphanReason) $ \(view $ _dbrOutput . _entityVal . _lmsOrphanReason -> t) -> foldMap textCell t ] dbtSorting = Map.fromList [ ("ident" , SortColumn (E.^. LmsOrphanIdent)) , ("seen-first" , SortColumn (E.^. LmsOrphanSeenFirst)) , ("seen-last" , SortColumn (E.^. LmsOrphanSeenLast)) , ("deleted-last" , SortColumn (E.^. LmsOrphanDeletedLast)) , ("reason" , SortColumn (E.^. LmsOrphanReason)) ] dbtFilter = Map.fromList [ ("preview" , FilterColumnHandler $ \case (x:_) | x == tshow True -> do now <- liftIO getCurrentTime next_orphans <- runDB $ selectOrphans qid now -- only query next orphans when really needed; not sure how to formulate a proper sub-query here -- addMessageI Info $ MsgLmsOrphanNr $ length next_orphans -- debug return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.in_` E.valList (map fst next_orphans) | x == tshow False -> do now <- liftIO getCurrentTime next_orphans <- runDB $ selectOrphans qid now return $ \row -> (queryOrphan row E.^. LmsOrphanId) `E.notIn` E.valList (map fst next_orphans) _ -> return (const E.true) ) , ("ident" , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsOrphanIdent)) ] -- checkBoxTextField = convertField show (\case { t | t == show True -> True; _ -> False }) checkBoxField -- UNNECESSARY hack to use FilterColumnHandler, which only works on [Text] criteria dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "ident" . maybePrism _PathPiece) mPrev $ aopt textField (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus) -- , prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgLmsOrphanPreviewFltr) -- NOTE: anticipated checkBoxTextField-hack not needed here , prismAForm (singletonFilter "preview" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsOrphanPreviewFltr) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "lms-orphans" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] orvDBTableValidator = def & defaultSorting [SortAscBy "seen-first", SortDescBy "deleted-last"] snd <$> (dbTable orvDBTableValidator orvDBTable :: DB (Any, Widget)) LmsConf{..} <- getsYesod $ view _appLmsConf siteLayoutMsg MsgLmsOrphans $ do setTitleI MsgLmsOrphans $(i18nWidgetFile "lms-orphans")