335 lines
15 KiB
Haskell
335 lines
15 KiB
Haskell
-- SPDX-FileCopyrightText: 2023 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 LmsTimestamp
|
|
, csvLRresult :: LmsState
|
|
, csvLRlock :: LmsBool
|
|
}
|
|
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 { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool }
|
|
| LmsReportUpdateData { lmsReportCsvIdent :: LmsIdent, lmsReportCsvDate :: Maybe UTCTime, lmsReportCsvResult :: LmsState, lmsReportCsvLock :: Bool }
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsReportInsertData -> insert
|
|
, fieldLabelModifier = camelToPathPiece' 2 -- lmsReportCsvIdent -> csv-ident
|
|
, 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 <- 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 csvLmsDate) (i18nCell MsgTableLmsDate) $ \(view $ _dbrOutput . _entityVal . _lmsReportDate -> d) -> cellMaybe dateTimeCell d
|
|
, sortable (Just csvLmsResult) (i18nCell MsgTableLmsStatus) $ \(view $ _dbrOutput . _entityVal . _lmsReportResult -> s) -> lmsStateCell s
|
|
, sortable (Just csvLmsLock) (i18nCell MsgTableLmsLock) $ \(view $ _dbrOutput . _entityVal . _lmsReportLock -> b) -> ifIconCell b IconLocked
|
|
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived)$ \(view $ _dbrOutput . _entityVal . _lmsReportTimestamp -> t) -> dateTimeCell t
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ (csvLmsIdent , SortColumn (E.^. LmsReportIdent))
|
|
, (csvLmsDate , SortColumn (E.^. LmsReportDate))
|
|
, (csvLmsResult , SortColumn (E.^. LmsReportResult))
|
|
, (csvLmsLock , SortColumn (E.^. LmsReportLock))
|
|
, (csvLmsTimestamp, SortColumn (E.^. LmsReportTimestamp))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWithCommaPlus LmsIdent (E.^. LmsReportIdent))
|
|
, (csvLmsDate , FilterColumn $ E.mkExactFilter (E.^. LmsReportDate))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent & setTooltip MsgTableFilterCommaPlus)
|
|
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsDate)
|
|
]
|
|
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
|
|
{ csvLRident = LmsIdent lid
|
|
, csvLRdate = Just $ LmsTimestamp $ addLocalDays (fromIntegral $ -dos) now
|
|
, csvLRresult = toEnum $ dos `mod` succ (fromEnum (maxBound :: LmsState))
|
|
, csvLRlock = LmsBool $ even dos
|
|
}
|
|
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch", "x2!y3-z4"] [(1::Int)..]
|
|
]
|
|
}
|
|
where
|
|
doEncode' = LmsReportTableCsv
|
|
<$> view (_dbrOutput . _entityVal . _lmsReportIdent)
|
|
<*> preview (_dbrOutput . _entityVal . _lmsReportDate . _Just . _lmsTimestamp)
|
|
<*> view (_dbrOutput . _entityVal . _lmsReportResult)
|
|
<*> view (_dbrOutput . _entityVal . _lmsReportLock . _lmsBool)
|
|
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
|
|
{ dbtCsvRowKey = \LmsReportTableCsv{..} ->
|
|
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsReport qid csvLRident
|
|
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
|
|
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew = LmsReportTableCsv{..}} -> do
|
|
yield $ LmsReportInsertData
|
|
{ lmsReportCsvIdent = csvLRident
|
|
, lmsReportCsvDate = csvLRdate <&> lms2timestamp
|
|
, lmsReportCsvResult = csvLRresult
|
|
, lmsReportCsvLock = csvLRlock & lms2bool
|
|
}
|
|
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 resultTime = csvLRdate <&> lms2timestamp
|
|
when (resultTime > dbCsvOld ^. _dbrOutput . _entityVal . _lmsReportDate) $
|
|
yield $ LmsReportUpdateData
|
|
{ lmsReportCsvIdent = csvLRident
|
|
, lmsReportCsvDate = resultTime
|
|
, lmsReportCsvResult = csvLRresult
|
|
, lmsReportCsvLock = csvLRlock & lms2bool
|
|
}
|
|
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
|
|
eanow <- liftIO getCurrentTime
|
|
void $ upsert
|
|
LmsReport
|
|
{ lmsReportQualification = qid
|
|
, lmsReportIdent = lmsReportCsvIdent actionData
|
|
, lmsReportDate = lmsReportCsvDate actionData
|
|
, lmsReportResult = lmsReportCsvResult actionData
|
|
, lmsReportLock = lmsReportCsvLock actionData
|
|
, lmsReportTimestamp = eanow
|
|
}
|
|
[ LmsReportDate =. lmsReportCsvDate actionData
|
|
, LmsReportResult =. lmsReportCsvResult actionData
|
|
, LmsReportLock =. lmsReportCsvLock actionData
|
|
, LmsReportTimestamp =. eanow
|
|
]
|
|
lift . queueDBJob $ JobLmsReports qid
|
|
return $ LmsReportR sid qsh
|
|
, dbtCsvRenderKey = const $ \case
|
|
LmsReportInsertData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Insert: Ident #{getLmsIdent lmsReportCsvIdent} #
|
|
has status #{show lmsReportCsvResult} #
|
|
$if lmsReportCsvLock
|
|
and is locked #
|
|
$maybe d <- lmsReportCsvDate
|
|
on ^{formatTimeW SelFormatDateTime d}
|
|
|]
|
|
LmsReportUpdateData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Update: Ident #{getLmsIdent lmsReportCsvIdent} #
|
|
has status #{show lmsReportCsvResult} #
|
|
$if lmsReportCsvLock
|
|
and is locked #
|
|
$maybe d <- lmsReportCsvDate
|
|
on ^{formatTimeW SelFormatDateTime d}
|
|
|]
|
|
, 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 :: UTCTime -> QualificationId -> Int -> LmsReportTableCsv -> JobDB Int
|
|
saveReportCsv now qid i LmsReportTableCsv{..} = do
|
|
void $ upsert
|
|
LmsReport
|
|
{ lmsReportQualification = qid
|
|
, lmsReportIdent = csvLRident
|
|
, lmsReportDate = csvLRdate <&> lms2timestamp
|
|
, lmsReportResult = csvLRresult
|
|
, lmsReportLock = csvLRlock & lms2bool
|
|
, lmsReportTimestamp = now
|
|
}
|
|
[ LmsReportDate =. (csvLRdate <&> lms2timestamp)
|
|
, LmsReportResult =. csvLRresult
|
|
, LmsReportLock =. (csvLRlock & lms2bool)
|
|
, 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
|
|
now <- liftIO getCurrentTime
|
|
((report,widget), enctype) <- runFormPost makeReportUploadForm
|
|
case report of
|
|
FormSuccess file -> do
|
|
-- content <- fileSourceByteString file
|
|
-- return $ Just (fileName file, content)
|
|
(nr, qid) <- runDBJobs $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
nr <- runConduit $ fileSource file
|
|
.| decodeCsv
|
|
.| foldMC (saveReportCsv now qid) 0
|
|
return (nr, qid)
|
|
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
|
|
-- redirect $ LmsReportR sid qsh
|
|
getLmsReportR sid qsh <* queueJob' (JobLmsReports qid) -- show uploaded data before processing
|
|
|
|
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}
|
|
<input type=submit>
|
|
|]
|
|
|
|
|
|
postLmsReportDirectR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
postLmsReportDirectR sid qsh = do
|
|
(_params, files) <- runRequestBody
|
|
(status, msg) <- case files of
|
|
[(fhead,file)] -> do
|
|
now <- liftIO getCurrentTime
|
|
lmsDecoder <- getLmsCsvDecoder
|
|
runDBJobs $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
enr <- try $ runConduit $ fileSource file
|
|
.| lmsDecoder
|
|
.| foldMC (saveReportCsv now 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
|
|
logInterface "LMS" (ciOriginal qsh) False Nothing ""
|
|
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
|
|
logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
|
|
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 -- must be outside of runDB; otherwise transaction is rolled back
|
|
|