330 lines
18 KiB
Haskell
330 lines
18 KiB
Haskell
-- SPDX-FileCopyrightText: 2023-25 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- 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")
|