294 lines
13 KiB
Haskell
294 lines
13 KiB
Haskell
-- 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.Result
|
|
( getLmsResultR, postLmsResultR
|
|
, getLmsResultUploadR, postLmsResultUploadR
|
|
, postLmsResultDirectR
|
|
)
|
|
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 LmsResultTableCsv = LmsResultTableCsv
|
|
{ csvLRTident :: LmsIdent
|
|
, csvLRTsuccess :: LmsDay
|
|
}
|
|
deriving Generic
|
|
makeLenses_ ''LmsResultTableCsv
|
|
|
|
-- csv without headers
|
|
instance Csv.ToRecord LmsResultTableCsv -- default suffices
|
|
instance Csv.FromRecord LmsResultTableCsv -- default suffices
|
|
|
|
-- csv with headers
|
|
lmsResultTableCsvHeader :: Csv.Header
|
|
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
|
|
|
|
instance ToNamedRecord LmsResultTableCsv where
|
|
toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord
|
|
[ csvLmsIdent Csv..= csvLRTident
|
|
, csvLmsSuccess Csv..= csvLRTsuccess
|
|
]
|
|
|
|
instance FromNamedRecord LmsResultTableCsv where
|
|
parseNamedRecord (lsfHeaderTranslate -> csv)
|
|
= LmsResultTableCsv
|
|
<$> csv Csv..: csvLmsIdent
|
|
<*> csv Csv..: csvLmsSuccess
|
|
|
|
instance CsvColumnsExplained LmsResultTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single csvLmsIdent MsgCsvColumnLmsIdent
|
|
, single csvLmsSuccess MsgCsvColumnLmsSuccess
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
|
|
embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id
|
|
|
|
-- By coincidence the action type is identical to LmsResultTableCsv
|
|
data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
|
|
| LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert
|
|
, fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success
|
|
, sumEncoding = TaggedObject "action" "data"
|
|
} ''LmsResultCsvAction
|
|
|
|
data LmsResultCsvException
|
|
= LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception LmsResultCsvException
|
|
embedRenderMessage ''UniWorX ''LmsResultCsvException id
|
|
|
|
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
|
mkResultTable sid qsh qid = do
|
|
now_day <- utctDay <$> liftIO getCurrentTime
|
|
dbtCsvName <- csvFilenameLmsResult qsh
|
|
let dbtCsvSheetName = dbtCsvName
|
|
let
|
|
resultDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery lmsresult = do
|
|
E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid
|
|
return lmsresult
|
|
dbtRowKey = (E.^. LmsResultId)
|
|
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident
|
|
, sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success
|
|
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ (csvLmsIdent , SortColumn (E.^. LmsResultIdent))
|
|
, (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess))
|
|
, (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
|
|
, (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess))
|
|
]
|
|
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-result"
|
|
dbtCsvEncode = Just DBTCsvEncode
|
|
{ dbtCsvExportForm = pure ()
|
|
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
|
, dbtCsvName
|
|
, dbtCsvSheetName
|
|
, dbtCsvNoExportData = Just id
|
|
, dbtCsvHeader = const $ return lmsResultTableCsvHeader
|
|
, dbtCsvExampleData = Just
|
|
[ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
|
|
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
|
|
]
|
|
}
|
|
where
|
|
doEncode' = LmsResultTableCsv
|
|
<$> view (_dbrOutput . _entityVal . _lmsResultIdent)
|
|
<*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
|
|
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
|
|
{ dbtCsvRowKey = \LmsResultTableCsv{..} ->
|
|
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
|
|
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
|
|
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
|
yield $ LmsResultInsertData
|
|
{ lmsResultInsertIdent = csvLRTident dbCsvNew
|
|
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day
|
|
}
|
|
DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code
|
|
DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
|
|
let successDay = lms2day csvLRTsuccess
|
|
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
|
|
yield $ LmsResultUpdateData
|
|
{ lmsResultInsertIdent = csvLRTident
|
|
, lmsResultInsertSuccess = successDay
|
|
}
|
|
DBCsvDiffMissing{} -> return () -- no deletion
|
|
, dbtCsvClassifyAction = \case
|
|
LmsResultInsertData{} -> LmsResultInsert
|
|
LmsResultUpdateData{} -> LmsResultUpdate
|
|
, dbtCsvCoarsenActionClass = \case
|
|
LmsResultInsert -> DBCsvActionNew
|
|
LmsResultUpdate -> 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
|
|
LmsResult
|
|
{ lmsResultQualification = qid
|
|
, lmsResultIdent = lmsResultInsertIdent actionData
|
|
, lmsResultSuccess = lmsResultInsertSuccess actionData
|
|
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
|
|
}
|
|
[ LmsResultSuccess =. lmsResultInsertSuccess actionData
|
|
, LmsResultTimestamp =. now
|
|
]
|
|
-- audit $ Transaction.. (add to Audit.Types)
|
|
lift . queueDBJob $ JobLmsResults qid
|
|
return $ LmsResultR sid qsh
|
|
, dbtCsvRenderKey = const $ \case
|
|
LmsResultInsertData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Insert: Ident #{getLmsIdent lmsResultInsertIdent} #
|
|
had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
|
|
|]
|
|
LmsResultUpdateData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Update: Ident #{getLmsIdent lmsResultInsertIdent} #
|
|
had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess}
|
|
|]
|
|
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
|
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
|
|
}
|
|
dbtExtraReps = []
|
|
|
|
resultDBTableValidator = def
|
|
& defaultSorting [SortAscBy csvLmsIdent]
|
|
dbTable resultDBTableValidator resultDBTable
|
|
|
|
getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsResultR = postLmsResultR
|
|
postLmsResultR sid qsh = do
|
|
let directUploadLink = LmsResultUploadR sid qsh
|
|
lmsTable <- runDB $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
view _2 <$> mkResultTable sid qsh qid
|
|
siteLayoutMsg MsgMenuLmsResult $ do
|
|
setTitleI MsgMenuLmsResult
|
|
$(widgetFile "lms-result")
|
|
|
|
|
|
-- Direct File Upload/Download
|
|
|
|
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
|
|
saveResultCsv qid i LmsResultTableCsv{..} = do
|
|
now <- liftIO getCurrentTime
|
|
void $ upsert
|
|
LmsResult
|
|
{ lmsResultQualification = qid
|
|
, lmsResultIdent = csvLRTident
|
|
, lmsResultSuccess = csvLRTsuccess & lms2day
|
|
, lmsResultTimestamp = now
|
|
}
|
|
[ LmsResultSuccess =. (csvLRTsuccess & lms2day)
|
|
, LmsResultTimestamp =. now
|
|
]
|
|
return $ succ i
|
|
|
|
makeResultUploadForm :: Form FileInfo
|
|
makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
|
|
|
|
getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsResultUploadR = postLmsResultUploadR
|
|
postLmsResultUploadR sid qsh = do
|
|
((result,widget), enctype) <- runFormPost makeResultUploadForm
|
|
case result 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 (saveResultCsv qid) 0
|
|
queueDBJob $ JobLmsResults qid
|
|
return nr
|
|
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
|
|
redirect $ LmsResultR sid qsh
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect $ LmsResultUploadR sid qsh
|
|
FormMissing ->
|
|
siteLayoutMsg MsgMenuLmsResult $ do
|
|
setTitleI MsgMenuLmsUpload
|
|
[whamlet|$newline never
|
|
<form method=post enctype=#{enctype}>
|
|
^{widget}
|
|
<p>
|
|
<input type=submit>
|
|
|]
|
|
|
|
|
|
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
postLmsResultDirectR 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 (saveResultCsv qid) 0
|
|
case enr of
|
|
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
|
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
|
|
return (badRequest400, "Exception: " <> tshow e)
|
|
Right nr -> do
|
|
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
|
|
$logInfoS "LMS" msg
|
|
when (nr > 0) $ queueDBJob $ JobLmsResults qid
|
|
return (ok200, msg)
|
|
[] -> do
|
|
let msg = "Result upload file missing."
|
|
$logWarnS "LMS" msg
|
|
return (badRequest400, msg)
|
|
_other -> do
|
|
let msg = "Result upload received multiple files; all ignored."
|
|
$logWarnS "LMS" msg
|
|
return (badRequest400, msg)
|
|
sendResponseStatus status msg
|
|
|