-- SPDX-FileCopyrightText: 2023 Steffen Jost ,Steffen Jost -- -- 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
^{widget} |] 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