289 lines
12 KiB
Haskell
289 lines
12 KiB
Haskell
-- 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.Userlist
|
|
( getLmsUserlistR, postLmsUserlistR
|
|
, getLmsUserlistUploadR, postLmsUserlistUploadR
|
|
, postLmsUserlistDirectR
|
|
)
|
|
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 LmsUserlistTableCsv = LmsUserlistTableCsv
|
|
{ csvLULident :: LmsIdent
|
|
, csvLULfailed :: LmsBool
|
|
}
|
|
deriving Generic
|
|
makeLenses_ ''LmsUserlistTableCsv
|
|
|
|
-- csv without headers
|
|
instance Csv.ToRecord LmsUserlistTableCsv
|
|
instance Csv.FromRecord LmsUserlistTableCsv
|
|
|
|
-- csv with headers
|
|
instance DefaultOrdered LmsUserlistTableCsv where
|
|
headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
|
|
|
|
instance ToNamedRecord LmsUserlistTableCsv where
|
|
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
|
|
[ csvLmsIdent Csv..= csvLULident
|
|
, csvLmsBlocked Csv..= csvLULfailed
|
|
]
|
|
instance FromNamedRecord LmsUserlistTableCsv where
|
|
parseNamedRecord (lsfHeaderTranslate -> csv)
|
|
= LmsUserlistTableCsv
|
|
<$> csv Csv..: csvLmsIdent
|
|
<*> csv Csv..: csvLmsBlocked
|
|
|
|
instance CsvColumnsExplained LmsUserlistTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single csvLmsIdent MsgCsvColumnLmsIdent
|
|
, single csvLmsBlocked MsgCsvColumnLmsFailed
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
|
|
data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
|
|
deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)
|
|
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
|
|
|
|
data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
|
|
| LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool }
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece'' 2 1 -- LmsUserlistInsertData -> insert
|
|
, fieldLabelModifier = camelToPathPiece' 2 -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed
|
|
, sumEncoding = TaggedObject "action" "data"
|
|
} ''LmsUserlistCsvAction
|
|
|
|
|
|
data LmsUserlistCsvException
|
|
= LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
|
|
deriving (Show, Generic)
|
|
|
|
instance Exception LmsUserlistCsvException
|
|
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
|
|
|
|
mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
|
mkUserlistTable sid qsh qid = do
|
|
dbtCsvName <- csvFilenameLmsUserlist qsh
|
|
let dbtCsvSheetName = dbtCsvName
|
|
let
|
|
userlistTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery lmslist = do
|
|
E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid
|
|
return lmslist
|
|
dbtRowKey = (E.^. LmsUserlistId)
|
|
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent
|
|
, sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsFailed) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked
|
|
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent)
|
|
, (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed)
|
|
, (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp)
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
|
|
, (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
|
|
, prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "lms-userlist"
|
|
dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
|
|
where
|
|
addExample dce = dce{ dbtCsvExampleData = csvExample }
|
|
csvExample = Just
|
|
[ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
|
|
| (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
|
|
]
|
|
doEncode' = LmsUserlistTableCsv
|
|
<$> view (_dbrOutput . _entityVal . _lmsUserlistIdent)
|
|
<*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
|
|
dbtCsvDecode = Just DBTCsvDecode {..}
|
|
where
|
|
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
|
|
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
|
|
dbtCsvComputeActions = \case -- shows a diff first
|
|
DBCsvDiffNew{dbCsvNew} -> do
|
|
yield $ LmsUserlistInsertData
|
|
{ lmsUserlistInsertIdent = csvLULident dbCsvNew
|
|
, lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew
|
|
}
|
|
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
|
|
let failedBool = lms2bool csvLULfailed
|
|
when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
|
|
yield $ LmsUserlistUpdateData
|
|
{ lmsUserlistInsertIdent = csvLULident
|
|
, lmsUserlistInsertFailed = csvLULfailed & lms2bool
|
|
}
|
|
DBCsvDiffMissing{} -> return () -- no deletion
|
|
dbtCsvClassifyAction = \case
|
|
LmsUserlistInsertData{} -> LmsUserlistInsert
|
|
LmsUserlistUpdateData{} -> LmsUserlistUpdate
|
|
dbtCsvCoarsenActionClass = \case
|
|
LmsUserlistInsert -> DBCsvActionNew
|
|
LmsUserlistUpdate -> 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 LmsUserlist
|
|
{
|
|
lmsUserlistQualification = qid
|
|
, lmsUserlistIdent = lmsUserlistInsertIdent actionData
|
|
, lmsUserlistFailed = lmsUserlistInsertFailed actionData
|
|
, lmsUserlistTimestamp = now
|
|
}
|
|
[
|
|
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
|
|
, LmsUserlistTimestamp =. now
|
|
]
|
|
-- audit
|
|
lift . queueDBJob $ JobLmsUserlist qid
|
|
return $ LmsUserlistR sid qsh
|
|
dbtCsvRenderKey = const $ \case
|
|
LmsUserlistInsertData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
|
|
$if lmsUserlistInsertFailed
|
|
is closed due to failure.
|
|
$else
|
|
is open.
|
|
|]
|
|
LmsUserlistUpdateData{..} -> do -- TODO: i18n
|
|
[whamlet|
|
|
$newline never
|
|
Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} #
|
|
$if lmsUserlistInsertFailed
|
|
is now closed due to failure.
|
|
$else
|
|
is still open.
|
|
|]
|
|
dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
|
dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text
|
|
dbtExtraReps = []
|
|
|
|
userlistDBTableValidator = def
|
|
& defaultSorting [SortAscBy csvLmsIdent]
|
|
|
|
dbTable userlistDBTableValidator userlistTable
|
|
|
|
|
|
getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsUserlistR = postLmsUserlistR
|
|
postLmsUserlistR sid qsh = do
|
|
lmsTable <- runDB $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
view _2 <$> mkUserlistTable sid qsh qid
|
|
siteLayoutMsg MsgMenuLmsUserlist $ do
|
|
setTitleI MsgMenuLmsUserlist
|
|
$(widgetFile "lms-userlist")
|
|
|
|
|
|
-- Direct File Upload/Download
|
|
-- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
|
|
-- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
|
|
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
|
|
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
|
|
now <- liftIO getCurrentTime
|
|
void $ upsert
|
|
LmsUserlist
|
|
{ lmsUserlistQualification = qid
|
|
, lmsUserlistIdent = csvLULident
|
|
, lmsUserlistFailed = csvLULfailed & lms2bool
|
|
, lmsUserlistTimestamp = now
|
|
}
|
|
[ LmsUserlistFailed =. (csvLULfailed & lms2bool)
|
|
, LmsUserlistTimestamp =. now
|
|
]
|
|
return $ succ i
|
|
|
|
makeUserlistUploadForm :: Form FileInfo
|
|
makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
|
|
|
|
getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
getLmsUserlistUploadR = postLmsUserlistUploadR
|
|
postLmsUserlistUploadR sid qsh = do
|
|
((result,widget), enctype) <- runFormPost makeUserlistUploadForm
|
|
case result of
|
|
FormSuccess file -> do
|
|
nr <- runDBJobs $ do
|
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
|
nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
|
|
queueDBJob $ JobLmsUserlist qid
|
|
return nr
|
|
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
|
|
redirect $ LmsUserlistR sid qsh
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect $ LmsUserlistUploadR sid qsh
|
|
FormMissing ->
|
|
siteLayoutMsg MsgMenuLmsUserlist $ do
|
|
setTitleI MsgMenuLmsUpload
|
|
[whamlet|$newline never
|
|
<form method=post enctype=#{enctype}>
|
|
^{widget}
|
|
<p>
|
|
<input type=submit>
|
|
|]
|
|
|
|
|
|
postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
|
|
postLmsUserlistDirectR 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 (saveUserlistCsv qid) 0
|
|
case enr of
|
|
Left (e :: SomeException) -> do
|
|
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
|
|
return (badRequest400, "Exception: " <> tshow e)
|
|
Right nr -> do
|
|
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
|
|
$logInfoS "LMS" msg
|
|
when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
|
|
return (ok200, msg)
|
|
[] -> do
|
|
let msg = "Userlist upload file missing."
|
|
$logWarnS "LMS" msg
|
|
return (badRequest400, msg)
|
|
_other -> do
|
|
let msg = "Userlist upload received multiple files; all ignored."
|
|
$logWarnS "LMS" msg
|
|
return (badRequest400, msg)
|
|
sendResponseStatus status msg
|