feat(exam users): course notes
This commit is contained in:
Gregor Kleen
parent
4b61c569a9
commit
1e756be778
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -148,6 +148,8 @@ makeLenses_ ''ExamOccurrence
|
||||
|
||||
makePrisms ''AuthenticationMode
|
||||
|
||||
makeLenses_ ''CourseUserNote
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user