193 lines
8.6 KiB
Haskell
193 lines
8.6 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 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.Users
|
|
( getLmsUsersR
|
|
, getLmsUsersDirectR
|
|
)
|
|
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 :: LmsBool
|
|
}
|
|
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 = lmsUserResetPin & LmsBool
|
|
, csvLUTdelete = lmsUserToDelete cutoff lu & LmsBool
|
|
, csvLUTstaff = False & LmsBool
|
|
}
|
|
|
|
-- 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 ]
|
|
|
|
instance ToNamedRecord LmsUserTableCsv where
|
|
toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
|
|
[ csvLmsIdent Csv..= csvLUTident
|
|
, csvLmsPin Csv..= csvLUTpin
|
|
, csvLmsResetPin Csv..= csvLUTresetPin
|
|
, csvLmsDelete Csv..= csvLUTdelete
|
|
, csvLmsStaff Csv..= csvLUTstaff
|
|
]
|
|
instance FromNamedRecord LmsUserTableCsv where
|
|
parseNamedRecord (lsfHeaderTranslate -> csv)
|
|
= LmsUserTableCsv
|
|
<$> csv Csv..: csvLmsIdent
|
|
<*> csv Csv..: csvLmsPin
|
|
<*> csv Csv..: csvLmsResetPin
|
|
<*> csv Csv..: csvLmsDelete
|
|
<*> csv Csv..: csvLmsStaff
|
|
|
|
instance CsvColumnsExplained LmsUserTableCsv where
|
|
csvColumnsExplanations _ = Map.fromList
|
|
[ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
|
|
, (csvLmsPin , msg2widget MsgCsvColumnLmsPin)
|
|
, (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
|
|
, (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete)
|
|
, (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff)
|
|
]
|
|
|
|
|
|
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
|
mkUserTable _sid qsh qid = do
|
|
cutoff <- liftHandler $ lmsDeletionDate Nothing
|
|
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) $ const mempty
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ (csvLmsIdent , SortColumn (E.^. LmsUserIdent))
|
|
, (csvLmsPin , SortColumn (E.^. LmsUserPin))
|
|
, (csvLmsResetPin , SortColumn (E.^. LmsUserResetPin))
|
|
, (csvLmsDelete , SortColumn (lmsUserToDeleteExpr cutoff))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
|
|
, (csvLmsResetPin , FilterColumn $ E.mkExactFilterLast (E.^. LmsUserResetPin))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
|
, 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)
|
|
<*> const (LmsBool False)
|
|
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
userDBTableValidator = def
|
|
& defaultSorting [SortAscBy csvLmsIdent]
|
|
dbTable userDBTableValidator userDBTable
|
|
|
|
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsUsersR sid qsh = do
|
|
lmsTable <- runDB $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
view _2 <$> mkUserTable sid qsh qid
|
|
siteLayoutMsg MsgMenuLmsUsers $ do
|
|
setTitleI MsgMenuLmsUsers
|
|
lmsTable
|
|
|
|
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
|
getLmsUsersDirectR sid qsh = do
|
|
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
|
cutoff <- lmsDeletionDate Nothing
|
|
lms_users <- runDB $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
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]
|
|
|
|
{- 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 Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
|
$logInfoS "LMS" msg
|
|
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
|
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
|
|
|
|
-- direct Download see:
|
|
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod |