refactor(lms): lms decoding delimiter is fully optional now
This commit is contained in:
Steffen Jost
parent
b99629b97d
commit
d174f39530
@ -125,10 +125,10 @@ ldap:
|
||||
|
||||
ldap-re-test-failover: 60
|
||||
|
||||
lms:
|
||||
upload-headedness: "_env:LMSUPLOADHEADEDNESS:true"
|
||||
upload-delimiter: "_env:LMSUPLOADDELIMITER:,"
|
||||
download-headedness: "_env:LMSDOWNLOADHEADEDNESS:true"
|
||||
lms-direct:
|
||||
upload-header: "_env:LMSUPLOADHEADER:true"
|
||||
upload-delimiter: "_env:LMSUPLOADDELIMITER:"
|
||||
download-header: "_env:LMSDOWNLOADHEADER:true"
|
||||
download-delimiter: "_env:LMSDOWNLOADDELIMITER:,"
|
||||
download-cr-lf: "_env:LMSDOWNLOADCRLF:true"
|
||||
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||
|
||||
module Handler.LMS.Result
|
||||
( getLmsResultR, postLmsResultR
|
||||
, getLmsResultUploadR, postLmsResultUploadR
|
||||
( getLmsResultR, postLmsResultR
|
||||
, getLmsResultUploadR, postLmsResultUploadR
|
||||
, postLmsResultDirectR
|
||||
)
|
||||
where
|
||||
@ -33,7 +33,7 @@ makeLenses_ ''LmsResultTableCsv
|
||||
instance Csv.ToRecord LmsResultTableCsv -- default suffices
|
||||
instance Csv.FromRecord LmsResultTableCsv -- default suffices
|
||||
|
||||
-- csv with headers
|
||||
-- csv with headers
|
||||
lmsResultTableCsvHeader :: Csv.Header
|
||||
lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ]
|
||||
|
||||
@ -73,15 +73,15 @@ deriveJSON defaultOptions
|
||||
, sumEncoding = TaggedObject "action" "data"
|
||||
} ''LmsResultCsvAction
|
||||
|
||||
data LmsResultCsvException
|
||||
data LmsResultCsvException
|
||||
= LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
|
||||
deriving (Show, Generic, Typeable)
|
||||
|
||||
instance Exception LmsResultCsvException
|
||||
embedRenderMessage ''UniWorX ''LmsResultCsvException id
|
||||
embedRenderMessage ''UniWorX ''LmsResultCsvException id
|
||||
|
||||
mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkResultTable sid qsh qid = do
|
||||
mkResultTable sid qsh qid = do
|
||||
now_day <- utctDay <$> liftIO getCurrentTime
|
||||
dbtCsvName <- csvFilenameLmsResult qsh
|
||||
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 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))
|
||||
@ -107,72 +107,72 @@ mkResultTable sid qsh qid = do
|
||||
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent))
|
||||
, (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 csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms-result"
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
dbtIdent = "lms-result"
|
||||
dbtCsvEncode = Just DBTCsvEncode
|
||||
{ dbtCsvExportForm = pure ()
|
||||
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
||||
, dbtCsvName
|
||||
, 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..]
|
||||
]
|
||||
, dbtCsvExampleData = Just
|
||||
[ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day }
|
||||
| (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..]
|
||||
]
|
||||
}
|
||||
where
|
||||
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
|
||||
{ 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
|
||||
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
|
||||
DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do
|
||||
let successDay = lms2day csvLRTsuccess
|
||||
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
|
||||
when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $
|
||||
yield $ LmsResultUpdateData
|
||||
{ lmsResultInsertIdent = csvLRTident
|
||||
, lmsResultInsertSuccess = successDay
|
||||
}
|
||||
}
|
||||
DBCsvDiffMissing{} -> return () -- no deletion
|
||||
, dbtCsvClassifyAction = \case
|
||||
, dbtCsvClassifyAction = \case
|
||||
LmsResultInsertData{} -> LmsResultInsert
|
||||
LmsResultUpdateData{} -> LmsResultUpdate
|
||||
LmsResultUpdateData{} -> LmsResultUpdate
|
||||
, dbtCsvCoarsenActionClass = \case
|
||||
LmsResultInsert -> DBCsvActionNew
|
||||
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
|
||||
C.mapM_ $ \actionData -> do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
void $ upsert
|
||||
LmsResult
|
||||
{ lmsResultQualification = qid
|
||||
{ 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
|
||||
return $ LmsResultR sid qsh
|
||||
, dbtCsvRenderKey = const $ \case
|
||||
LmsResultInsertData{..} -> do -- TODO: i18n
|
||||
[whamlet|
|
||||
$newline never
|
||||
@ -187,7 +187,7 @@ mkResultTable sid qsh qid = do
|
||||
|]
|
||||
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
||||
, dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text
|
||||
}
|
||||
}
|
||||
dbtExtraReps = []
|
||||
|
||||
resultDBTableValidator = def
|
||||
@ -198,9 +198,9 @@ getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler
|
||||
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
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
view _2 <$> mkResultTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsResult $ do
|
||||
setTitleI MsgMenuLmsResult
|
||||
$(widgetFile "lms-result")
|
||||
@ -211,17 +211,17 @@ postLmsResultR sid qsh = do
|
||||
saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
|
||||
saveResultCsv qid i LmsResultTableCsv{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
void $ upsert
|
||||
LmsResult
|
||||
{ lmsResultQualification = qid
|
||||
{ lmsResultQualification = qid
|
||||
, lmsResultIdent = csvLRTident
|
||||
, lmsResultSuccess = csvLRTsuccess & lms2day
|
||||
, lmsResultTimestamp = now
|
||||
, lmsResultTimestamp = now
|
||||
}
|
||||
[ LmsResultSuccess =. (csvLRTsuccess & lms2day)
|
||||
, LmsResultTimestamp =. now
|
||||
]
|
||||
return $ succ i
|
||||
return $ succ i
|
||||
|
||||
makeResultUploadForm :: Form FileInfo
|
||||
makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV"
|
||||
@ -230,23 +230,23 @@ getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand
|
||||
getLmsResultUploadR = postLmsResultUploadR
|
||||
postLmsResultUploadR sid qsh = do
|
||||
((result,widget), enctype) <- runFormPost makeResultUploadForm
|
||||
case result of
|
||||
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
|
||||
-- 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
|
||||
redirect $ LmsResultR sid qsh
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect $ LmsResultUploadR sid qsh
|
||||
FormMissing ->
|
||||
redirect $ LmsResultUploadR sid qsh
|
||||
FormMissing ->
|
||||
siteLayoutMsg MsgMenuLmsResult $ do
|
||||
setTitleI MsgMenuLmsUpload
|
||||
[whamlet|$newline never
|
||||
@ -258,36 +258,32 @@ postLmsResultUploadR sid qsh = do
|
||||
|
||||
|
||||
postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
postLmsResultDirectR sid qsh = do
|
||||
(_params, files) <- runRequestBody
|
||||
postLmsResultDirectR sid qsh = do
|
||||
(_params, files) <- runRequestBody
|
||||
(status, msg) <- case files of
|
||||
[(fhead,file)] -> do
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
let fmtOpts = def { csvDelimiter = lmsUploadDelimiter
|
||||
, csvIncludeHeader = lmsUploadHeadedness
|
||||
}
|
||||
csvOpts = def { csvFormat = fmtOpts }
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
lmsDecoder <- getLmsCsvDecoder
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
enr <- try $ runConduit $ fileSource file
|
||||
.| decodeCsvWith csvOpts
|
||||
.| lmsDecoder
|
||||
.| foldMC (saveResultCsv qid) 0
|
||||
case enr of
|
||||
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
|
||||
Right nr -> do
|
||||
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
|
||||
queueDBJob $ JobLmsResults qid
|
||||
return (ok200, msg)
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Result upload file missing."
|
||||
$logWarnS "LMS" msg
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
_other -> do
|
||||
let msg = "Result upload received multiple files; all ignored."
|
||||
$logWarnS "LMS" msg
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
sendResponseStatus status msg
|
||||
|
||||
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||
|
||||
module Handler.LMS.Userlist
|
||||
( getLmsUserlistR, postLmsUserlistR
|
||||
, getLmsUserlistUploadR, postLmsUserlistUploadR
|
||||
( getLmsUserlistR, postLmsUserlistR
|
||||
, getLmsUserlistUploadR, postLmsUserlistUploadR
|
||||
, postLmsUserlistDirectR
|
||||
)
|
||||
where
|
||||
@ -23,20 +23,20 @@ import Jobs.Queue
|
||||
|
||||
data LmsUserlistTableCsv = LmsUserlistTableCsv
|
||||
{ csvLULident :: LmsIdent
|
||||
, csvLULfailed :: LmsBool
|
||||
, csvLULfailed :: LmsBool
|
||||
}
|
||||
deriving Generic
|
||||
makeLenses_ ''LmsUserlistTableCsv
|
||||
|
||||
-- csv without headers
|
||||
-- csv without headers
|
||||
instance Csv.ToRecord LmsUserlistTableCsv
|
||||
instance Csv.FromRecord LmsUserlistTableCsv
|
||||
|
||||
-- csv with headers
|
||||
instance DefaultOrdered LmsUserlistTableCsv where
|
||||
-- csv with headers
|
||||
instance DefaultOrdered LmsUserlistTableCsv where
|
||||
headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ]
|
||||
|
||||
instance ToNamedRecord LmsUserlistTableCsv where
|
||||
instance ToNamedRecord LmsUserlistTableCsv where
|
||||
toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord
|
||||
[ csvLmsIdent Csv..= csvLULident
|
||||
, csvLmsBlocked Csv..= csvLULfailed
|
||||
@ -57,7 +57,7 @@ instance CsvColumnsExplained LmsUserlistTableCsv where
|
||||
single k v = singletonMap k [whamlet|_{v}|]
|
||||
|
||||
|
||||
data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
|
||||
data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable, Enum, Bounded)
|
||||
embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id
|
||||
|
||||
@ -72,12 +72,12 @@ deriveJSON defaultOptions
|
||||
} ''LmsUserlistCsvAction
|
||||
|
||||
|
||||
data LmsUserlistCsvException
|
||||
data LmsUserlistCsvException
|
||||
= LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?!
|
||||
deriving (Show, Generic, Typeable)
|
||||
|
||||
instance Exception LmsUserlistCsvException
|
||||
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
|
||||
embedRenderMessage ''UniWorX ''LmsUserlistCsvException id
|
||||
|
||||
mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkUserlistTable sid qsh qid = do
|
||||
@ -105,7 +105,7 @@ mkUserlistTable sid qsh qid = do
|
||||
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent ))
|
||||
, (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 csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsFailed)
|
||||
]
|
||||
@ -114,9 +114,9 @@ mkUserlistTable sid qsh qid = do
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms-userlist"
|
||||
dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample
|
||||
where
|
||||
where
|
||||
addExample dce = dce{ dbtCsvExampleData = csvExample }
|
||||
csvExample = Just
|
||||
csvExample = Just
|
||||
[ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl}
|
||||
| (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False]
|
||||
]
|
||||
@ -125,47 +125,47 @@ mkUserlistTable sid qsh qid = do
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool)
|
||||
dbtCsvDecode = Just DBTCsvDecode {..}
|
||||
where
|
||||
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
|
||||
dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} ->
|
||||
fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident
|
||||
dbtCsvComputeActions = \case -- shows a diff first
|
||||
DBCsvDiffNew{dbCsvNew} -> do
|
||||
yield $ LmsUserlistInsertData
|
||||
DBCsvDiffNew{dbCsvNew} -> do
|
||||
yield $ LmsUserlistInsertData
|
||||
{ lmsUserlistInsertIdent = csvLULident dbCsvNew
|
||||
, lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew
|
||||
}
|
||||
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
|
||||
DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do
|
||||
let failedBool = lms2bool csvLULfailed
|
||||
when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $
|
||||
yield $ LmsUserlistUpdateData
|
||||
{ lmsUserlistInsertIdent = csvLULident
|
||||
, lmsUserlistInsertFailed = csvLULfailed & lms2bool
|
||||
yield $ LmsUserlistUpdateData
|
||||
{ lmsUserlistInsertIdent = csvLULident
|
||||
, lmsUserlistInsertFailed = csvLULfailed & lms2bool
|
||||
}
|
||||
DBCsvDiffMissing{} -> return () -- no deletion
|
||||
dbtCsvClassifyAction = \case
|
||||
DBCsvDiffMissing{} -> return () -- no deletion
|
||||
dbtCsvClassifyAction = \case
|
||||
LmsUserlistInsertData{} -> LmsUserlistInsert
|
||||
LmsUserlistUpdateData{} -> LmsUserlistUpdate
|
||||
dbtCsvCoarsenActionClass = \case
|
||||
LmsUserlistInsert -> DBCsvActionNew
|
||||
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
|
||||
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
|
||||
lmsUserlistQualification = qid
|
||||
, lmsUserlistIdent = lmsUserlistInsertIdent actionData
|
||||
, lmsUserlistFailed = lmsUserlistInsertFailed actionData
|
||||
, lmsUserlistTimestamp = now
|
||||
, lmsUserlistTimestamp = now
|
||||
}
|
||||
[
|
||||
LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False?
|
||||
, LmsUserlistTimestamp =. now
|
||||
]
|
||||
-- audit
|
||||
]
|
||||
-- audit
|
||||
lift . queueDBJob $ JobLmsUserlist qid
|
||||
return $ LmsUserlistR sid qsh
|
||||
dbtCsvRenderKey = const $ \case
|
||||
dbtCsvRenderKey = const $ \case
|
||||
LmsUserlistInsertData{..} -> do -- TODO: i18n
|
||||
[whamlet|
|
||||
$newline never
|
||||
@ -195,7 +195,7 @@ mkUserlistTable sid qsh qid = do
|
||||
|
||||
|
||||
getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsUserlistR = postLmsUserlistR
|
||||
getLmsUserlistR = postLmsUserlistR
|
||||
postLmsUserlistR sid qsh = do
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
@ -211,17 +211,17 @@ postLmsUserlistR sid qsh = do
|
||||
saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
|
||||
saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsert
|
||||
void $ upsert
|
||||
LmsUserlist
|
||||
{ lmsUserlistQualification = qid
|
||||
{ lmsUserlistQualification = qid
|
||||
, lmsUserlistIdent = csvLULident
|
||||
, lmsUserlistFailed = csvLULfailed & lms2bool
|
||||
, lmsUserlistTimestamp = now
|
||||
, lmsUserlistTimestamp = now
|
||||
}
|
||||
[ LmsUserlistFailed =. (csvLULfailed & lms2bool)
|
||||
, LmsUserlistTimestamp =. now
|
||||
]
|
||||
return $ succ i
|
||||
return $ succ i
|
||||
|
||||
makeUserlistUploadForm :: Form FileInfo
|
||||
makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV"
|
||||
@ -230,19 +230,19 @@ getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorth
|
||||
getLmsUserlistUploadR = postLmsUserlistUploadR
|
||||
postLmsUserlistUploadR sid qsh = do
|
||||
((result,widget), enctype) <- runFormPost makeUserlistUploadForm
|
||||
case result of
|
||||
case result of
|
||||
FormSuccess file -> do
|
||||
nr <- runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
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
|
||||
redirect $ LmsUserlistR sid qsh
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage Error . toHtml
|
||||
redirect $ LmsUserlistUploadR sid qsh
|
||||
FormMissing ->
|
||||
redirect $ LmsUserlistUploadR sid qsh
|
||||
FormMissing ->
|
||||
siteLayoutMsg MsgMenuLmsUserlist $ do
|
||||
setTitleI MsgMenuLmsUpload
|
||||
[whamlet|$newline never
|
||||
@ -255,35 +255,30 @@ postLmsUserlistUploadR sid qsh = do
|
||||
|
||||
postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
postLmsUserlistDirectR sid qsh = do
|
||||
(_params, files) <- runRequestBody
|
||||
(_params, files) <- runRequestBody
|
||||
(status, msg) <- case files of
|
||||
[(fhead,file)] -> do
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
let fmtOpts = def { csvDelimiter = lmsUploadDelimiter
|
||||
, csvIncludeHeader = lmsUploadHeadedness
|
||||
}
|
||||
csvOpts = def { csvFormat = fmtOpts }
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
lmsDecoder <- getLmsCsvDecoder
|
||||
runDBJobs $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
enr <- try $ runConduit $ fileSource file
|
||||
.| decodeCsvWith csvOpts
|
||||
.| lmsDecoder
|
||||
.| foldMC (saveUserlistCsv qid) 0
|
||||
case enr of
|
||||
case enr of
|
||||
Left (e :: SomeException) -> do
|
||||
$logWarnS "LMS" $ "Userlist upload failed parsing: " <> 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
|
||||
$logWarnS "LMS" msg -- TODO: change to Info Level in the future
|
||||
queueDBJob $ JobLmsResults qid
|
||||
return (ok200, msg)
|
||||
[] -> do
|
||||
let msg = "Userlist upload file missing."
|
||||
$logWarnS "LMS" msg
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
_other -> do
|
||||
let msg = "Userlist upload received multiple files; all ignored."
|
||||
$logWarnS "LMS" msg
|
||||
$logWarnS "LMS" msg
|
||||
return (badRequest400, msg)
|
||||
sendResponseStatus status msg
|
||||
|
||||
@ -27,30 +27,30 @@ data LmsUserTableCsv = LmsUserTableCsv -- for csv export only
|
||||
, csvLUTresetPin, csvLUTdelete, csvLUTstaff :: LmsBool
|
||||
}
|
||||
deriving Generic
|
||||
makeLenses_ ''LmsUserTableCsv
|
||||
makeLenses_ ''LmsUserTableCsv
|
||||
|
||||
-- | Mundane conversion needed for direct download without dbTable onlu
|
||||
lmsUser2csv :: LmsUser -> LmsUserTableCsv
|
||||
lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
|
||||
{ csvLUTident = lmsUserIdent
|
||||
{ csvLUTident = lmsUserIdent
|
||||
, csvLUTpin = lmsUserPin
|
||||
, csvLUTresetPin = lmsUserResetPin & LmsBool
|
||||
, csvLUTresetPin = lmsUserResetPin & LmsBool
|
||||
, csvLUTdelete = lmsUserToDelete lu & LmsBool
|
||||
, csvLUTstaff = False & LmsBool
|
||||
}
|
||||
|
||||
-- csv without headers
|
||||
-- csv without headers
|
||||
instance Csv.ToRecord LmsUserTableCsv
|
||||
instance Csv.FromRecord LmsUserTableCsv
|
||||
|
||||
-- csv with headers
|
||||
-- csv with headers
|
||||
lmsUserTableCsvHeader :: Csv.Header
|
||||
lmsUserTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsPin, csvLmsResetPin, csvLmsDelete, csvLmsStaff ]
|
||||
|
||||
instance ToNamedRecord LmsUserTableCsv where
|
||||
instance ToNamedRecord LmsUserTableCsv where
|
||||
toNamedRecord LmsUserTableCsv{..} = Csv.namedRecord
|
||||
[ csvLmsIdent Csv..= csvLUTident
|
||||
, csvLmsPin Csv..= csvLUTpin
|
||||
, csvLmsPin Csv..= csvLUTpin
|
||||
, csvLmsResetPin Csv..= csvLUTresetPin
|
||||
, csvLmsDelete Csv..= csvLUTdelete
|
||||
, csvLmsStaff Csv..= csvLUTstaff
|
||||
@ -79,14 +79,14 @@ instance CsvColumnsExplained LmsUserTableCsv where
|
||||
|
||||
|
||||
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||
mkUserTable _sid qsh qid = do
|
||||
mkUserTable _sid qsh qid = do
|
||||
dbtCsvName <- csvFilenameLmsUser qsh
|
||||
let dbtCsvSheetName = dbtCsvName
|
||||
let
|
||||
userDBTable = DBTable{..}
|
||||
where
|
||||
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)
|
||||
return lmsuser
|
||||
dbtRowKey = (E.^. LmsUserId)
|
||||
@ -94,7 +94,7 @@ mkUserTable _sid qsh qid = do
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ 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)]
|
||||
) $ \(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 csvLmsDelete) (i18nCell MsgTableLmsDelete) $ \(view $ _dbrOutput . _entityVal . _lmsUserToDelete -> del ) -> ifIconCell del IconRemoveUser
|
||||
, sortable Nothing (i18nCell MsgTableLmsStaff) $ const mempty
|
||||
@ -109,16 +109,16 @@ mkUserTable _sid qsh qid = do
|
||||
[ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserIdent ))
|
||||
, (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 csvLmsResetPin . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsResetPin)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "lms-user"
|
||||
dbtIdent = "lms-user"
|
||||
dbtCsvEncode = Just DBTCsvEncode {..}
|
||||
where
|
||||
where
|
||||
dbtCsvExportForm = pure ()
|
||||
dbtCsvNoExportData = Just id
|
||||
dbtCsvExampleData = Nothing
|
||||
@ -129,7 +129,7 @@ mkUserTable _sid qsh qid = do
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserPin)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserResetPin . _lmsBool)
|
||||
<*> view (_dbrOutput . _entityVal . _lmsUserToDelete . _lmsBool)
|
||||
<*> const (LmsBool False)
|
||||
<*> const (LmsBool False)
|
||||
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
@ -140,9 +140,9 @@ mkUserTable _sid qsh qid = do
|
||||
|
||||
getLmsUsersR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||
getLmsUsersR sid qsh = do
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
view _2 <$> mkUserTable sid qsh qid
|
||||
lmsTable <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
view _2 <$> mkUserTable sid qsh qid
|
||||
siteLayoutMsg MsgMenuLmsUsers $ do
|
||||
setTitleI MsgMenuLmsUsers
|
||||
$(widgetFile "lms-user")
|
||||
@ -150,34 +150,34 @@ getLmsUsersR sid qsh = do
|
||||
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
||||
getLmsUsersDirectR sid qsh = do
|
||||
lms_users <- runDB $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
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
|
||||
Ex.select $ do
|
||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||
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
|
||||
Ex.select $ do
|
||||
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)
|
||||
pure $ LmsUserTableCsv
|
||||
{ csvLUTident = lmsuser Ex.^. LmsUserIdent
|
||||
, csvLUTpin = lmsuser Ex.^. LmsUserPin
|
||||
{ csvLUTident = lmsuser Ex.^. LmsUserIdent
|
||||
, csvLUTpin = lmsuser Ex.^. LmsUserPin
|
||||
, csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin
|
||||
, csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus)
|
||||
, csvLUTstaff = LmsBool False
|
||||
}
|
||||
-}
|
||||
-}
|
||||
LmsConf{..} <- getsYesod $ view _appLmsConf
|
||||
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
|
||||
--csvRenderedHeader = lmsUserTableCsvHeader
|
||||
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
|
||||
--csvRenderedHeader = lmsUserTableCsvHeader
|
||||
--cvsRendered = CsvRendered {..}
|
||||
csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users
|
||||
fmtOpts = def { csvDelimiter = lmsDownloadDelimiter
|
||||
fmtOpts = def { csvIncludeHeader = lmsDownloadHeader
|
||||
, csvDelimiter = lmsDownloadDelimiter
|
||||
, csvUseCrLf = lmsDownloadCrLf
|
||||
, csvIncludeHeader = lmsDownloadHeadedness
|
||||
}
|
||||
csvOpts = def { csvFormat = fmtOpts }
|
||||
csvSheetName <- csvFilenameLmsUser qsh
|
||||
csvSheetName <- csvFilenameLmsUser qsh
|
||||
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
||||
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
|
||||
|
||||
|
||||
-- direct Download see:
|
||||
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
||||
@ -1,17 +1,18 @@
|
||||
{-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
|
||||
|
||||
module Handler.Utils.LMS
|
||||
( csvLmsIdent
|
||||
( getLmsCsvDecoder
|
||||
, csvLmsIdent
|
||||
, csvLmsTimestamp
|
||||
, csvLmsBlocked
|
||||
, csvLmsSuccess
|
||||
, csvLmsPin
|
||||
, csvLmsPin
|
||||
, csvLmsResetPin
|
||||
, csvLmsDelete
|
||||
, csvLmsStaff
|
||||
, csvFilenameLmsUser
|
||||
, csvLmsDelete
|
||||
, csvLmsStaff
|
||||
, csvFilenameLmsUser
|
||||
, csvFilenameLmsUserlist
|
||||
, csvFilenameLmsResult
|
||||
, csvFilenameLmsResult
|
||||
, lmsUserToDelete, _lmsUserToDelete
|
||||
, lmsUserToDeleteExpr
|
||||
, randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries
|
||||
@ -19,14 +20,30 @@ module Handler.Utils.LMS
|
||||
|
||||
-- general utils for LMS Interface Handlers
|
||||
|
||||
import Import
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Csv
|
||||
import Data.Csv (HasHeader(..), FromRecord)
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
import Control.Monad.Random.Class (uniform)
|
||||
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 = 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 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 :: Getter LmsUser Bool
|
||||
_lmsUserToDelete :: Getter LmsUser Bool
|
||||
_lmsUserToDelete = to lmsUserToDelete
|
||||
|
||||
|
||||
-- random generation of LmsIdentifiers, maybe this should be in Model.Types.Lms since length specifications are type-y?
|
||||
|
||||
lengthIdent :: Int
|
||||
lengthIdent = 8
|
||||
lengthIdent :: Int
|
||||
lengthIdent = 8
|
||||
|
||||
lengthPassword :: Int
|
||||
lengthPassword = 8
|
||||
lengthPassword :: Int
|
||||
lengthPassword = 8
|
||||
|
||||
-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent
|
||||
maxLmsUserIdentRetries :: Int
|
||||
-- | Maximal number of times, randomLMSIdent should be called in a row to find an unused LmsIdent
|
||||
maxLmsUserIdentRetries :: Int
|
||||
maxLmsUserIdentRetries = 27
|
||||
|
||||
-- | Generate Random Text of specified length using numbers and lower case letters plus supplied extra characters
|
||||
randomText :: MonadIO m => String -> Int -> m Text
|
||||
randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
|
||||
where
|
||||
randomText :: MonadIO m => String -> Int -> m Text
|
||||
randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
|
||||
where
|
||||
num_letters = ['0'..'9'] ++ ['a'..'z']
|
||||
range = extra ++ num_letters
|
||||
|
||||
--TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
|
||||
-- import qualified Data.Elocrypt as Elo
|
||||
-- randomLMSIdent :: MonadRandom m => m LmsIdent
|
||||
-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt
|
||||
-- where
|
||||
-- randomLMSIdent :: MonadRandom m => m LmsIdent
|
||||
-- randomLMSIdent = LmsIdent . T.pack <$> Elo.mkPassword lengthIdent eopt
|
||||
-- where
|
||||
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
|
||||
|
||||
randomLMSIdent :: MonadIO m => m LmsIdent
|
||||
randomLMSIdent :: MonadIO m => m LmsIdent
|
||||
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
|
||||
|
||||
randomLMSpw :: MonadIO m => m Text
|
||||
randomLMSpw :: MonadIO m => m Text
|
||||
randomLMSpw = randomText extra lengthPassword
|
||||
where
|
||||
where
|
||||
extra = "_-+*.:;=!?#"
|
||||
|
||||
@ -304,10 +304,10 @@ data LdapConf = LdapConf
|
||||
} deriving (Show)
|
||||
|
||||
data LmsConf = LmsConf
|
||||
{ lmsUploadDelimiter :: Char
|
||||
, lmsUploadHeadedness :: Bool
|
||||
{ lmsUploadHeader :: Bool
|
||||
, lmsUploadDelimiter :: Maybe Char
|
||||
, lmsDownloadHeader :: Bool
|
||||
, lmsDownloadDelimiter :: Char
|
||||
, lmsDownloadHeadedness :: Bool
|
||||
, lmsDownloadCrLf :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
@ -492,11 +492,11 @@ deriveFromJSON
|
||||
|
||||
instance FromJSON LmsConf where
|
||||
parseJSON = withObject "LmsConf" $ \o -> do
|
||||
lmsUploadDelimiter <- o .: "upload-delimiter"
|
||||
lmsUploadHeadedness <- o .: "upload-headedness"
|
||||
lmsDownloadDelimiter <- o .: "download-delimiter"
|
||||
lmsDownloadHeadedness <- o .: "download-headedness"
|
||||
lmsDownloadCrLf <- o .: "download-cr-lf"
|
||||
lmsUploadHeader <- o .: "upload-header"
|
||||
lmsUploadDelimiter <- o .:? "upload-delimiter"
|
||||
lmsDownloadHeader <- o .: "download-header"
|
||||
lmsDownloadDelimiter <- o .: "download-delimiter"
|
||||
lmsDownloadCrLf <- o .: "download-cr-lf"
|
||||
return LmsConf{..}
|
||||
|
||||
makeLenses_ ''LmsConf
|
||||
@ -597,7 +597,7 @@ instance FromJSON AppSettings where
|
||||
Ldap.Tls host _ -> not $ null host
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
appLmsConf <- o .: "lms"
|
||||
appLmsConf <- o .: "lms-direct"
|
||||
appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs"
|
||||
appLprConf <- o .: "lpr"
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
|
||||
Reference in New Issue
Block a user