diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index f1ded3f63..be7f33c88 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -302,6 +302,40 @@ data CorrectionTableCsvSettings = forall filename sheetName. , cTableShowCorrector :: Bool } +data CorrectionTableJson = CorrectionTableJson + { jsonCorrectionTerm :: TermIdentifier + , jsonCorrectionSchool :: SchoolShorthand + , jsonCorrectionCourse :: CourseShorthand + , jsonCorrectionSheet :: SheetName + , jsonCorrectionLastEdit :: Maybe UTCTime + , jsonCorrectionSubmittors :: Maybe [CorrectionTableSubmittorJson] + , jsonCorrectionAssigned :: Maybe UTCTime + , jsonCorrectionCorrectorName :: Maybe UserDisplayName + , jsonCorrectionCorrectorEmail :: Maybe UserEmail + , jsonCorrectionRatingDone :: Bool + , jsonCorrectionRatedAt :: Maybe UTCTime + , jsonCorrectionRatingPoints :: Maybe Points + , jsonCorrectionRatingComment :: Maybe Text + } deriving (Generic) + +data CorrectionTableSubmittorJson = CorrectionTableSubmittorJson + { jsonCorrectionSurname :: UserSurname + , jsonCorrectionFirstName :: UserFirstName + , jsonCorrectionName :: UserDisplayName + , jsonCorrectionMatriculation :: Maybe UserMatriculation + , jsonCorrectionEmail :: UserEmail + , jsonCorrectionPseudonym :: Maybe Pseudonym + , jsonCorrectionSubmissionGroup :: Maybe SubmissionGroupName + , jsonCorrectionAuthorshipStatementState :: Maybe AuthorshipStatementSubmissionState + } deriving (Generic) + +deriveToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''CorrectionTableSubmittorJson + +deriveToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + } ''CorrectionTableJson -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere @@ -667,7 +701,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValida { dbtCsvExportForm = pure () , dbtCsvNoExportData = Just id , dbtCsvDoEncode = \() -> awaitForever $ \(_, row) -> runReaderC row $ do - submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName ) . toListOf resultSubmittors + submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors forM_ (bool pure (map pure) False submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do let guardNonAnonymous = runMaybeT . guardMOnM (view $ _1 . resultNonAnonymousAccess) . MaybeT yieldM $ CorrectionTableCsv @@ -697,7 +731,44 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValida , dbtCsvExampleData = Nothing } dbtCsvDecode = Nothing - dbtExtraReps = [] + dbtExtraReps = + [ DBTExtraRep $ toPrettyJSON <$> repCorrectionJson, DBTExtraRep $ toYAML <$> repCorrectionJson + ] + + repCorrectionJson :: ConduitT (E.Value SubmissionId, CorrectionTableData) Void DB (Map CryptoFileNameSubmission CorrectionTableJson) + repCorrectionJson = C.foldMap $ \(_, res) -> Map.singleton (res ^. resultCryptoID) $ mkCorrectionTableJson res + where + mkCorrectionTableJson :: CorrectionTableData -> CorrectionTableJson + mkCorrectionTableJson res' = flip runReader res' $ do + let guardNonAnonymous :: Reader CorrectionTableData (Maybe a) -> Reader CorrectionTableData (Maybe a) + guardNonAnonymous = runMaybeT . guardMOnM (view resultNonAnonymousAccess) . MaybeT + mkCorrectionTableSubmittorJson :: Reader CorrectionTableData (Maybe [CorrectionTableSubmittorJson]) + mkCorrectionTableSubmittorJson = Just <$> do + submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors + forM submittors $ \submittor -> lift . flip runReaderT submittor $ + CorrectionTableSubmittorJson + <$> view (resultUserUser . _userSurname) + <*> view (resultUserUser . _userFirstName) + <*> view (resultUserUser . _userDisplayName) + <*> view (resultUserUser . _userMatrikelnummer) + <*> view (resultUserUser . _userEmail) + <*> preview resultUserPseudonym + <*> preview resultUserSubmissionGroup + <*> preview resultUserAuthorshipStatementState + CorrectionTableJson + <$> view (resultCourseTerm . _TermId) + <*> view (resultCourseSchool . _SchoolId) + <*> view resultCourseShorthand + <*> view (resultSheet . _entityVal . _sheetName) + <*> guardNonAnonymous (preview resultLastEdit) + <*> guardNonAnonymous mkCorrectionTableSubmittorJson + <*> preview (resultSubmission . _entityVal . _submissionRatingAssigned . _Just) + <*> preview (resultCorrector . _entityVal . _userDisplayName) + <*> preview (resultCorrector . _entityVal . _userEmail) + <*> view (resultSubmission . _entityVal . to submissionRatingDone) + <*> preview (resultSubmission . _entityVal . _submissionRatingTime . _Just) + <*> preview (resultSubmission . _entityVal . _submissionRatingPoints . _Just) + <*> preview (resultSubmission . _entityVal . _submissionRatingComment . _Just) in dbTable psValidator DBTable{..} data ActionCorrections = CorrDownload diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 50bee48b8..676b64776 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -153,3 +153,4 @@ deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger rough nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 pathPieceCsv ''AuthorshipStatementSubmissionState +pathPieceJSON ''AuthorshipStatementSubmissionState