-- SPDX-FileCopyrightText: 2023 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 ) 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 -- | 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,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] return (lms_users, cutoff, qshs) {- 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 for Qualifications " <> Text.intercalate ", " (ciOriginal <$> qshs) $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