Steffen Jost
fb20defc42
Since each interface log also triggers an AuditLog entry, the additional data about user and instance do not need to be saved twice
218 lines
10 KiB
Haskell
218 lines
10 KiB
Haskell
-- SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
|
|
|
module Handler.LMS.Learners
|
|
( getLmsLearnersR
|
|
, getLmsLearnersDirectR
|
|
)
|
|
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.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
|
|
|
|
-- | 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 _ = mconcat
|
|
[ single csvLmsIdent MsgCsvColumnLmsIdent
|
|
, single csvLmsPin MsgCsvColumnLmsPin
|
|
, single csvLmsResetPin MsgCsvColumnLmsResetPin
|
|
, single csvLmsDelete MsgCsvColumnLmsDelete
|
|
, single csvLmsStaff MsgCsvColumnLmsStaff
|
|
, single csvLmsResetTries MsgCsvColumnLmsResetTries
|
|
, single csvLmsLock MsgCsvColumnLmsLock
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
|
|
|
|
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
|
|
cutoff <- liftHandler $ lmsDeletionDate auditDur
|
|
return (qid, cutoff)
|
|
|
|
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsLearnersR sid qsh = do
|
|
lmsTable <- runDB $ do
|
|
(qid, cutoff) <- getQidCutoff sid qsh
|
|
view _2 <$> mkUserTable sid qsh qid cutoff
|
|
siteLayoutMsg MsgMenuLmsLearners $ do
|
|
setTitleI MsgMenuLmsLearners
|
|
lmsTable
|
|
|
|
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
|
getLmsLearnersDirectR sid qsh = do
|
|
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
|
(lms_users,cutoff) <- runDB $ do
|
|
(qid, cutoff) <- getQidCutoff sid qsh
|
|
lms_users <- selectList [ LmsUserQualification ==. qid
|
|
, LmsUserEnded ==. Nothing
|
|
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
|
|
] [Asc LmsUserStarted, Asc LmsUserIdent]
|
|
return (lms_users, cutoff)
|
|
|
|
{- 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
|
|
}
|
|
-}
|
|
LmsConf{..} <- getsYesod $ view _appLmsConf
|
|
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
|
|
--csvRenderedHeader = lmsUserTableCsvHeader
|
|
--cvsRendered = CsvRendered {..}
|
|
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv cutoff . entityVal <$> lms_users
|
|
fmtOpts = (review csvPreset CsvPresetRFC)
|
|
{ csvIncludeHeader = lmsDownloadHeader
|
|
, csvDelimiter = lmsDownloadDelimiter
|
|
, csvUseCrLf = lmsDownloadCrLf
|
|
}
|
|
csvOpts = def { csvFormat = fmtOpts }
|
|
csvSheetName <- csvFilenameLmsUser qsh
|
|
let nr = length lms_users
|
|
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
|
$logInfoS "LMS" msg
|
|
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
|
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
|
|
<* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "")
|
|
-- direct Download see:
|
|
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod |