diff --git a/config/settings.yml b/config/settings.yml index f9c501645..190cd0670 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 92c6c4550..43ddac453 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -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 - + diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 3ef15737e..25d57e3ed 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -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 - \ No newline at end of file diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index 772f7910a..216c74270 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -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 \ No newline at end of file diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 3cd3e3403..79a306756 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -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 = "_-+*.:;=!?#" - \ No newline at end of file diff --git a/src/Settings.hs b/src/Settings.hs index 6f8b502da..fb471d603 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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"