diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b4213a860..fece2bfe2 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1981,6 +1981,7 @@ ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehm ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst +ExamUsersExamDataRequiresRegistration: Wenn Prüfungsbezogene Daten (Teil-/Ergebnis, Termin/Raum, Bonus) gesetzt bzw. angepasst werden sollen, muss der jeweilige Teilnehmer zur Prüfung angemeldet sein bzw. werden. CourseUserTutorialsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Tutorium" "Tutorien"} abgemeldet CourseUserNoTutorialsDeregistered: Teilnehmer ist zu keinem der gewählten Tutorien angemeldet CourseUserExamsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Prüfung" "Prüfungen"} abgemeldet diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index c8cb2dbb9..e2362c410 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1980,6 +1980,7 @@ ExamUsersResultsReset count: Successfully reset result for #{show count} #{plura ExamUsersPartResultsSet count: Successfully modified exam part result for #{show count} #{pluralEN count "participant" "participants"} ExamUsersBonusSet count: Successfully modified exam bonus for #{show count} #{pluralEN count "participant" "participants"} ExamUsersResultSet count: Sucessfully modified exam result for #{show count} #{pluralEN count "participant" "participants"} +ExamUsersExamDataRequiresRegistration: If exam data (part-/result, occurrence/room, bonus) is to be modified/set, the relenvant participant needs to be registered for the exam. CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from #{show count} #{pluralEN count "tutorial" "tutorials"} CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected tutorials CourseUserExamsDeregistered count: Successfully deregistered participant from #{show count} #{pluralEN count "exam" "exams"} diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 57ed2f2db..8e9f53d79 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -402,6 +402,7 @@ postCApplicationsR tid ssh csh = do CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment , dbtCsvCoarsenActionClass = const DBCsvActionExisting + , dbtCsvValidateActions = return () , dbtCsvExecuteActions = do C.mapM_ $ \case CourseApplicationsTableCsvSetVetoData{..} -> do diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 30b351113..6e76ed20b 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -43,6 +43,8 @@ import Control.Lens.Indexed ((<.), (.>)) import Jobs.Queue +import qualified Control.Monad.State.Class as State + type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User) @@ -613,8 +615,7 @@ postEUsersR tid ssh csh examn = do -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do (isPart, uid) <- lift $ guessUser' dbCsvNew - unless isPart $ - yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew + yieldM $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> lookupOccurrence dbCsvNew iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> when (epNumber `elem` examPartNumbers) $ @@ -706,6 +707,22 @@ postEUsersR tid ssh csh examn = do ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvDeregister -> DBCsvActionMissing _other -> DBCsvActionExisting + , dbtCsvValidateActions = do + selectedActions <- State.get + availableActions <- ask + let missingExamDataUsers = flip filter examDataUsers $ \uid -> any (isRegisterAction uid) availableActions && none (isRegisterAction uid) selectedActions + where + examDataUsers = flip mapMaybe selectedActions $ \case + ExamUserCsvSetResultData{..} -> Just examUserCsvActUser + ExamUserCsvSetBonusData{..} -> Just examUserCsvActUser + ExamUserCsvSetPartResultData{..} -> Just examUserCsvActUser + _other -> Nothing + isRegisterAction uid = \case + ExamUserCsvCourseRegisterData{..} -> uid == examUserCsvActUser + ExamUserCsvRegisterData{..} -> uid == examUserCsvActUser + _other -> False + unless (null missingExamDataUsers) $ + tellMPoint $ messageI Error MsgExamUsersExamDataRequiresRegistration , dbtCsvExecuteActions = do C.mapM_ $ \case ExamUserCsvCourseRegisterData{..} -> do diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index a64df671f..f3d3aed0c 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -446,6 +446,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $ yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult + , dbtCsvValidateActions = return () , dbtCsvClassifyAction = \case ExternalExamUserCsvRegisterData{} -> ExternalExamUserCsvRegister ExternalExamUserCsvSetTimeData{} -> ExternalExamUserCsvSetTime diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0bba1059d..b14d92de2 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -69,7 +69,7 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue) import qualified Network.Wai as Wai -import Control.Monad.RWS (RWST(..), execRWS) +import Control.Monad.RWS (RWST(..), execRWS, execRWST) import Control.Monad.State (evalStateT, execStateT) import Control.Monad.Trans.Maybe import Control.Monad.State.Class (modify) @@ -420,6 +420,9 @@ data DBCsvException k' { dbCsvExceptionRow :: NamedRecord , dbCsvException :: Text } + | DBCsvUnavailableActionRequested + { dbCsvActions :: Set Value + } deriving (Show, Typeable) makeLenses_ ''DBCsvException @@ -598,6 +601,7 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException ) => DBTCsvDecode { dbtCsvRowKey :: csv -> MaybeT DB k' , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB () + , dbtCsvValidateActions :: RWST (Set csvAction) [Message] [csvAction] DB () , dbtCsvClassifyAction :: csvAction -> csvActionClass , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route @@ -1177,6 +1181,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db |] fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False + availableActs :: Widget + availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" (toPathPiece PostDBCsvImportAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation")) let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings { formMethod = POST @@ -1231,6 +1237,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
^{csvReImport} |] + other -> throwM other , Catch.Handler $ \(csvParseError :: CsvParseError) -> liftHandler $ sendResponseStatus badRequest400 =<< do mr <- getMessageRender @@ -1389,18 +1396,29 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db ] ((csvImportConfirmRes, _confirmView), _enctype) <- case dbtCsvDecode of - Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do + Just (DBTCsvDecode{dbtCsvExecuteActions, dbtCsvValidateActions} :: DBTCsvDecode r' k' csv) -> do lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do + availableActs <- fromMaybe Set.empty <$> globalPostParamField PostDBCsvImportAvailableActions secretJsonField acts <- globalPostParamFields PostDBCsvImportAction secretJsonField - return . (, mempty) $ if - | null acts -> FormSuccess $ do - addMessageI Info MsgCsvImportAborted - redirect $ tblLink id - | otherwise -> FormSuccess $ do - finalDest <- runDBJobs' . runConduit $ C.sourceList acts .| dbtCsvExecuteActions - addMessageI Success . MsgCsvImportSuccessful $ length acts - E.transactionSave - redirect finalDest + return . (, mempty) . FormSuccess $ if + | unavailableActs <- filter (`Set.notMember` availableActs) acts + , not $ null unavailableActs -> do + throwM . DBCsvUnavailableActionRequested @k' . Set.fromList $ map toJSON unavailableActs + | otherwise -> do + (acts', validationMsgs) <- execRWST dbtCsvValidateActions availableActs acts + if | not $ null validationMsgs -> do + mapM_ addMessage' validationMsgs + E.transactionUndo + redirect $ tblLink id + | null acts' -> do + addMessageI Info MsgCsvImportAborted + redirect $ tblLink id + | otherwise -> do + finalDest <- runDBJobs' . runConduit $ C.sourceList acts' .| dbtCsvExecuteActions + addMessageI Success . MsgCsvImportSuccessful $ length acts' + E.transactionSave + redirect finalDest + _other -> return ((FormMissing, mempty), mempty) formResult csvImportConfirmRes $ \case (_, BtnCsvImportAbort) -> do diff --git a/src/Utils.hs b/src/Utils.hs index 2b3a428d0..3668a5655 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -884,6 +884,9 @@ tellM = tell <=< lift tellPoint :: (MonadWriter mono m, MonoPointed mono) => Element mono -> m () tellPoint = tell . opoint + +tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m () +tellMPoint = tellM . fmap opoint ------------- -- Conduit -- diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index f056be9c6..2fdbf6311 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -57,7 +57,7 @@ data GlobalPostParam = PostFormIdentifier | PostDeleteTarget | PostMassInputShape | PostBearer - | PostDBCsvImportAction + | PostDBCsvImportAction | PostDBCsvImportAvailableActions | PostDBCsvReImport | PostLoginDummy | PostExamAutoOccurrencePrevious diff --git a/templates/csv-import-confirmation.hamlet b/templates/csv-import-confirmation.hamlet index 473a2c101..07b549938 100644 --- a/templates/csv-import-confirmation.hamlet +++ b/templates/csv-import-confirmation.hamlet @@ -1,5 +1,6 @@ $newline never #{csrf} +^{availableActs}
$forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)