chore(lms): WIP towards new interface
This commit is contained in:
parent
a06ec1b298
commit
8bcdbd95f0
@ -129,6 +129,8 @@ MenuLmsUpload: Hochladen
|
||||
MenuLmsDirectUpload: Direkter Upload
|
||||
MenuLmsDirectDownload: Direkter Download
|
||||
MenuLmsFake: Testnutzer generieren
|
||||
MenuLmsLearners: Export Benutzer E‑Learning
|
||||
MenuLmsReport: Ergebnisse E‑Learning
|
||||
|
||||
MenuSap: SAP Schnittstelle
|
||||
|
||||
|
||||
@ -129,7 +129,9 @@ MenuLmsResult: Upload E‑Learning Results
|
||||
MenuLmsUpload: Upload
|
||||
MenuLmsDirectUpload: Direct Upload
|
||||
MenuLmsDirectDownload: Direct Download
|
||||
MenuLmsFake: Generate test users
|
||||
MenuLmsFake: Generate Test Users
|
||||
MenuLmsLearners: E‑Learning Users
|
||||
MenuLmsReport: E‑Learning Results
|
||||
|
||||
MenuSap: SAP Interface
|
||||
|
||||
|
||||
@ -151,3 +151,13 @@ LmsResult
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsResult qualification ident -- required by DBTable
|
||||
deriving Generic
|
||||
|
||||
LmsReport
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
ident LmsIdent
|
||||
date Day Maybe -- BEWARE: timezone is local as submitted by LMS
|
||||
result Int -- (0|1|2) 0=too many ties, 1=open, 2=success
|
||||
lock Int -- (0|1)
|
||||
timestamp UTCTime default=now()
|
||||
UniqueLmsReport qualification ident -- required by DBTable
|
||||
deriving Generic
|
||||
8
routes
8
routes
@ -273,6 +273,7 @@
|
||||
/lms/#SchoolId LmsSchoolR GET
|
||||
/lms/#SchoolId/#QualificationShorthand LmsR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
|
||||
-- old V1 LMS Interface
|
||||
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
|
||||
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
|
||||
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
||||
@ -281,6 +282,13 @@
|
||||
/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development
|
||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS
|
||||
-- new V2 LMS Interface
|
||||
/lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET
|
||||
/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS
|
||||
/lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST
|
||||
/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development
|
||||
/lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS
|
||||
-- other lms routes
|
||||
/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
|
||||
/lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET
|
||||
/lmsuser/#CryptoUUIDUser LmsUserAllR GET
|
||||
|
||||
@ -186,6 +186,13 @@ breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Jus
|
||||
breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh
|
||||
breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh
|
||||
breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed
|
||||
-- v2
|
||||
breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh
|
||||
breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent
|
||||
breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh
|
||||
breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh
|
||||
breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed
|
||||
--
|
||||
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
|
||||
breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh
|
||||
breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u
|
||||
|
||||
@ -12,11 +12,17 @@ module Handler.LMS
|
||||
, getLmsR , postLmsR
|
||||
, getLmsIdentR
|
||||
, getLmsEditR , postLmsEditR
|
||||
-- V1
|
||||
, getLmsUsersR , getLmsUsersDirectR
|
||||
, getLmsUserlistR , postLmsUserlistR
|
||||
, getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR
|
||||
, getLmsResultR , postLmsResultR
|
||||
, getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR
|
||||
-- V1
|
||||
, getLmsLearnersR , getLmsLearnersDirectR
|
||||
, getLmsReportR , postLmsReportR
|
||||
, getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR
|
||||
--
|
||||
, getLmsFakeR , postLmsFakeR
|
||||
, getLmsUserR
|
||||
, getLmsUserSchoolR
|
||||
@ -45,10 +51,13 @@ import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
-- V1
|
||||
import Handler.LMS.Users as Handler.LMS
|
||||
import Handler.LMS.Userlist as Handler.LMS
|
||||
import Handler.LMS.Result as Handler.LMS
|
||||
-- V2
|
||||
import Handler.LMS.Learners as Handler.LMS
|
||||
import Handler.LMS.Report as Handler.LMS
|
||||
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
|
||||
|
||||
|
||||
|
||||
197
src/Handler/LMS/Learners.hs
Normal file
197
src/Handler/LMS/Learners.hs
Normal file
@ -0,0 +1,197 @@
|
||||
-- SPDX-FileCopyrightText: 2022 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 :: LmsBool
|
||||
}
|
||||
deriving Generic
|
||||
makeLenses_ ''LmsUserTableCsv
|
||||
|
||||
-- | Mundane conversion needed for direct download without dbTable onlu
|
||||
lmsUser2csv :: Day -> 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 _ = mconcat
|
||||
[ single csvLmsIdent MsgCsvColumnLmsIdent
|
||||
, single csvLmsPin MsgCsvColumnLmsPin
|
||||
, single csvLmsResetPin MsgCsvColumnLmsResetPin
|
||||
, single csvLmsDelete MsgCsvColumnLmsDelete
|
||||
, single csvLmsStaff MsgCsvColumnLmsStaff
|
||||
]
|
||||
where
|
||||
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
||||
single k v = singletonMap k [whamlet|_{v}|]
|
||||
|
||||
|
||||
|
||||
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkUserTable _sid qsh qid = do
|
||||
cutoff <- liftHandler lmsDeletionDate
|
||||
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
|
||||
|
||||
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsLearnersR sid qsh = do
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
view _2 <$> mkUserTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsUsers $ do
|
||||
setTitleI MsgMenuLmsUsers
|
||||
lmsTable
|
||||
|
||||
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
||||
getLmsLearnersDirectR sid qsh = do
|
||||
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
||||
cutoff <- lmsDeletionDate
|
||||
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
|
||||
301
src/Handler/LMS/Report.hs
Normal file
301
src/Handler/LMS/Report.hs
Normal file
@ -0,0 +1,301 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,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.Report
|
||||
( getLmsReportR, postLmsReportR
|
||||
, getLmsReportUploadR, postLmsReportUploadR
|
||||
, postLmsReportDirectR
|
||||
)
|
||||
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.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
data LmsReportTableCsv = LmsReportTableCsv
|
||||
{ csvLRident :: LmsIdent
|
||||
, csvLRdate :: Maybe LmsDay
|
||||
, csvLRresult :: Int
|
||||
, csvLRlock :: Int
|
||||
}
|
||||
deriving Generic
|
||||
makeLenses_ ''LmsReportTableCsv
|
||||
|
||||
-- csv without headers
|
||||
instance Csv.ToRecord LmsReportTableCsv -- default suffices
|
||||
instance Csv.FromRecord LmsReportTableCsv -- default suffices
|
||||
|
||||
-- csv with headers
|
||||
lmsReportTableCsvHeader :: Csv.Header
|
||||
lmsReportTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsDate, csvLmsResult, csvLmsLock ]
|
||||
|
||||
instance ToNamedRecord LmsReportTableCsv where
|
||||
toNamedRecord LmsReportTableCsv{..} = Csv.namedRecord
|
||||
[ csvLmsIdent Csv..= csvLRident
|
||||
, csvLmsDate Csv..= csvLRdate
|
||||
, csvLmsResult Csv..= csvLRresult
|
||||
, csvLmsLock Csv..= csvLRlock
|
||||
]
|
||||
|
||||
instance FromNamedRecord LmsReportTableCsv where
|
||||
parseNamedRecord (lsfHeaderTranslate -> csv)
|
||||
= LmsReportTableCsv
|
||||
<$> csv Csv..: csvLmsIdent
|
||||
<*> csv Csv..: csvLmsDate
|
||||
<*> csv Csv..: csvLmsResult
|
||||
<*> csv Csv..: csvLmsLock
|
||||
|
||||
instance CsvColumnsExplained LmsReportTableCsv where
|
||||
csvColumnsExplanations _ = mconcat
|
||||
[ single csvLmsIdent MsgCsvColumnLmsIdent
|
||||
, single csvLmsDate MsgCsvColumnLmsDate
|
||||
, single csvLmsResult MsgCsvColumnLmsResult
|
||||
, single csvLmsLock MsgCsvColumnLmsLock
|
||||
]
|
||||
where
|
||||
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
||||
single k v = singletonMap k [whamlet|_{v}|]
|
||||
|
||||
data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
|
||||
deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
|
||||
embedRenderMessage ''UniWorX ''LmsReportCsvActionClass id
|
||||
|
||||
-- By coincidence the action type is identical to LmsReportTableCsv
|
||||
data LmsReportCsvAction = LmsReportInsertData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int }
|
||||
| LmsReportUpdateData { lmsReportInsertIdent :: LmsIdent, lmsReportInsertDate :: Maybe Day, lmsReportInsertResult :: Int, lmsReportInsertLock :: Int }
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsReportInsertData -> insert
|
||||
, fieldLabelModifier = camelToPathPiece' 2 -- lmsReportInsertIdent -> insert-ident | lmsReportInsertSuccess -> insert-success
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''LmsReportCsvAction
|
||||
|
||||
data LmsReportCsvException
|
||||
= LmsReportCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Exception LmsReportCsvException
|
||||
embedRenderMessage ''UniWorX ''LmsReportCsvException id
|
||||
|
||||
mkReportTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkReportTable sid qsh qid = do
|
||||
now_day <- utctDay <$> liftIO getCurrentTime
|
||||
dbtCsvName <- csvFilenameLmsReport qsh
|
||||
let dbtCsvSheetName = dbtCsvName
|
||||
let
|
||||
reportDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery lmsReport = do
|
||||
E.where_ $ lmsReport E.^. LmsReportQualification E.==. E.val qid
|
||||
return lmsReport
|
||||
dbtRowKey = (E.^. LmsReportId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsReportIdent . _getLmsIdent -> ident) -> textCell ident
|
||||
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsReportSuccess -> success) -> dayCell success
|
||||
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> timestamp) -> dateTimeCell timestamp
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ (csvLmsIdent , SortColumn (E.^. LmsReportIdent))
|
||||
, (csvLmsSuccess , SortColumn (E.^. LmsReportSuccess))
|
||||
, (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp))
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsReportIdent))
|
||||
, (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsReportSuccess))
|
||||
]
|
||||
dbtFilterUI = \mPrev -> mconcat
|
||||
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
||||
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms-Report"
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
{ dbtCsvExportForm = pure ()
|
||||
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
||||
, dbtCsvName
|
||||
, dbtCsvSheetName
|
||||
, dbtCsvNoExportData = Just id
|
||||
, dbtCsvHeader = const $ return lmsReportTableCsvHeader
|
||||
, dbtCsvExampleData = Just
|
||||
[ LmsReportTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
|
||||
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
|
||||
]
|
||||
}
|
||||
where
|
||||
doEncode' = LmsReportTableCsv
|
||||
<$> view (_dbrOutput . _entityVal . _lmsReportIdent)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsReportSuccess . _lmsDay)
|
||||
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
|
||||
{ dbtCsvRowKey = \LmsReportTableCsv{..} ->
|
||||
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRTident
|
||||
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
|
||||
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
||||
yield $ LmsReportInsertData
|
||||
{ lmsReportInsertIdent = csvLRTident dbCsvNew
|
||||
, lmsReportInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
|
||||
}
|
||||
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsReport was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
|
||||
DBCsvDiffExisting{dbCsvNew = LmsReportTableCsv{..}, dbCsvOld} -> do
|
||||
let successDay = lms2day csvLRTsuccess
|
||||
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportSuccess) $
|
||||
yield $ LmsReportUpdateData
|
||||
{ lmsReportInsertIdent = csvLRTident
|
||||
, lmsReportInsertSuccess = successDay
|
||||
}
|
||||
DBCsvDiffMissing{} -> return () -- no deletion
|
||||
, dbtCsvClassifyAction = \case
|
||||
LmsReportInsertData{} -> LmsReportInsert
|
||||
LmsReportUpdateData{} -> LmsReportUpdate
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
LmsReportInsert -> DBCsvActionNew
|
||||
LmsReportUpdate -> DBCsvActionExisting
|
||||
, dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
|
||||
, dbtCsvExecuteActions = do
|
||||
C.mapM_ $ \actionData -> do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
LmsReport
|
||||
{ lmsReportQualification = qid
|
||||
, lmsReportIdent = lmsReportInsertIdent actionData
|
||||
, lmsReportSuccess = lmsReportInsertSuccess actionData
|
||||
, lmsReportTimestamp = now -- lmsReportInsertTimestamp -- does it matter which one to choose?
|
||||
}
|
||||
[ LmsReportSuccess =. lmsReportInsertSuccess actionData
|
||||
, LmsReportTimestamp =. now
|
||||
]
|
||||
-- audit $ Transaction.. (add to Audit.Types)
|
||||
lift . queueDBJob $ JobLmsReports qid
|
||||
return $ LmsReportR sid qsh
|
||||
, dbtCsvRenderKey = const $ \case
|
||||
LmsReportInsertData{..} -> do -- TODO: i18n
|
||||
[whamlet|
|
||||
$newline never
|
||||
Insert: Ident #{getLmsIdent lmsReportInsertIdent} #
|
||||
had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess}
|
||||
|]
|
||||
LmsReportUpdateData{..} -> do -- TODO: i18n
|
||||
[whamlet|
|
||||
$newline never
|
||||
Update: Ident #{getLmsIdent lmsReportInsertIdent} #
|
||||
had success on ^{formatTimeW SelFormatDate lmsReportInsertSuccess}
|
||||
|]
|
||||
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: LmsReportCsvException -> DB Text
|
||||
}
|
||||
dbtExtraReps = []
|
||||
|
||||
ReportDBTableValidator = def
|
||||
& defaultSorting [SortAscBy csvLmsIdent]
|
||||
dbTable ReportDBTableValidator ReportDBTable
|
||||
|
||||
getLmsReportR, postLmsReportR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsReportR = postLmsReportR
|
||||
postLmsReportR sid qsh = do
|
||||
let directUploadLink = LmsReportUploadR sid qsh
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
view _2 <$> mkReportTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsReport $ do
|
||||
setTitleI MsgMenuLmsReport
|
||||
$(widgetFile "lms-Report")
|
||||
|
||||
|
||||
-- Direct File Upload/Download
|
||||
|
||||
saveReportCsv :: QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
|
||||
saveReportCsv qid i LmsReportTableCsv{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
LmsReport
|
||||
{ lmsReportQualification = qid
|
||||
, lmsReportIdent = csvLRTident
|
||||
, lmsReportSuccess = csvLRTsuccess & lms2day
|
||||
, lmsReportTimestamp = now
|
||||
}
|
||||
[ LmsReportSuccess =. (csvLRTsuccess & lms2day)
|
||||
, LmsReportTimestamp =. now
|
||||
]
|
||||
return $ succ i
|
||||
|
||||
makeReportUploadForm :: Form FileInfo
|
||||
makeReportUploadForm = renderAForm FormStandard $ fileAFormReq "Report CSV"
|
||||
|
||||
getLmsReportUploadR, postLmsReportUploadR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsReportUploadR = postLmsReportUploadR
|
||||
postLmsReportUploadR sid qsh = do
|
||||
((Report,widget), enctype) <- runFormPost makeReportUploadForm
|
||||
case Report of
|
||||
FormSuccess file -> do
|
||||
-- content <- fileSourceByteString file
|
||||
-- return $ Just (fileName file, content)
|
||||
nr <- runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
nr <- runConduit $ fileSource file
|
||||
.| decodeCsv
|
||||
.| foldMC (saveReportCsv qid) 0
|
||||
queueDBJob $ JobLmsReports qid
|
||||
return nr
|
||||
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
|
||||
redirect $ LmsReportR sid qsh
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect $ LmsReportUploadR sid qsh
|
||||
FormMissing ->
|
||||
siteLayoutMsg MsgMenuLmsReport $ do
|
||||
setTitleI MsgMenuLmsUpload
|
||||
[whamlet|$newline never
|
||||
<form method=post enctype=#{enctype}>
|
||||
^{widget}
|
||||
<p>
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
|
||||
postLmsReportDirectR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
postLmsReportDirectR sid qsh = do
|
||||
(_params, files) <- runRequestBody
|
||||
(status, msg) <- case files of
|
||||
[(fhead,file)] -> do
|
||||
lmsDecoder <- getLmsCsvDecoder
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
enr <- try $ runConduit $ fileSource file
|
||||
.| lmsDecoder
|
||||
.| foldMC (saveReportCsv qid) 0
|
||||
case enr of
|
||||
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
||||
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
|
||||
return (badRequest400, "Exception: " <> tshow e)
|
||||
Right nr -> do
|
||||
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
|
||||
$logInfoS "LMS" msg
|
||||
when (nr > 0) $ queueDBJob $ JobLmsReports qid
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Report upload file missing."
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
_other -> do
|
||||
let msg = "Report upload received multiple files; all ignored."
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
sendResponseStatus status msg
|
||||
|
||||
@ -7,6 +7,7 @@
|
||||
module Handler.Utils.LMS
|
||||
( getLmsCsvDecoder
|
||||
, csvLmsIdent
|
||||
, csvLmsDate
|
||||
, csvLmsTimestamp
|
||||
, csvLmsBlocked
|
||||
, csvLmsSuccess
|
||||
@ -14,9 +15,13 @@ module Handler.Utils.LMS
|
||||
, csvLmsResetPin
|
||||
, csvLmsDelete
|
||||
, csvLmsStaff
|
||||
, csvLmsResetTries
|
||||
, csvLmsLock
|
||||
, csvLmsResult
|
||||
, csvFilenameLmsUser
|
||||
, csvFilenameLmsUserlist
|
||||
, csvFilenameLmsResult
|
||||
, csvFilenameLmsReport
|
||||
, lmsDeletionDate
|
||||
, lmsUserToDelete, _lmsUserToDelete
|
||||
, lmsUserToDeleteExpr
|
||||
@ -56,45 +61,63 @@ getLmsCsvDecoder = do
|
||||
|
||||
-- generic Column names
|
||||
csvLmsIdent :: IsString a => a
|
||||
csvLmsIdent = fromString "user" -- "Benutzerkennung"
|
||||
csvLmsIdent = fromString "user" -- "Benutzerkennung" V1, V2
|
||||
|
||||
csvLmsDate :: IsString a => a
|
||||
csvLmsDate = fromString "date" -- "Datum", V2
|
||||
|
||||
csvLmsTimestamp :: IsString a => a
|
||||
csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel"
|
||||
csvLmsTimestamp = fromString "timestamp" -- "Zeitstempel" V1
|
||||
|
||||
-- for Users Table
|
||||
csvLmsPin :: IsString a => a
|
||||
csvLmsPin = fromString "pin" -- "PIN"
|
||||
csvLmsPin = fromString "pin" -- "PIN" V1, V2
|
||||
|
||||
csvLmsResetPin :: IsString a => a
|
||||
csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen"
|
||||
csvLmsResetPin = fromString "reset_pin" -- "PIN zurücksetzen" V1, V2
|
||||
|
||||
csvLmsDelete :: IsString a => a
|
||||
csvLmsDelete = fromString "delete" -- "Account löschen"
|
||||
csvLmsDelete = fromString "delete" -- "Account löschen" V1, V2
|
||||
|
||||
csvLmsStaff :: IsString a => a
|
||||
csvLmsStaff = fromString "staff" -- "Mitarbeiter"
|
||||
csvLmsStaff = fromString "staff" -- "Mitarbeiter" V1, V2
|
||||
|
||||
-- for Userlist Table
|
||||
csvLmsResetTries :: IsString a => a
|
||||
csvLmsResetTries = fromString "reset_tries" -- Anzahl Versuche zurücksetzen, V2
|
||||
|
||||
csvLmsLock :: IsString a => a
|
||||
csvLmsLock = fromString "lock" -- Ist der Login derzeit gesperrt? V2
|
||||
|
||||
-- for Userlist Table V1
|
||||
csvLmsBlocked :: IsString a => a
|
||||
csvLmsBlocked = fromString "blocked" -- "Sperrung"
|
||||
csvLmsBlocked = fromString "blocked" -- "Sperrung" V1
|
||||
|
||||
-- for Result Table
|
||||
-- for Result Table V1
|
||||
csvLmsSuccess :: IsString a => a
|
||||
csvLmsSuccess = fromString "success" -- "Datum"
|
||||
csvLmsSuccess = fromString "success" -- "Datum" V1
|
||||
|
||||
-- for Report Table V2
|
||||
csvLmsResult :: IsString a => a
|
||||
csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offen, 2=Bestanden V2
|
||||
|
||||
|
||||
-- | Filename for User transmission, contains current datestamp as agreed in LMS interface
|
||||
|
||||
-- | Filename for User transmission, contains current datestamp as agreed in LMS interface V1 & V2
|
||||
csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text
|
||||
csvFilenameLmsUser = makeLmsFilename "user"
|
||||
|
||||
-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface
|
||||
-- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2
|
||||
csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text
|
||||
csvFilenameLmsUserlist = makeLmsFilename "userliste"
|
||||
|
||||
-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface
|
||||
-- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1
|
||||
csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text
|
||||
csvFilenameLmsResult = makeLmsFilename "ergebnisse"
|
||||
|
||||
-- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2
|
||||
csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text
|
||||
csvFilenameLmsReport = makeLmsFilename "report"
|
||||
|
||||
-- | Create filenames as specified by the LMS interface agreed with Know How AG
|
||||
makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text
|
||||
makeLmsFilename ftag (citext2lower -> qsh) = do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user