fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(lms): lms decoding delimiter is fully optional now

Browse Source
This commit is contained in:
Steffen Jost 2022-09-09 12:11:13 +02:00
parent b99629b97d
commit d174f39530
6 changed files with 198 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
config/settings.yml
View File

@ -125,10 +125,10 @@ ldap:
ldap-re-test-failover: 60 ldap-re-test-failover: 60
lms: lms-direct:
upload-headedness: "_env:LMSUPLOADHEADEDNESS:true" upload-header: "_env:LMSUPLOADHEADER:true"
upload-delimiter: "_env:LMSUPLOADDELIMITER:," upload-delimiter: "_env:LMSUPLOADDELIMITER:"
download-headedness: "_env:LMSDOWNLOADHEADEDNESS:true" download-header: "_env:LMSDOWNLOADHEADER:true"
download-delimiter: "_env:LMSDOWNLOADDELIMITER:," download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
download-cr-lf: "_env:LMSDOWNLOADCRLF:true" download-cr-lf: "_env:LMSDOWNLOADCRLF:true"

126
src/Handler/LMS/Result.hs
View File

@ -1,8 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
module Handler.LMS.Result module Handler.LMS.Result
( getLmsResultR, postLmsResultR ( getLmsResultR, postLmsResultR
, getLmsResultUploadR, postLmsResultUploadR , getLmsResultUploadR, postLmsResultUploadR
, postLmsResultDirectR , postLmsResultDirectR
) )
where where
@ -33,7 +33,7 @@ makeLenses_ ''LmsResultTableCsv
instance Csv.ToRecord LmsResultTableCsv -- default suffices instance Csv.ToRecord LmsResultTableCsv -- default suffices
instance Csv.FromRecord LmsResultTableCsv -- default suffices instance Csv.FromRecord LmsResultTableCsv -- default suffices
-- csv with headers -- csv with headers
lmsResultTableCsvHeader :: Csv.Header lmsResultTableCsvHeader :: Csv.Header
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
@ -73,15 +73,15 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "action" "data" , sumEncoding = TaggedObject "action" "data"
} ''LmsResultCsvAction } ''LmsResultCsvAction
data LmsResultCsvException data LmsResultCsvException
= LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
deriving (Show, Generic, Typeable) deriving (Show, Generic, Typeable)
instance Exception LmsResultCsvException instance Exception LmsResultCsvException
embedRenderMessage ''UniWorX ''LmsResultCsvException id embedRenderMessage ''UniWorX ''LmsResultCsvException id
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkResultTable sid qsh qid = do mkResultTable sid qsh qid = do
now_day <- utctDay <$> liftIO getCurrentTime now_day <- utctDay <$> liftIO getCurrentTime
dbtCsvName <- csvFilenameLmsResult qsh dbtCsvName <- csvFilenameLmsResult qsh
let dbtCsvSheetName = dbtCsvName let dbtCsvSheetName = dbtCsvName
@ -97,7 +97,7 @@ mkResultTable sid qsh qid = do
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident [ 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 csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success
, sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent))
, (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess))
@ -107,72 +107,72 @@ mkResultTable sid qsh qid = do
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
, (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-result" dbtIdent = "lms-result"
dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure () { dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName , dbtCsvName
, dbtCsvSheetName , dbtCsvSheetName
, dbtCsvNoExportData = Just id , dbtCsvNoExportData = Just id
, dbtCsvHeader = const $ return lmsResultTableCsvHeader , dbtCsvHeader = const $ return lmsResultTableCsvHeader
, dbtCsvExampleData = Just , dbtCsvExampleData = Just
[ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
] ]
} }
where where
doEncode' = LmsResultTableCsv doEncode' = LmsResultTableCsv
<$> view (_dbrOutput . _entityVal . _lmsResultIdent) <$> view (_dbrOutput . _entityVal . _lmsResultIdent)
<*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay)
dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later
{ dbtCsvRowKey = \LmsResultTableCsv{..} -> { dbtCsvRowKey = \LmsResultTableCsv{..} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident
, dbtCsvComputeActions = \case -- purpose is to show a diff to the user first , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
yield $ LmsResultInsertData yield $ LmsResultInsertData
{ lmsResultInsertIdent = csvLRTident dbCsvNew { lmsResultInsertIdent = csvLRTident dbCsvNew
, lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day , 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 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 DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
let successDay = lms2day csvLRTsuccess let successDay = lms2day csvLRTsuccess
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
yield $ LmsResultUpdateData yield $ LmsResultUpdateData
{ lmsResultInsertIdent = csvLRTident { lmsResultInsertIdent = csvLRTident
, lmsResultInsertSuccess = successDay , lmsResultInsertSuccess = successDay
} }
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
, dbtCsvClassifyAction = \case , dbtCsvClassifyAction = \case
LmsResultInsertData{} -> LmsResultInsert LmsResultInsertData{} -> LmsResultInsert
LmsResultUpdateData{} -> LmsResultUpdate LmsResultUpdateData{} -> LmsResultUpdate
, dbtCsvCoarsenActionClass = \case , dbtCsvCoarsenActionClass = \case
LmsResultInsert -> DBCsvActionNew LmsResultInsert -> DBCsvActionNew
LmsResultUpdate -> DBCsvActionExisting LmsResultUpdate -> DBCsvActionExisting
, dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
, dbtCsvExecuteActions = do , dbtCsvExecuteActions = do
C.mapM_ $ \actionData -> do C.mapM_ $ \actionData -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsResult LmsResult
{ lmsResultQualification = qid { lmsResultQualification = qid
, lmsResultIdent = lmsResultInsertIdent actionData , lmsResultIdent = lmsResultInsertIdent actionData
, lmsResultSuccess = lmsResultInsertSuccess actionData , lmsResultSuccess = lmsResultInsertSuccess actionData
, lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose?
} }
[ LmsResultSuccess =. lmsResultInsertSuccess actionData [ LmsResultSuccess =. lmsResultInsertSuccess actionData
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
-- audit $ Transaction.. (add to Audit.Types) -- audit $ Transaction.. (add to Audit.Types)
lift . queueDBJob $ JobLmsResults qid lift . queueDBJob $ JobLmsResults qid
return $ LmsResultR sid qsh return $ LmsResultR sid qsh
, dbtCsvRenderKey = const $ \case , dbtCsvRenderKey = const $ \case
LmsResultInsertData{..} -> do -- TODO: i18n LmsResultInsertData{..} -> do -- TODO: i18n
[whamlet| [whamlet|
$newline never $newline never
@ -187,7 +187,7 @@ mkResultTable sid qsh qid = do
|] |]
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
} }
dbtExtraReps = [] dbtExtraReps = []
resultDBTableValidator = def resultDBTableValidator = def
@ -198,9 +198,9 @@ getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler
getLmsResultR = postLmsResultR getLmsResultR = postLmsResultR
postLmsResultR sid qsh = do postLmsResultR sid qsh = do
let directUploadLink = LmsResultUploadR sid qsh let directUploadLink = LmsResultUploadR sid qsh
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkResultTable sid qsh qid view _2 <$> mkResultTable sid qsh qid
siteLayoutMsg MsgMenuLmsResult $ do siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsResult setTitleI MsgMenuLmsResult
$(widgetFile "lms-result") $(widgetFile "lms-result")
@ -211,17 +211,17 @@ postLmsResultR sid qsh = do
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
saveResultCsv qid i LmsResultTableCsv{..} = do saveResultCsv qid i LmsResultTableCsv{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsResult LmsResult
{ lmsResultQualification = qid { lmsResultQualification = qid
, lmsResultIdent = csvLRTident , lmsResultIdent = csvLRTident
, lmsResultSuccess = csvLRTsuccess & lms2day , lmsResultSuccess = csvLRTsuccess & lms2day
, lmsResultTimestamp = now , lmsResultTimestamp = now
} }
[ LmsResultSuccess =. (csvLRTsuccess & lms2day) [ LmsResultSuccess =. (csvLRTsuccess & lms2day)
, LmsResultTimestamp =. now , LmsResultTimestamp =. now
] ]
return $ succ i return $ succ i
makeResultUploadForm :: Form FileInfo makeResultUploadForm :: Form FileInfo
makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
@ -230,23 +230,23 @@ getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand
getLmsResultUploadR = postLmsResultUploadR getLmsResultUploadR = postLmsResultUploadR
postLmsResultUploadR sid qsh = do postLmsResultUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeResultUploadForm ((result,widget), enctype) <- runFormPost makeResultUploadForm
case result of case result of
FormSuccess file -> do FormSuccess file -> do
-- content <- fileSourceByteString file -- content <- fileSourceByteString file
-- return $ Just (fileName file, content) -- return $ Just (fileName file, content)
nr <- runDBJobs $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file nr <- runConduit $ fileSource file
.| decodeCsv .| decodeCsv
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
queueDBJob $ JobLmsResults qid queueDBJob $ JobLmsResults qid
return nr return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsResultR sid qsh redirect $ LmsResultR sid qsh
FormFailure errs -> do FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect $ LmsResultUploadR sid qsh redirect $ LmsResultUploadR sid qsh
FormMissing -> FormMissing ->
siteLayoutMsg MsgMenuLmsResult $ do siteLayoutMsg MsgMenuLmsResult $ do
setTitleI MsgMenuLmsUpload setTitleI MsgMenuLmsUpload
[whamlet|$newline never [whamlet|$newline never
@ -258,36 +258,32 @@ postLmsResultUploadR sid qsh = do
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsResultDirectR sid qsh = do postLmsResultDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
(status, msg) <- case files of (status, msg) <- case files of
[(fhead,file)] -> do [(fhead,file)] -> do
LmsConf{..} <- getsYesod $ view _appLmsConf lmsDecoder <- getLmsCsvDecoder
let fmtOpts = def { csvDelimiter = lmsUploadDelimiter runDBJobs $ do
, csvIncludeHeader = lmsUploadHeadedness qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
}
csvOpts = def { csvFormat = fmtOpts }
runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
enr <- try $ runConduit $ fileSource file enr <- try $ runConduit $ fileSource file
.| decodeCsvWith csvOpts .| lmsDecoder
.| foldMC (saveResultCsv qid) 0 .| foldMC (saveResultCsv qid) 0
case enr of case enr of
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
$logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e
return (badRequest400, "Exception: " <> tshow e) return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
$logWarnS "LMS" msg -- TODO: change to Info Level in the future $logWarnS "LMS" msg -- TODO: change to Info Level in the future
queueDBJob $ JobLmsResults qid queueDBJob $ JobLmsResults qid
return (ok200, msg) return (ok200, msg)
[] -> do [] -> do
let msg = "Result upload file missing." let msg = "Result upload file missing."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
_other -> do _other -> do
let msg = "Result upload received multiple files; all ignored." let msg = "Result upload received multiple files; all ignored."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
sendResponseStatus status msg sendResponseStatus status msg

107
src/Handler/LMS/Userlist.hs
View File

@ -1,8 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
module Handler.LMS.Userlist module Handler.LMS.Userlist
( getLmsUserlistR, postLmsUserlistR ( getLmsUserlistR, postLmsUserlistR
, getLmsUserlistUploadR, postLmsUserlistUploadR , getLmsUserlistUploadR, postLmsUserlistUploadR
, postLmsUserlistDirectR , postLmsUserlistDirectR
) )
where where
@ -23,20 +23,20 @@ import Jobs.Queue
data LmsUserlistTableCsv = LmsUserlistTableCsv data LmsUserlistTableCsv = LmsUserlistTableCsv
{ csvLULident :: LmsIdent { csvLULident :: LmsIdent
, csvLULfailed :: LmsBool , csvLULfailed :: LmsBool
} }
deriving Generic deriving Generic
makeLenses_ ''LmsUserlistTableCsv makeLenses_ ''LmsUserlistTableCsv
-- csv without headers -- csv without headers
instance Csv.ToRecord LmsUserlistTableCsv instance Csv.ToRecord LmsUserlistTableCsv
instance Csv.FromRecord LmsUserlistTableCsv instance Csv.FromRecord LmsUserlistTableCsv
-- csv with headers -- csv with headers
instance DefaultOrdered LmsUserlistTableCsv where instance DefaultOrdered LmsUserlistTableCsv where
headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
instance ToNamedRecord LmsUserlistTableCsv where instance ToNamedRecord LmsUserlistTableCsv where
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
[ csvLmsIdent Csv..= csvLULident [ csvLmsIdent Csv..= csvLULident
, csvLmsBlocked Csv..= csvLULfailed , csvLmsBlocked Csv..= csvLULfailed
@ -57,7 +57,7 @@ instance CsvColumnsExplained LmsUserlistTableCsv where
single k v = singletonMap k [whamlet|_{v}|] single k v = singletonMap k [whamlet|_{v}|]
data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded) deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
@ -72,12 +72,12 @@ deriveJSON defaultOptions
} ''LmsUserlistCsvAction } ''LmsUserlistCsvAction
data LmsUserlistCsvException data LmsUserlistCsvException
= LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
deriving (Show, Generic, Typeable) deriving (Show, Generic, Typeable)
instance Exception LmsUserlistCsvException instance Exception LmsUserlistCsvException
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserlistTable sid qsh qid = do mkUserlistTable sid qsh qid = do
@ -105,7 +105,7 @@ mkUserlistTable sid qsh qid = do
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
, (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed) , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
] ]
@ -114,9 +114,9 @@ mkUserlistTable sid qsh qid = do
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-userlist" dbtIdent = "lms-userlist"
dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
where where
addExample dce = dce{ dbtCsvExampleData = csvExample } addExample dce = dce{ dbtCsvExampleData = csvExample }
csvExample = Just csvExample = Just
[ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
| (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
] ]
@ -125,47 +125,47 @@ mkUserlistTable sid qsh qid = do
<*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
dbtCsvDecode = Just DBTCsvDecode {..} dbtCsvDecode = Just DBTCsvDecode {..}
where where
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
dbtCsvComputeActions = \case -- shows a diff first dbtCsvComputeActions = \case -- shows a diff first
DBCsvDiffNew{dbCsvNew} -> do DBCsvDiffNew{dbCsvNew} -> do
yield $ LmsUserlistInsertData yield $ LmsUserlistInsertData
{ lmsUserlistInsertIdent = csvLULident dbCsvNew { lmsUserlistInsertIdent = csvLULident dbCsvNew
, lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew
} }
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
let failedBool = lms2bool csvLULfailed let failedBool = lms2bool csvLULfailed
when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
yield $ LmsUserlistUpdateData yield $ LmsUserlistUpdateData
{ lmsUserlistInsertIdent = csvLULident { lmsUserlistInsertIdent = csvLULident
, lmsUserlistInsertFailed = csvLULfailed & lms2bool , lmsUserlistInsertFailed = csvLULfailed & lms2bool
} }
DBCsvDiffMissing{} -> return () -- no deletion DBCsvDiffMissing{} -> return () -- no deletion
dbtCsvClassifyAction = \case dbtCsvClassifyAction = \case
LmsUserlistInsertData{} -> LmsUserlistInsert LmsUserlistInsertData{} -> LmsUserlistInsert
LmsUserlistUpdateData{} -> LmsUserlistUpdate LmsUserlistUpdateData{} -> LmsUserlistUpdate
dbtCsvCoarsenActionClass = \case dbtCsvCoarsenActionClass = \case
LmsUserlistInsert -> DBCsvActionNew LmsUserlistInsert -> DBCsvActionNew
LmsUserlistUpdate -> DBCsvActionExisting LmsUserlistUpdate -> DBCsvActionExisting
dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error
dbtCsvExecuteActions = do dbtCsvExecuteActions = do
C.mapM_ $ \actionData -> do C.mapM_ $ \actionData -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert LmsUserlist void $ upsert LmsUserlist
{ {
lmsUserlistQualification = qid lmsUserlistQualification = qid
, lmsUserlistIdent = lmsUserlistInsertIdent actionData , lmsUserlistIdent = lmsUserlistInsertIdent actionData
, lmsUserlistFailed = lmsUserlistInsertFailed actionData , lmsUserlistFailed = lmsUserlistInsertFailed actionData
, lmsUserlistTimestamp = now , lmsUserlistTimestamp = now
} }
[ [
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
, LmsUserlistTimestamp =. now , LmsUserlistTimestamp =. now
] ]
-- audit -- audit
lift . queueDBJob $ JobLmsUserlist qid lift . queueDBJob $ JobLmsUserlist qid
return $ LmsUserlistR sid qsh return $ LmsUserlistR sid qsh
dbtCsvRenderKey = const $ \case dbtCsvRenderKey = const $ \case
LmsUserlistInsertData{..} -> do -- TODO: i18n LmsUserlistInsertData{..} -> do -- TODO: i18n
[whamlet| [whamlet|
$newline never $newline never
@ -195,7 +195,7 @@ mkUserlistTable sid qsh qid = do
getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUserlistR = postLmsUserlistR getLmsUserlistR = postLmsUserlistR
postLmsUserlistR sid qsh = do postLmsUserlistR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
@ -211,17 +211,17 @@ postLmsUserlistR sid qsh = do
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
void $ upsert void $ upsert
LmsUserlist LmsUserlist
{ lmsUserlistQualification = qid { lmsUserlistQualification = qid
, lmsUserlistIdent = csvLULident , lmsUserlistIdent = csvLULident
, lmsUserlistFailed = csvLULfailed & lms2bool , lmsUserlistFailed = csvLULfailed & lms2bool
, lmsUserlistTimestamp = now , lmsUserlistTimestamp = now
} }
[ LmsUserlistFailed =. (csvLULfailed & lms2bool) [ LmsUserlistFailed =. (csvLULfailed & lms2bool)
, LmsUserlistTimestamp =. now , LmsUserlistTimestamp =. now
] ]
return $ succ i return $ succ i
makeUserlistUploadForm :: Form FileInfo makeUserlistUploadForm :: Form FileInfo
makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
@ -230,19 +230,19 @@ getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorth
getLmsUserlistUploadR = postLmsUserlistUploadR getLmsUserlistUploadR = postLmsUserlistUploadR
postLmsUserlistUploadR sid qsh = do postLmsUserlistUploadR sid qsh = do
((result,widget), enctype) <- runFormPost makeUserlistUploadForm ((result,widget), enctype) <- runFormPost makeUserlistUploadForm
case result of case result of
FormSuccess file -> do FormSuccess file -> do
nr <- runDBJobs $ do nr <- runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
queueDBJob $ JobLmsUserlist qid queueDBJob $ JobLmsUserlist qid
return nr return nr
addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
redirect $ LmsUserlistR sid qsh redirect $ LmsUserlistR sid qsh
FormFailure errs -> do FormFailure errs -> do
forM_ errs $ addMessage Error . toHtml forM_ errs $ addMessage Error . toHtml
redirect $ LmsUserlistUploadR sid qsh redirect $ LmsUserlistUploadR sid qsh
FormMissing -> FormMissing ->
siteLayoutMsg MsgMenuLmsUserlist $ do siteLayoutMsg MsgMenuLmsUserlist $ do
setTitleI MsgMenuLmsUpload setTitleI MsgMenuLmsUpload
[whamlet|$newline never [whamlet|$newline never
@ -255,35 +255,30 @@ postLmsUserlistUploadR sid qsh = do
postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
postLmsUserlistDirectR sid qsh = do postLmsUserlistDirectR sid qsh = do
(_params, files) <- runRequestBody (_params, files) <- runRequestBody
(status, msg) <- case files of (status, msg) <- case files of
[(fhead,file)] -> do [(fhead,file)] -> do
LmsConf{..} <- getsYesod $ view _appLmsConf lmsDecoder <- getLmsCsvDecoder
let fmtOpts = def { csvDelimiter = lmsUploadDelimiter runDBJobs $ do
, csvIncludeHeader = lmsUploadHeadedness qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
}
csvOpts = def { csvFormat = fmtOpts }
runDBJobs $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
enr <- try $ runConduit $ fileSource file enr <- try $ runConduit $ fileSource file
.| decodeCsvWith csvOpts .| lmsDecoder
.| foldMC (saveUserlistCsv qid) 0 .| foldMC (saveUserlistCsv qid) 0
case enr of case enr of
Left (e :: SomeException) -> do Left (e :: SomeException) -> do
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e
return (badRequest400, "Exception: " <> tshow e) return (badRequest400, "Exception: " <> tshow e)
Right nr -> do Right nr -> do
let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
$logWarnS "LMS" msg -- TODO: change to Info Level in the future $logWarnS "LMS" msg -- TODO: change to Info Level in the future
queueDBJob $ JobLmsResults qid queueDBJob $ JobLmsResults qid
return (ok200, msg) return (ok200, msg)
[] -> do [] -> do
let msg = "Userlist upload file missing." let msg = "Userlist upload file missing."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
_other -> do _other -> do
let msg = "Userlist upload received multiple files; all ignored." let msg = "Userlist upload received multiple files; all ignored."
$logWarnS "LMS" msg $logWarnS "LMS" msg
return (badRequest400, msg) return (badRequest400, msg)
sendResponseStatus status msg sendResponseStatus status msg

62
src/Handler/LMS/Users.hs
View File

@ -27,30 +27,30 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
, csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool , csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool
} }
deriving Generic deriving Generic
makeLenses_ ''LmsUserTableCsv makeLenses_ ''LmsUserTableCsv
-- | Mundane conversion needed for direct download without dbTable onlu -- | Mundane conversion needed for direct download without dbTable onlu
lmsUser2csv :: LmsUser -> LmsUserTableCsv lmsUser2csv :: LmsUser -> LmsUserTableCsv
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
{ csvLUTident = lmsUserIdent { csvLUTident = lmsUserIdent
, csvLUTpin = lmsUserPin , csvLUTpin = lmsUserPin
, csvLUTresetPin = lmsUserResetPin & LmsBool , csvLUTresetPin = lmsUserResetPin & LmsBool
, csvLUTdelete = lmsUserToDelete lu & LmsBool , csvLUTdelete = lmsUserToDelete lu & LmsBool
, csvLUTstaff = False & LmsBool , csvLUTstaff = False & LmsBool
} }
-- csv without headers -- csv without headers
instance Csv.ToRecord LmsUserTableCsv instance Csv.ToRecord LmsUserTableCsv
instance Csv.FromRecord LmsUserTableCsv instance Csv.FromRecord LmsUserTableCsv
-- csv with headers -- csv with headers
lmsUserTableCsvHeader :: Csv.Header lmsUserTableCsvHeader :: Csv.Header
lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ] lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ]
instance ToNamedRecord LmsUserTableCsv where instance ToNamedRecord LmsUserTableCsv where
toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
[ csvLmsIdent Csv..= csvLUTident [ csvLmsIdent Csv..= csvLUTident
, csvLmsPin Csv..= csvLUTpin , csvLmsPin Csv..= csvLUTpin
, csvLmsResetPin Csv..= csvLUTresetPin , csvLmsResetPin Csv..= csvLUTresetPin
, csvLmsDelete Csv..= csvLUTdelete , csvLmsDelete Csv..= csvLUTdelete
, csvLmsStaff Csv..= csvLUTstaff , csvLmsStaff Csv..= csvLUTstaff
@ -79,14 +79,14 @@ instance CsvColumnsExplained LmsUserTableCsv where
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserTable _sid qsh qid = do mkUserTable _sid qsh qid = do
dbtCsvName <- csvFilenameLmsUser qsh dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName let dbtCsvSheetName = dbtCsvName
let let
userDBTable = DBTable{..} userDBTable = DBTable{..}
where where
dbtSQLQuery lmsuser = do dbtSQLQuery lmsuser = do
E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid E.where_ $ lmsuser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (lmsuser E.^. LmsUserEnded) E.&&. E.isNothing (lmsuser E.^. LmsUserEnded)
return lmsuser return lmsuser
dbtRowKey = (E.^. LmsUserId) dbtRowKey = (E.^. LmsUserId)
@ -94,7 +94,7 @@ mkUserTable _sid qsh qid = do
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsUserIdent . _getLmsIdent -> ident) -> textCell ident [ 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)] , sortable (Just csvLmsPin) (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin ) $ \(view $ _dbrOutput . _entityVal . _lmsUserPin -> pin ) -> textCell pin
, sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset , sortable (Just csvLmsResetPin) (i18nCell MsgTableLmsResetPin) $ \(view $ _dbrOutput . _entityVal . _lmsUserResetPin -> reset) -> ifIconCell reset IconReset
, sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser , sortable (Just csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser
, sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty , sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty
@ -109,16 +109,16 @@ mkUserTable _sid qsh qid = do
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent )) [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
, (csvLmsResetPin , FilterColumn $ E.mkExactFilter (E.^. LmsUserResetPin)) , (csvLmsResetPin , FilterColumn $ E.mkExactFilter (E.^. LmsUserResetPin))
] ]
dbtFilterUI = \mPrev -> mconcat dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
, prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin) , prismAForm (singletonFilter csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms-user" dbtIdent = "lms-user"
dbtCsvEncode = Just DBTCsvEncode {..} dbtCsvEncode = Just DBTCsvEncode {..}
where where
dbtCsvExportForm = pure () dbtCsvExportForm = pure ()
dbtCsvNoExportData = Just id dbtCsvNoExportData = Just id
dbtCsvExampleData = Nothing dbtCsvExampleData = Nothing
@ -129,7 +129,7 @@ mkUserTable _sid qsh qid = do
<*> view (_dbrOutput . _entityVal . _lmsUserPin) <*> view (_dbrOutput . _entityVal . _lmsUserPin)
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool) <*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
<*> const (LmsBool False) <*> const (LmsBool False)
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
@ -140,9 +140,9 @@ mkUserTable _sid qsh qid = do
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
getLmsUsersR sid qsh = do getLmsUsersR sid qsh = do
lmsTable <- runDB $ do lmsTable <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
view _2 <$> mkUserTable sid qsh qid view _2 <$> mkUserTable sid qsh qid
siteLayoutMsg MsgMenuLmsUsers $ do siteLayoutMsg MsgMenuLmsUsers $ do
setTitleI MsgMenuLmsUsers setTitleI MsgMenuLmsUsers
$(widgetFile "lms-user") $(widgetFile "lms-user")
@ -150,34 +150,34 @@ getLmsUsersR sid qsh = do
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
getLmsUsersDirectR sid qsh = do getLmsUsersDirectR sid qsh = do
lms_users <- runDB $ do lms_users <- runDB $ do
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent] selectList [LmsUserQualification ==. qid, LmsUserEnded ==. Nothing] [Asc LmsUserStarted, Asc LmsUserIdent]
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do Ex.select $ do
lmsuser <- Ex.from $ Ex.table @LmsUser lmsuser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid Ex.where_ $ lmsuser Ex.^. LmsUserQualification Ex.==. Ex.val qid
Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.isNothing (lmsuser Ex.^. LmsUserEnded)
pure $ LmsUserTableCsv pure $ LmsUserTableCsv
{ csvLUTident = lmsuser Ex.^. LmsUserIdent { csvLUTident = lmsuser Ex.^. LmsUserIdent
, csvLUTpin = lmsuser Ex.^. LmsUserPin , csvLUTpin = lmsuser Ex.^. LmsUserPin
, csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
, csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus) , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
, csvLUTstaff = LmsBool False , csvLUTstaff = LmsBool False
} }
-} -}
LmsConf{..} <- getsYesod $ view _appLmsConf LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader --csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..} --cvsRendered = CsvRendered {..}
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users
fmtOpts = def { csvDelimiter = lmsDownloadDelimiter fmtOpts = def { csvIncludeHeader = lmsDownloadHeader
, csvDelimiter = lmsDownloadDelimiter
, csvUseCrLf = lmsDownloadCrLf , csvUseCrLf = lmsDownloadCrLf
, csvIncludeHeader = lmsDownloadHeadedness
} }
csvOpts = def { csvFormat = fmtOpts } csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh csvSheetName <- csvFilenameLmsUser qsh
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-- direct Download see: -- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

