feat(exam users): course notes

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

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 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))
+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

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

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

src/Utils/Lens.hs

@@ -148,6 +148,8 @@ makeLenses_ ''ExamOccurrence
 
 makePrisms ''AuthenticationMode
 
+makeLenses_ ''CourseUserNote
+
 
 -- makeClassy_ ''Load