diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 833df71e9..e79b4b3e2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1278,6 +1278,7 @@ CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilneh CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") +CsvColumnExamUserCourseNote: Notizen zum Teilnehmer Action: Aktion @@ -1292,6 +1293,9 @@ ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern ExamUserCsvSetResult: Ergebnis eintragen +ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen + +ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index ca8599861..20966b7da 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -36,8 +36,8 @@ import Control.Arrow (Kleisli(..)) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult)) +type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) +type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote)) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -49,25 +49,28 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 4 2) +queryExamOccurrence = $(sqlLOJproj 5 2) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) -queryExamResult = $(sqlLOJproj 4 4) +queryExamResult = $(sqlLOJproj 5 4) + +queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) +queryCourseNote = $(sqlLOJproj 5 5) resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration = _dbrOutput . _1 @@ -90,6 +93,9 @@ resultExamOccurrence = _dbrOutput . _3 . _Just resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _7 . _Just +resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) +resultCourseNote = _dbrOutput . _8 . _Just + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text , csvEUserFirstName :: Maybe Text @@ -104,6 +110,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserExercisePointsMax :: Maybe Points , csvEUserExerciseNumPassesMax :: Maybe Int , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + , csvEUserCourseNote :: Maybe Html } deriving (Generic) makeLenses_ ''ExamUserTableCsv @@ -130,6 +137,7 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:? "exercise-points-max" <*> csv .:? "exercise-num-passes-max" <*> csv .:? "exam-result" + <*> csv .:? "course-note" where (.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a) m .:? name = Csv.lookup m name <|> return Nothing @@ -152,6 +160,7 @@ instance CsvColumnsExplained ExamUserTableCsv where , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) + , ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote ) ] data ExamUserAction = ExamUserDeregister @@ -171,8 +180,9 @@ data ExamUserCsvActionClass | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField - | ExamUserCsvDeregister | ExamUserCsvSetResult + | ExamUserCsvSetCourseNote + | ExamUserCsvDeregister deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id @@ -201,6 +211,10 @@ data ExamUserCsvAction { examUserCsvActUser :: UserId , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) } + | ExamUserCsvSetCourseNoteData + { examUserCsvActUser :: UserId + , examUserCsvActCourseNote :: Maybe Html + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel @@ -236,7 +250,9 @@ postEUsersR tid ssh csh examn = do let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do + E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) + E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField @@ -248,7 +264,7 @@ postEUsersR tid ssh csh examn = do E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult) + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = mconcat $ catMaybes @@ -269,6 +285,8 @@ postEUsersR tid ssh csh examn = do return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) + , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) + -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -279,6 +297,11 @@ postEUsersR tid ssh csh examn = do , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) + , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date + E.sub_select . E.from $ \edit -> do + E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) + return . E.max_ $ edit E.^. CourseUserNoteEditTime + ) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -354,6 +377,7 @@ postEUsersR tid ssh csh examn = do <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) + <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser csv @@ -376,6 +400,10 @@ postEUsersR tid ssh csh examn = do yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew when (is _Just $ csvEUserExamResult dbCsvNew) $ yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew + + note <- lift . getBy $ UniqueCourseUserNote uid examCourse + when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $ + yield . ExamUserCsvSetCourseNoteData uid $ csvEUserCourseNote dbCsvNew DBCsvDiffExisting{..} -> do newOccurrence <- lift $ lookupOccurrence dbCsvNew when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ @@ -388,6 +416,9 @@ postEUsersR tid ssh csh examn = do when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew + + when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $ + yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew , dbtCsvClassifyAction = \case ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister ExamUserCsvRegisterData{} -> ExamUserCsvRegister @@ -395,6 +426,7 @@ postEUsersR tid ssh csh examn = do ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetResultData{} -> ExamUserCsvSetResult + ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew @@ -442,6 +474,16 @@ postEUsersR tid ssh csh examn = do User{userIdent} <- getJust examRegistrationUser audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent delete examUserCsvActRegistration + ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do + noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse + whenIsJust noteId $ \nid -> do + deleteWhere [CourseUserNoteEditNote ==. nid] + delete nid + ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do + now <- liftIO getCurrentTime + uid <- liftHandlerT requireAuthId + Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] + insert_ $ CourseUserNoteEdit uid now nid return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do @@ -502,7 +544,14 @@ postEUsersR tid ssh csh examn = do $nothing , _{MsgExamResultNone} |] - + ExamUserCsvSetCourseNoteData{..} -> do + User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $if isn't _Just examUserCsvActCourseNote + \ (_{MsgExamUserCsvCourseNoteDeleted}) + |] ExamUserCsvDeregisterData{..} -> registeredUserName' examUserCsvActRegistration , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 4bb875d02..5c9f83c42 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -31,8 +31,9 @@ deriving instance Typeable CsvParseError instance Exception CsvParseError -typeCsv :: ContentType +typeCsv, typeCsv' :: ContentType typeCsv = "text/csv" +typeCsv' = "text/csv; charset=UTF-8; header=present" extensionCsv :: Extension extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] @@ -57,7 +58,7 @@ respondCsv :: ( ToNamedRecord csv ) => Source (HandlerT site IO) csv -> HandlerT site IO TypedContent -respondCsv src = respondSource typeCsv $ src .| encodeCsv .| awaitForever sendChunk +respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk respondCsvDB :: ( ToNamedRecord csv , DefaultOrdered csv @@ -65,7 +66,7 @@ respondCsvDB :: ( ToNamedRecord csv ) => Source (YesodDB site) csv -> HandlerT site IO TypedContent -respondCsvDB src = respondSourceDB typeCsv $ src .| encodeCsv .| awaitForever sendChunk +respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk fileSourceCsv :: ( FromNamedRecord csv , MonadResource m diff --git a/src/Text/Blaze/Instances.hs b/src/Text/Blaze/Instances.hs index 346b17c60..6bc967a9b 100644 --- a/src/Text/Blaze/Instances.hs +++ b/src/Text/Blaze/Instances.hs @@ -14,6 +14,8 @@ import Data.Hashable (Hashable(..)) import Data.Aeson (ToJSON(..), FromJSON(..)) import qualified Data.Aeson as Aeson +import qualified Data.Csv as Csv + instance Eq Markup where (==) = (==) `on` Text.renderMarkup @@ -35,3 +37,9 @@ instance ToJSON Markup where instance FromJSON Markup where parseJSON = Aeson.withText "Html" $ return . preEscapedText + +instance Csv.ToField Markup where + toField = Csv.toField . Text.renderMarkup + +instance Csv.FromField Markup where + parseField = fmap preEscapedText . Csv.parseField diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7ef4d33a7..dd1cea10f 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -148,6 +148,8 @@ makeLenses_ ''ExamOccurrence makePrisms ''AuthenticationMode +makeLenses_ ''CourseUserNote + -- makeClassy_ ''Load