68
src/Handler/Utils/LMS.hs
View File

@ -1,17 +1,18 @@
{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter {-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
module Handler.Utils.LMS module Handler.Utils.LMS
( csvLmsIdent ( getLmsCsvDecoder
, csvLmsIdent
, csvLmsTimestamp , csvLmsTimestamp
, csvLmsBlocked , csvLmsBlocked
, csvLmsSuccess , csvLmsSuccess
, csvLmsPin , csvLmsPin
, csvLmsResetPin , csvLmsResetPin
, csvLmsDelete , csvLmsDelete
, csvLmsStaff , csvLmsStaff
, csvFilenameLmsUser , csvFilenameLmsUser
, csvFilenameLmsUserlist , csvFilenameLmsUserlist
, csvFilenameLmsResult , csvFilenameLmsResult
, lmsUserToDelete, _lmsUserToDelete , lmsUserToDelete, _lmsUserToDelete
, lmsUserToDeleteExpr , lmsUserToDeleteExpr
, randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries , randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries
@ -19,14 +20,30 @@ module Handler.Utils.LMS
-- general utils for LMS Interface Handlers -- general utils for LMS Interface Handlers
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Csv
import Data.Csv (HasHeader(..), FromRecord)
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import Control.Monad.Random.Class (uniform) import Control.Monad.Random.Class (uniform)
import Control.Monad.Trans.Random (evalRandTIO) import Control.Monad.Trans.Random (evalRandTIO)
-- generic Column names
getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => Handler (ConduitT ByteString csv m ())
getLmsCsvDecoder = do
LmsConf{..} <- getsYesod $ view _appLmsConf
if | Just upDelim <- lmsUploadDelimiter -> do
let fmtOpts = def { csvDelimiter = upDelim
, csvIncludeHeader = lmsUploadHeader
}
csvOpts = def { csvFormat = fmtOpts }
return $ decodeCsvWith csvOpts
| lmsUploadHeader -> return decodeCsv
| otherwise -> return $ decodeCsvPositional NoHeader
-- generic Column names
csvLmsIdent :: IsString a => a csvLmsIdent :: IsString a => a
csvLmsIdent = fromString "user" -- "Benutzerkennung" csvLmsIdent = fromString "user" -- "Benutzerkennung"
@ -81,44 +98,43 @@ getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus)
lmsUserToDelete :: LmsUser -> Bool lmsUserToDelete :: LmsUser -> Bool
lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus
_lmsUserToDelete :: Getter LmsUser Bool _lmsUserToDelete :: Getter LmsUser Bool
_lmsUserToDelete = to lmsUserToDelete _lmsUserToDelete = to lmsUserToDelete
-- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y? -- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y?
lengthIdent :: Int lengthIdent :: Int
lengthIdent = 8 lengthIdent = 8
lengthPassword :: Int lengthPassword :: Int
lengthPassword = 8 lengthPassword = 8
-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent -- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent
maxLmsUserIdentRetries :: Int maxLmsUserIdentRetries :: Int
maxLmsUserIdentRetries = 27 maxLmsUserIdentRetries = 27
-- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters -- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters
randomText :: MonadIO m => String -> Int -> m Text randomText :: MonadIO m => String -> Int -> m Text
randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
where where
num_letters = ['0'..'9'] ++ ['a'..'z'] num_letters = ['0'..'9'] ++ ['a'..'z']
range = extra ++ num_letters range = extra ++ num_letters
--TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though --TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
-- import qualified Data.Elocrypt as Elo -- import qualified Data.Elocrypt as Elo
-- randomLMSIdent :: MonadRandom m => m LmsIdent -- randomLMSIdent :: MonadRandom m => m LmsIdent
-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt -- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt
-- where -- where
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True } -- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
randomLMSIdent :: MonadIO m => m LmsIdent randomLMSIdent :: MonadIO m => m LmsIdent
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
randomLMSpw :: MonadIO m => m Text randomLMSpw :: MonadIO m => m Text
randomLMSpw = randomText extra lengthPassword randomLMSpw = randomText extra lengthPassword
where where
extra = "_-+*.:;=!?#" extra = "_-+*.:;=!?#"

18
src/Settings.hs
View File

@ -304,10 +304,10 @@ data LdapConf = LdapConf
} deriving (Show) } deriving (Show)
data LmsConf = LmsConf data LmsConf = LmsConf
{ lmsUploadDelimiter :: Char { lmsUploadHeader :: Bool
, lmsUploadHeadedness :: Bool , lmsUploadDelimiter :: Maybe Char
, lmsDownloadHeader :: Bool
, lmsDownloadDelimiter :: Char , lmsDownloadDelimiter :: Char
, lmsDownloadHeadedness :: Bool
, lmsDownloadCrLf :: Bool , lmsDownloadCrLf :: Bool
} deriving (Show) } deriving (Show)
@ -492,11 +492,11 @@ deriveFromJSON
instance FromJSON LmsConf where instance FromJSON LmsConf where
parseJSON = withObject "LmsConf" $ \o -> do parseJSON = withObject "LmsConf" $ \o -> do
lmsUploadDelimiter <- o .: "upload-delimiter" lmsUploadHeader <- o .: "upload-header"
lmsUploadHeadedness <- o .: "upload-headedness" lmsUploadDelimiter <- o .:? "upload-delimiter"
lmsDownloadDelimiter <- o .: "download-delimiter" lmsDownloadHeader <- o .: "download-header"
lmsDownloadHeadedness <- o .: "download-headedness" lmsDownloadDelimiter <- o .: "download-delimiter"
lmsDownloadCrLf <- o .: "download-cr-lf" lmsDownloadCrLf <- o .: "download-cr-lf"
return LmsConf{..} return LmsConf{..}
makeLenses_ ''LmsConf makeLenses_ ''LmsConf
@ -597,7 +597,7 @@ instance FromJSON AppSettings where
Ldap.Tls host _ -> not $ null host Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host Ldap.Plain host -> not $ null host
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
appLmsConf <- o .: "lms" appLmsConf <- o .: "lms-direct"
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
appLprConf <- o .: "lpr" appLprConf <- o .: "lpr"
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"