From abdc2a8926ae374f5ebd9d03c9ff995b1e1b0b76 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 16 Aug 2021 15:04:12 +0200 Subject: [PATCH 1/9] refactor(corrections-r): modernize --- package.yaml | 1 + src/Handler/Course/User.hs | 3 +- src/Handler/Submission/Grade.hs | 3 +- src/Handler/Submission/List.hs | 567 +++++++++++++------------- src/Handler/Utils/Table/Pagination.hs | 27 +- src/Import/NoModel.hs | 3 + 6 files changed, 312 insertions(+), 292 deletions(-) diff --git a/package.yaml b/package.yaml index 9b8fdec52..a2afdc4f7 100644 --- a/package.yaml +++ b/package.yaml @@ -121,6 +121,7 @@ dependencies: - http-types - jose-jwt - mono-traversable + - mono-traversable-keys - lens-aeson - systemd - streaming-commons diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 30ef678c2..65db94981 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -243,7 +243,8 @@ courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler W courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR - let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid + let whereClause :: CorrectionTableWhere + whereClause = (E.&&.) <$> courseIs cid <*> userIs uid colonnade = mconcat -- should match getSSubsR for consistent UX [ colSelect , colSheet diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 88b181f50..2ee574b5b 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -19,7 +19,8 @@ getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html getCorrectionsGradeR = postCorrectionsGradeR postCorrectionsGradeR = do uid <- requireAuthId - let whereClause = ratedBy uid + let whereClause :: CorrectionTableWhere + whereClause = ratedBy uid displayColumns = mconcat -- should match getSSubsR for consistent UX [ -- dbRow, colSchool diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 345cadd99..b8151d625 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + module Handler.Submission.List ( getCorrectionsR, postCorrectionsR , getCCorrectionsR, postCCorrectionsR @@ -7,7 +10,7 @@ module Handler.Submission.List , ratedBy, courseIs, sheetIs, userIs , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups , makeCorrectionsTable - , CorrectionTableData + , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction ) where @@ -28,7 +31,6 @@ import qualified Data.CaseInsensitive as CI import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -import qualified Database.Esqueleto.Internal.Internal as IE (From) import Text.Hamlet (ihamletFile) @@ -40,7 +42,7 @@ import Data.List (genericLength) newtype CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) } - + instance Default CorrectionTableFilterProj where def = CorrectionTableFilterProj { corrProjFilterSubmission = Nothing @@ -48,194 +50,270 @@ instance Default CorrectionTableFilterProj where makeLenses_ ''CorrectionTableFilterProj -type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) -type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool) -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -}) -correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v -correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do - E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ whereClause t - return $ returnStatement t +type CorrectionTableExpr = ( E.SqlExpr (Entity Course) + `E.InnerJoin` E.SqlExpr (Entity Sheet) + `E.InnerJoin` E.SqlExpr (Entity Submission) + ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) +type CorrectionTableWhere = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool)) +type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId) +type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName) +type CorrectionTableData = DBRow ( Entity Submission + , Entity Sheet + , CorrectionTableCourseData + , Maybe (Entity User) + , Maybe UTCTime + , Map UserId CorrectionTableUserData + , CryptoFileNameSubmission + , Bool {- Access to non-anonymous submission data -} + ) -lastEditQuery :: IE.From (E.SqlExpr (Entity SubmissionEdit)) - => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime)) -lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do - E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId - return $ E.max_ $ edit E.^. SubmissionEditTime -queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) +queryCourse :: Getter CorrectionTableExpr (E.SqlExpr (Entity Course)) +queryCourse = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) -querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission) -querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) +querySheet :: Getter CorrectionTableExpr (E.SqlExpr (Entity Sheet)) +querySheet = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) + +querySubmission :: Getter CorrectionTableExpr (E.SqlExpr (Entity Submission)) +querySubmission = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) + +queryCorrector :: Getter CorrectionTableExpr (E.SqlExpr (Maybe (Entity User))) +queryCorrector = to $(sqlLOJproj 2 2) + +queryLastEdit :: Getter CorrectionTableExpr (E.SqlExpr (E.Value (Maybe UTCTime))) +queryLastEdit = querySubmission . submissionLastEdit + where + submissionLastEdit = to $ \submission -> E.subSelectMaybe . E.from $ \edit -> do + E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId + return $ E.max_ $ edit E.^. SubmissionEditTime + + +resultSubmission :: Lens' CorrectionTableData (Entity Submission) +resultSubmission = _dbrOutput . _1 + +resultSheet :: Lens' CorrectionTableData (Entity Sheet) +resultSheet = _dbrOutput . _2 + +resultCourseName :: Lens' CorrectionTableData CourseName +resultCourseName = _dbrOutput . _3 . _1 + +resultCourseShorthand :: Lens' CorrectionTableData CourseShorthand +resultCourseShorthand = _dbrOutput . _3 . _2 + +resultCourseTerm :: Lens' CorrectionTableData TermId +resultCourseTerm = _dbrOutput . _3 . _3 + +resultCourseSchool :: Lens' CorrectionTableData SchoolId +resultCourseSchool = _dbrOutput . _3 . _4 + +resultCorrector :: Traversal' CorrectionTableData (Entity User) +resultCorrector = _dbrOutput . _4 . _Just + +resultLastEdit :: Traversal' CorrectionTableData UTCTime +resultLastEdit = _dbrOutput . _5 . _Just + +resultSubmittors :: IndexedTraversal' UserId CorrectionTableData CorrectionTableUserData +resultSubmittors = _dbrOutput . _6 . itraversed + +resultUserUser :: Lens' CorrectionTableUserData User +resultUserUser = _1 + +resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym +resultUserPseudonym = _2 . _Just + +resultUserSubmissionGroup :: Traversal' CorrectionTableUserData SubmissionGroupName +resultUserSubmissionGroup = _3 . _Just + +resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission +resultCryptoID = _dbrOutput . _7 + +resultNonAnonymousAccess :: Lens' CorrectionTableData Bool +resultNonAnonymousAccess = _dbrOutput . _8 -queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User)) -queryCorrector = $(sqlLOJproj 2 2) -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere -ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) +ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy) courseIs :: CourseId -> CorrectionTableWhere -courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid +courseIs cid = views queryCourse $ (E.==. E.val cid) . (E.^. CourseId) sheetIs :: Key Sheet -> CorrectionTableWhere -sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid +sheetIs shid = views querySheet $ (E.==. E.val shid) . (E.^. SheetId) userIs :: Key User -> CorrectionTableWhere -userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = E.exists . E.from $ \submissionUser -> +userIs uid = views querySubmission $ \submission -> E.exists . E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid + -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colTerm = sortable (Just "term") (i18nCell MsgTableTerm) - $ \DBRow{ dbrOutput } -> - textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel +colTerm = sortable (Just "term") (i18nCell MsgTableTerm) . views (resultCourseTerm . _TermId) $ textCell . termToText colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool) - $ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in - anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] +colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \x -> + let tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + in anchorCell (TermSchoolCourseListR tid ssh) + (ssh ^. _SchoolId) colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colCourse = sortable (Just "course") (i18nCell MsgTableCourse) - $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh) +colCourse = sortable (Just "course") (i18nCell MsgTableCourse) $ views ($(multifocusG 3) resultCourseTerm resultCourseSchool resultCourseShorthand) courseCellCL colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \row -> - let sheet = row ^. _dbrOutput . _2 - course= row ^. _dbrOutput . _3 - tid = course ^. _3 - ssh = course ^. _4 - csh = course ^. _2 - shn = sheetName $ entityVal sheet - in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|] +colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \x -> + let tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + csh = x ^. resultCourseShorthand + shn = x ^. resultSheet . _entityVal . _sheetName + in anchorCell (CSheetR tid ssh csh shn SShowR) shn colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \case - DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty - DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname +colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \x -> + maybeCell (x ^? resultCorrector) $ \(Entity _ User{..}) -> userCell userDisplayName userSurname colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) - $ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid, _) } -> - let csh = course ^. _2 - tid = course ^. _3 - ssh = course ^. _4 - shn = sheetName $ entityVal sheet - in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid) +colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ \x -> + let tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + csh = x ^. resultCourseShorthand + shn = x ^. resultSheet . _entityVal . _sheetName + subCID = x ^. resultCryptoID + in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId)) -colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid +colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return + colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } -> - let - csh = course ^. _2 - tid = course ^. _3 - ssh = course ^. _4 - link cid = CourseR tid ssh csh $ CUserR cid - protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo, _)) -> - anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of - Nothing -> nameWidget userDisplayName userSurname - Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|] - in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - | otherwise -> mempty +colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x -> + let tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + csh = x ^. resultCourseShorthand + link uCID = CourseR tid ssh csh $ CUserR uCID + protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \((encrypt -> mkUCID), u) -> + let User{..} = u ^. resultUserUser + mPseudo = u ^? resultUserPseudonym + in anchorCellCM $cacheIdentHere (link <$> mkUCID) $ + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe p <- mPseudo + \ (#{review _PseudonymText p}) + |] + in guardMonoid (x ^. resultNonAnonymousAccess) $ + protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } -> - let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr - in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - | otherwise -> mempty +colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \x -> + let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) wgtCell + in guardMonoid (x ^. resultNonAnonymousAccess) $ + protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } -> - let protoCell = listCell (nubOrdOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup - in if | hasAccess - , is _RegisteredGroups sheetGrouping - -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - | otherwise - -> mempty +colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \x -> + let protoCell = listCell (setOf (resultSubmittors . resultUserSubmissionGroup) x) wgtCell + in guardMonoid (x ^. resultNonAnonymousAccess) $ + protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] -colRating :: forall m a. IsDBTable m (a, SheetTypeSummary SqlBackendKey) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary SqlBackendKey)) -colRating = sortable (Just "rating") (i18nCell MsgTableRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 - ssh = course ^. _4 - -- shn = sheetName +colRating :: forall m a a'. (IsDBTable m a, a ~ (a', SheetTypeSummary SqlBackendKey)) => Colonnade Sortable CorrectionTableData (DBCell m a) +colRating = colRating' _2 - mkRoute = do - cid <- encrypt subId - return $ CSubmissionR tid ssh csh sheetName cid CorrectionR - in mconcat - [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating") - , writerCell $ do - let - summary :: SheetTypeSummary SqlBackendKey - summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub) - scribe (_2 :: Lens' (a, SheetTypeSummary SqlBackendKey) (SheetTypeSummary SqlBackendKey)) summary - ] +colRating' :: forall m a. IsDBTable m a => ASetter' a (SheetTypeSummary SqlBackendKey) -> Colonnade Sortable CorrectionTableData (DBCell m a) +colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x -> + let tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + csh = x ^. resultCourseShorthand + shn = x ^. resultSheet . _entityVal . _sheetName + cID = x ^. resultCryptoID + sub@Submission{..} = x ^. resultSubmission . _entityVal + Sheet{..} = x ^. resultSheet . _entityVal + + mkRoute = return $ CSubmissionR tid ssh csh shn cID CorrectionR + in mconcat + [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating") + , writerCell $ do + let summary :: SheetTypeSummary SqlBackendKey + summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub) + scribe l summary + ] colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } -> - maybe mempty dateTimeCell submissionRatingAssigned +colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } -> - maybe mempty dateTimeCell submissionRatingTime +colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let - lCell = listCell (catMaybes $ view (_2 . _2) <$> Map.toList users) $ \pseudo -> - cell [whamlet|#{review _PseudonymText pseudo}|] - in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] +colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \x -> + let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserPseudonym . re _PseudonymText) wgtCell + in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] -colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData))) -colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) +colRatedField :: a' ~ (Bool, a, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) +colRatedField = colRatedField' _1 -colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) -colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of - NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty) - _other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) +colRatedField' :: ASetter' a Bool -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData))) +colRatedField' l = sortable Nothing (i18nCell MsgRatingDone) $ formCell id + (views (resultSubmission . _entityKey) return) + (\(views (resultSubmission . _entityVal) submissionRatingDone -> done) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) + +colPointsField :: a' ~ (a, Maybe Points, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) +colPointsField = colPointsField' _2 + +colPointsField' :: ASetter' a (Maybe Points) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData))) +colPointsField' l = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id + (views (resultSubmission . _entityKey) return) + (\(view $ $(multifocusG 2) (resultSubmission . _entityVal) (resultSheet . _entityVal) -> (Submission{..}, Sheet{..})) mkUnique -> case sheetType of + NotGraded -> pure $ over (_1.mapped) (l .~) (FormSuccess Nothing, mempty) + _other -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) -colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) -colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{sheetCourse, sheetType}, _, _, _, _, _, _) } -> cell $ do +colMaxPointsField :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) +colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \x -> cell $ do + let Sheet{..} = x ^. resultSheet . _entityVal sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType - tr <- getTranslate - toWidget $ sheetTypeDesc tr + toWidget . sheetTypeDesc =<< getTranslate -colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id - (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) +colCommentField :: a' ~ (a, b, Maybe Text) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData))) +colCommentField = colCommentField' _3 + +colCommentField' :: ASetter' a (Maybe Text) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData))) +colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id + (views (resultSubmission . _entityKey) return) + (\(view (resultSubmission . _entityVal) -> Submission{..}) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ - \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit +colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do - let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ - dbtSQLQuery = correctionsTableQuery whereClause - (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> - let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) - , course E.^. CourseShorthand - , course E.^. CourseTerm - , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) - ) - in (submission, sheet, crse, corrector, lastEditQuery submission) - ) + let dbtSQLQuery = runReaderT $ do + course <- view queryCourse + sheet <- view querySheet + submission <- view querySubmission + corrector <- view queryCorrector + + lift $ do + E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + + lastEdit <- view queryLastEdit + + let crse = ( course E.^. CourseName + , course E.^. CourseShorthand + , course E.^. CourseTerm + , course E.^. CourseSchool + ) + + lift . E.where_ =<< whereClause + + return (submission, sheet, crse, corrector, lastEdit) dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput cid <- encrypt sId @@ -263,163 +341,77 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) + dbtRowKey = views querySubmission (E.^. SubmissionId) dbTable psValidator DBTable { dbtSQLQuery - , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId + , dbtRowKey , dbtColonnade , dbtProj - , dbtSorting = Map.fromList - [ ( "term" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm - ) - , ( "school" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool - ) - , ( "course" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand - ) - , ( "sheet" - , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName - ) - , ( "corrector" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname - ) - , ( "rating" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints - ) - , ( "sheet-type" - , SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> + , dbtSorting = mconcat + [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) + , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool) + , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand) + , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName) + , singletonMap "corrector" . SortColumns $ \x -> + [ SomeExprValue (views queryCorrector (E.?. UserSurname) x) + , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x) + ] + , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints) + , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) -> [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) ] - ) - , ( "israted" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime - ) - , ( "ratingtime" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime - ) - , ( "assignedtime" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned - ) - , ( "submittors" - , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors - ) - , ( "submittors-matriculation" - , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ Map.elems submittors - ) - , ( "submittors-group" - , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view _3) $ Map.elems submittors - ) - , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment - ) - , ( "last-edit" - , SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission - ) - , ( "submission" - , SortProjected . comparing $ toPathPiece . view (_dbrOutput . _7) - ) + , singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime) + , singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime) + , singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned) + , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x + , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x + , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x + , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done + , singletonMap "last-edit" . SortColumn $ view queryLastEdit + , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID ] - , dbtFilter = Map.fromList - [ ( "term" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - , ( "school" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) sids -> if - | Set.null sids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseSchool `E.in_` E.valList (Set.toList sids) - ) - , ( "course" - , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if - | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) - ) - , ( "sheet" - , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if - | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) - ) - , ( "sheet-search" - , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> case getLast (shns :: Last (CI Text)) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> sheet E.^. SheetName `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) - ) - , ( "corrector" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if - | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) - E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) - ) - , ( "isassigned" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just True -> E.isJust $ submission E.^. SubmissionRatingBy - Just False-> E.isNothing $ submission E.^. SubmissionRatingBy - ) - , ( "israted" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just True -> E.isJust $ submission E.^. SubmissionRatingTime - Just False-> E.isNothing $ submission E.^. SubmissionRatingTime - ) - , ( "corrector-name-email" -- corrector filter does not work for text-filtering - , FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname) - , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName) - , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail) - ] - ) - , ( "user-name-email" - , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter - [ E.mkContainsFilter (E.^. UserSurname) - , E.mkContainsFilter (E.^. UserDisplayName) - , E.mkContainsFilterWith CI.mk (E.^. UserEmail) - ] - ) - , ( "user-matriclenumber" - , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ (\f -> f user $ Set.singleton needle) $ - E.mkContainsFilter (E.^. UserMatrikelnummer) - ) - , ( "submission-group" - , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.where_ $ queryCourse table E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.where_ $ (\f -> f submissionGroup $ Set.singleton needle) $ - E.mkContainsFilter (E.^. SubmissionGroupName) - ) - , ( "rating-visible" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just True -> E.isJust $ submission E.^. SubmissionRatingTime - Just False-> E.isNothing $ submission E.^. SubmissionRatingTime - ) - , ( "rating" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if - | Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints) - ) - , ( "comment" - , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of - Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment) - ) - , ( "submission" - , FilterProjected (_corrProjFilterSubmission ?~) - -- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) -> - -- let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7 - -- criteria' = map CI.mk . unpack <$> Set.toList criteria - -- in any (`isInfixOf` cid) criteria' - ) + , dbtFilter = mconcat + [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) + , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool) + , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand) + , singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName) + , singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName) + , singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent) + , singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy)) + , singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone + , singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter + [ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname) + , E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail) + ] + , singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.anyFilter + [ E.mkContainsFilter (E.^. UserSurname) + , E.mkContainsFilter (E.^. UserDisplayName) + , E.mkContainsFilterWith CI.mk (E.^. UserEmail) + , E.mkContainsFilterWith CI.mk (E.^. UserIdent) + , E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail) + ] user (Set.singleton needle) + , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.mkContainsFilter (E.^. UserMatrikelnummer) user (Set.singleton needle) + , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse + E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle) + , singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted? + , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints) + , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) + , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI } @@ -447,7 +439,7 @@ data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous Submis | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent +correctionsR :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions @@ -455,7 +447,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") -correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) +correctionsR' :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler @@ -654,7 +646,8 @@ getCorrectionsR, postCorrectionsR :: Handler TypedContent getCorrectionsR = postCorrectionsR postCorrectionsR = do uid <- requireAuthId - let whereClause = ratedBy uid + let whereClause :: CorrectionTableWhere + whereClause = ratedBy uid colonnade = mconcat [ colSelect , colSchool @@ -701,7 +694,8 @@ getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh - let whereClause = courseIs cid + let whereClause :: CorrectionTableWhere + whereClause = courseIs cid colonnade = mconcat -- should match getSSubsR for consistent UX [ colSelect , colSheet @@ -737,7 +731,8 @@ getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> H getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do shid <- runDB $ fetchSheetId tid ssh csh shn - let whereClause = sheetIs shid + let whereClause :: CorrectionTableWhere + whereClause = sheetIs shid colonnade = mconcat -- should match getCCorrectionsR for consistent UX [ colSelect , colSMatrikel diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a3471822d..18203825d 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -45,7 +45,8 @@ module Handler.Utils.Table.Pagination , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' , cellTooltip - , listCell, listCell' + , listCell, listCell', listCellOf, listCellOf' + , ilistCell, ilistCell', ilistCellOf, ilistCellOf' , formCell, DBFormResult(..), getDBFormResult , dbSelect , (&) @@ -1793,12 +1794,30 @@ listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCel listCell = listCell' . return listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a -listCell' mkXS mkCell = review dbCell . ([], ) $ do +listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell + +ilistCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistCell = ilistCell' . return + +ilistCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a +ilistCell' mkXS mkCell = review dbCell . ([], ) $ do xs <- mkXS - cells <- forM (toList xs) $ - \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget + cells <- forM (otoKeyedList xs) $ + \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget return $(widgetFile "table/cell/list") +listCellOf :: IsDBTable m a' => Getting (Endo [a]) s a -> s -> (a -> DBCell m a') -> DBCell m a' +listCellOf l x = listCell (x ^.. l) + +listCellOf' :: IsDBTable m a' => Getting (Endo [a]) s a -> WriterT a' m s -> (a -> DBCell m a') -> DBCell m a' +listCellOf' l mkX = listCell' (toListOf l <$> mkX) + +ilistCellOf :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> s -> (i -> a -> DBCell m a') -> DBCell m a' +ilistCellOf l x = listCell (itoListOf l x) . uncurry + +ilistCellOf' :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> WriterT a' m s -> (i -> a -> DBCell m a') -> DBCell m a' +ilistCellOf' l mkX = listCell' (itoListOf l <$> mkX) . uncurry + newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a)) instance Functor (DBFormResult i a) where diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 79a6a45ca..ad0ac8f97 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -24,6 +24,7 @@ import ClassyPrelude.Yesod as Import , authorizationCheck , mkMessage, mkMessageFor, mkMessageVariant , YesodBreadcrumbs(..) + , MonoZip(..), ozipWith ) import UnliftIO.Async.Utils as Import @@ -235,6 +236,8 @@ import Data.Scientific as Import (Scientific, formatScientific) import Data.MultiSet as Import (MultiSet) +import Data.MonoTraversable.Keys as Import + import Control.Monad.Trans.RWS (RWST) From 1b6b781e82c39bc29c8984c587ac836f0da77a02 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Aug 2021 11:44:14 +0200 Subject: [PATCH 2/9] fix(corrections-r): allow filtering by matriculation --- src/Handler/Course/User.hs | 17 +++-- src/Handler/Submission/Grade.hs | 18 +++--- src/Handler/Submission/List.hs | 91 +++++++++++++++++++-------- src/Handler/Utils/Table/Pagination.hs | 7 +-- 4 files changed, 86 insertions(+), 47 deletions(-) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 65db94981..4accc76cf 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -257,15 +257,14 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do , colCorrector , colAssigned ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseCourseMembers) - , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) - -- "pseudonym" TODO DB only stores Word24 - , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector) - , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + filterUI = Just $ mconcat + [ filterUIUserNameEmail + , filterUIUserMatrikelnummer + , filterUISheetSearch + , filterUICorrectorNameEmail + , filterUIIsAssigned + , filterUIIsRated + , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 2ee574b5b..41a869ff2 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -38,15 +38,15 @@ postCorrectionsGradeR = do , colMaxPointsField , colCommentField ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) - , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm) - , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool) - , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) - , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) - , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) + filterUI = Just $ mconcat + [ filterUICourse courseOptions + , filterUITerm termOptions + , filterUISchool schoolOptions + , filterUISheetSearch + , filterUIIsRated + -- , flip (prismAForm $ singletonFilter "rating-visible" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) + , filterUIRating + , filterUIComment ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index b8151d625..99b47cdda 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -9,6 +9,7 @@ module Handler.Submission.List , restrictAnonymous, restrictCorrector , ratedBy, courseIs, sheetIs, userIs , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups + , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction @@ -289,6 +290,46 @@ colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell +filterUICourse :: Handler (OptionList Text) -> DBFilterUI +filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) + +filterUITerm :: Handler (OptionList Text) -> DBFilterUI +filterUITerm termOptions = flip (prismAForm $ singletonFilter "term") $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm) + +filterUISchool :: Handler (OptionList Text) -> DBFilterUI +filterUISchool schoolOptions = flip (prismAForm $ singletonFilter "school") $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool) + +filterUISheetSearch :: DBFilterUI +filterUISheetSearch mPrev = singletonMap "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) + +filterUIIsRated :: DBFilterUI +filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) + +filterUISubmission :: DBFilterUI +filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + +filterUIUserNameEmail :: DBFilterUI +filterUIUserNameEmail = flip (prismAForm $ singletonFilter "user-name-email") $ aopt textField (fslI MsgTableCourseMembers) + +filterUIUserMatrikelnummer :: DBFilterUI +filterUIUserMatrikelnummer = flip (prismAForm $ singletonFilter "user-matriclenumber") $ aopt textField (fslI MsgTableMatrikelNr) + +filterUICorrectorNameEmail :: DBFilterUI +filterUICorrectorNameEmail = flip (prismAForm $ singletonFilter "corrector-name-email") $ aopt textField (fslI MsgTableCorrector) + +filterUIIsAssigned :: DBFilterUI +filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) + +filterUISubmissionGroup :: DBFilterUI +filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submittors-group") $ aopt textField (fslI MsgTableSubmissionGroup) + +filterUIRating :: DBFilterUI +filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) + +filterUIComment :: DBFilterUI +filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) + + makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do @@ -401,7 +442,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.mkContainsFilter (E.^. UserMatrikelnummer) user (Set.singleton needle) + E.where_ $ E.mkContainsFilterWith Just (E.^. UserMatrikelnummer) user (Set.singleton needle) , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup @@ -663,13 +704,13 @@ postCorrectionsR = do , colRating , colRated ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) - , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm) - , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool) - , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + filterUI = Just $ mconcat + [ filterUICourse courseOptions + , filterUITerm termOptions + , filterUISchool schoolOptions + , filterUISheetSearch + , filterUIIsRated + , filterUISubmission ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) @@ -709,16 +750,16 @@ postCCorrectionsR tid ssh csh = do , colCorrector , colAssigned ] -- Continue here - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers) - , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) + filterUI = Just $ mconcat + [ filterUIUserNameEmail + , filterUIUserMatrikelnummer -- "pseudonym" TODO DB only stores Word24 - , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector) - , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + , filterUISheetSearch + , filterUICorrectorNameEmail + , filterUIIsAssigned + , filterUIIsRated + , filterUISubmissionGroup + , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList @@ -744,14 +785,14 @@ postSSubsR tid ssh csh shn = do , colCorrector , colAssigned ] - filterUI = Just $ \mPrev -> mconcat - [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers) - , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector) - , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime) - , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup) - , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + filterUI = Just $ mconcat + [ filterUIUserNameEmail + , filterUIUserMatrikelnummer + , filterUICorrectorNameEmail + , filterUIIsAssigned + , filterUIIsRated + , filterUISubmissionGroup + , filterUISubmission -- "pseudonym" TODO DB only stores Word24 ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 18203825d..50e666ed0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1171,7 +1171,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db && all (is _Just) filterSql psLimit' = bool PagesizeAll psLimit selectPagesize - rows' <- E.select . E.from $ \t -> do res <- dbtSQLQuery t @@ -1184,10 +1183,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db Nothing | PagesizeLimit l <- psLimit' , selectPagesize + , hasn't (_FormSuccess . _DBCsvExport) csvMode -> do - unless (has (_FormSuccess . _DBCsvExport) csvMode) $ - E.limit l - E.offset (psPage * l) + E.limit l + E.offset $ psPage * l Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps _other -> return () Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql From 153af8c6b4042430bb4bc120fa5c24a5d114e4c1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Aug 2021 12:30:08 +0200 Subject: [PATCH 3/9] feat(corrections-r): filter/sort by pseudonym --- .../courses/submission/de-de-formal.msg | 1 + .../categories/courses/submission/en-eu.msg | 1 + src/Handler/Course/User.hs | 1 + src/Handler/Submission/Grade.hs | 1 + src/Handler/Submission/List.hs | 24 +++++++++++++++---- 5 files changed, 23 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index 165cfe9a9..54a7795d5 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -68,6 +68,7 @@ Corrected: Korrigiert HeadingSubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen SubmissionUsers: Studenten AssignedTime: Zuteilung +SubmissionPseudonym !ident-ok: Pseudonym Pseudonyms: Pseudonyme CourseCorrectionsTitle: Korrekturen für diesen Kurs SubmissionArchiveName: abgaben diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index f9efeb3a0..e7f96147c 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -66,6 +66,7 @@ Corrected: Marked HeadingSubmissionEditHead tid ssh csh sheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Edit/Create submission SubmissionUsers: Submittors AssignedTime: Assigned +SubmissionPseudonym !ident-ok: Pseudonym Pseudonyms: Pseudonyms CourseCorrectionsTitle: Corrections for this course SubmissionArchiveName: submissions diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 4accc76cf..5db9da78b 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -260,6 +260,7 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer + , filterUIPseudonym , filterUISheetSearch , filterUICorrectorNameEmail , filterUIIsAssigned diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 41a869ff2..e848d2901 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -43,6 +43,7 @@ postCorrectionsGradeR = do , filterUITerm termOptions , filterUISchool schoolOptions , filterUISheetSearch + , filterUIPseudonym , filterUIIsRated -- , flip (prismAForm $ singletonFilter "rating-visible" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) , filterUIRating diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 99b47cdda..72bce9202 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -9,7 +9,7 @@ module Handler.Submission.List , restrictAnonymous, restrictCorrector , ratedBy, courseIs, sheetIs, userIs , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups - , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment + , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction @@ -40,13 +40,15 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) -newtype CorrectionTableFilterProj = CorrectionTableFilterProj +data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) + , corrProjFilterPseudonym :: Maybe (Set [CI Char]) } instance Default CorrectionTableFilterProj where def = CorrectionTableFilterProj { corrProjFilterSubmission = Nothing + , corrProjFilterPseudonym = Nothing } makeLenses_ ''CorrectionTableFilterProj @@ -307,6 +309,9 @@ filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _Pat filterUISubmission :: DBFilterUI filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission) + +filterUIPseudonym :: DBFilterUI +filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym) filterUIUserNameEmail :: DBFilterUI filterUIUserNameEmail = flip (prismAForm $ singletonFilter "user-name-email") $ aopt textField (fslI MsgTableCourseMembers) @@ -357,6 +362,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams return (submission, sheet, crse, corrector, lastEdit) dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput + cid <- encrypt sId forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> let haystack = map CI.mk . unpack $ toPathPiece cid @@ -377,6 +383,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') let submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors + + forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> + let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap + in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks + nonAnonymousAccess <- lift . lift $ or2M (return $ not sheetAnonymousCorrection) (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) @@ -409,6 +420,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x + , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done , singletonMap "last-edit" . SortColumn $ view queryLastEdit , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID @@ -453,6 +465,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints) , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) + , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI } @@ -705,7 +718,8 @@ postCorrectionsR = do , colRated ] -- Continue here filterUI = Just $ mconcat - [ filterUICourse courseOptions + [ filterUIPseudonym + , filterUICourse courseOptions , filterUITerm termOptions , filterUISchool schoolOptions , filterUISheetSearch @@ -753,7 +767,7 @@ postCCorrectionsR tid ssh csh = do filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer - -- "pseudonym" TODO DB only stores Word24 + , filterUIPseudonym , filterUISheetSearch , filterUICorrectorNameEmail , filterUIIsAssigned @@ -788,12 +802,12 @@ postSSubsR tid ssh csh shn = do filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer + , filterUIPseudonym , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated , filterUISubmissionGroup , filterUISubmission - -- "pseudonym" TODO DB only stores Word24 ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList From 57ea5fe329e3013bff83fffb2f8ad999cf9f5b6f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Aug 2021 12:46:27 +0200 Subject: [PATCH 4/9] refactor(corrections-r): modernize --- src/Handler/Submission/List.hs | 244 ++++++++++++++++----------------- 1 file changed, 119 insertions(+), 125 deletions(-) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72bce9202..a9959fdd1 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -337,144 +337,138 @@ filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoi makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do - let dbtSQLQuery = runReaderT $ do - course <- view queryCourse - sheet <- view querySheet - submission <- view querySubmission - corrector <- view queryCorrector +makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams + = let dbtSQLQuery = runReaderT $ do + course <- view queryCourse + sheet <- view querySheet + submission <- view querySubmission + corrector <- view queryCorrector - lift $ do - E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + lift $ do + E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - lastEdit <- view queryLastEdit + lastEdit <- view queryLastEdit - let crse = ( course E.^. CourseName - , course E.^. CourseShorthand - , course E.^. CourseTerm - , course E.^. CourseSchool - ) + let crse = ( course E.^. CourseName + , course E.^. CourseShorthand + , course E.^. CourseTerm + , course E.^. CourseSchool + ) - lift . E.where_ =<< whereClause + lift . E.where_ =<< whereClause - return (submission, sheet, crse, corrector, lastEdit) - dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do - (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput + return (submission, sheet, crse, corrector, lastEdit) + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput - cid <- encrypt sId - forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> - let haystack = map CI.mk . unpack $ toPathPiece cid - in guard $ any (`isInfixOf` haystack) criteria + cid <- encrypt sId + forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> + let haystack = map CI.mk . unpack $ toPathPiece cid + in guard $ any (`isInfixOf` haystack) criteria - submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do - E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) - E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId - E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] - let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId - return . E.just $ submissionGroup E.^. SubmissionGroupName + submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do + E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) + E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId + E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] + let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId + return . E.just $ submissionGroup E.^. SubmissionGroupName - return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') - let - submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors + return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') + let + submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors - forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> - let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap - in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks + forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> + let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap + in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks - nonAnonymousAccess <- lift . lift $ or2M - (return $ not sheetAnonymousCorrection) - (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) + nonAnonymousAccess <- lift . lift $ or2M + (return $ not sheetAnonymousCorrection) + (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) - dbtRowKey = views querySubmission (E.^. SubmissionId) - dbTable psValidator DBTable - { dbtSQLQuery - , dbtRowKey - , dbtColonnade - , dbtProj - , dbtSorting = mconcat - [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) - , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool) - , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand) - , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName) - , singletonMap "corrector" . SortColumns $ \x -> - [ SomeExprValue (views queryCorrector (E.?. UserSurname) x) - , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x) + return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) + dbtRowKey = views querySubmission (E.^. SubmissionId) + dbtSorting = mconcat + [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) + , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool) + , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand) + , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName) + , singletonMap "corrector" . SortColumns $ \x -> + [ SomeExprValue (views queryCorrector (E.?. UserSurname) x) + , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x) + ] + , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints) + , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) -> + [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) + , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) + , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) + ] + , singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime) + , singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime) + , singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned) + , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x + , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x + , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x + , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x + , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done + , singletonMap "last-edit" . SortColumn $ view queryLastEdit + , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID ] - , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints) - , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) -> - [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) - , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) - , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) + dbtFilter = mconcat + [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) + , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool) + , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand) + , singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName) + , singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName) + , singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent) + , singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy)) + , singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone + , singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter + [ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname) + , E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent) + , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail) + ] + , singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.anyFilter + [ E.mkContainsFilter (E.^. UserSurname) + , E.mkContainsFilter (E.^. UserDisplayName) + , E.mkContainsFilterWith CI.mk (E.^. UserEmail) + , E.mkContainsFilterWith CI.mk (E.^. UserIdent) + , E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail) + ] user (Set.singleton needle) + , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.mkContainsFilterWith Just (E.^. UserMatrikelnummer) user (Set.singleton needle) + , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse + E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle) + , singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted? + , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints) + , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) + , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) + , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) ] - , singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime) - , singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime) - , singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned) - , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x - , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x - , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x - , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x - , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done - , singletonMap "last-edit" . SortColumn $ view queryLastEdit - , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID - ] - , dbtFilter = mconcat - [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) - , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool) - , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand) - , singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName) - , singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName) - , singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent) - , singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy)) - , singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone - , singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter - [ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname) - , E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName) - , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail) - , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent) - , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail) - ] - , singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.anyFilter - [ E.mkContainsFilter (E.^. UserSurname) - , E.mkContainsFilter (E.^. UserDisplayName) - , E.mkContainsFilterWith CI.mk (E.^. UserEmail) - , E.mkContainsFilterWith CI.mk (E.^. UserIdent) - , E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail) - ] user (Set.singleton needle) - , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.mkContainsFilterWith Just (E.^. UserMatrikelnummer) user (Set.singleton needle) - , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle) - , singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted? - , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints) - , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) - , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) - , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) - ] - , dbtFilterUI = fromMaybe mempty dbtFilterUI - , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI } - , dbtParams - , dbtIdent = "corrections" :: Text - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - , dbtExtraReps = [] - } + dbtFilterUI = fromMaybe mempty dbtFilterUI' + dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } + dbtIdent = "corrections" :: Text + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + in dbTable psValidator DBTable{..} data ActionCorrections = CorrDownload | CorrSetCorrector From 51522efc7c9915115e0d8791320a03e35d2933c8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 17 Aug 2021 14:38:52 +0200 Subject: [PATCH 5/9] feat(corrections-r): authorship statement state --- src/Handler/Submission/Grade.hs | 2 +- src/Handler/Submission/Helper.hs | 32 +-------- src/Handler/Submission/List.hs | 120 ++++++++++++++++++++++--------- src/Handler/Utils/Submission.hs | 58 +++++++++++++++ 4 files changed, 147 insertions(+), 65 deletions(-) diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index e848d2901..1ddb8019e 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -62,7 +62,7 @@ postCorrectionsGradeR = do & restrictAnonymous & restrictCorrector & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) - unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) + unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index c78335edf..3b6521f1b 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -31,18 +31,6 @@ import Handler.Submission.SubmissionUserInvite import qualified Data.Conduit.Combinators as C -data AuthorshipStatementSubmissionState - = ASExists - | ASOldStatement - | ASMissing - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) - -nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 - -embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel - - makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget)) @@ -606,28 +594,10 @@ submissionHelper tid ssh csh shn mcid = do subUsers <- maybeT (return []) $ do subId <- hoistMaybe msmid - let - getUserAuthorshipStatement :: UserId - -> DB AuthorshipStatementSubmissionState - getUserAuthorshipStatement uid = runConduit $ - getStmts - .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint) - where - getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do - E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId - E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid - return authorshipStatementSubmission - toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any - toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement - toRes :: Maybe Any -> AuthorshipStatementSubmissionState - toRes = \case - Just (Any True) -> ASExists - Just (Any False) -> ASOldStatement - Nothing -> ASMissing lift $ buddies & bool id (maybe id (Set.insert . Right) muid) isOwner & Set.toList - & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid) + & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid) & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1) subUsersVisible <- orM diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index a9959fdd1..14f1fdb29 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -8,8 +8,9 @@ module Handler.Submission.List , correctionsR' , restrictAnonymous, restrictCorrector , ratedBy, courseIs, sheetIs, userIs - , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups - , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym + , resultSubmission + , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups, colAuthorshipStatementState + , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym, filterUIAuthorshipStatementState , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction @@ -33,6 +34,8 @@ import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E +import qualified Data.Conduit.Combinators as C + import Text.Hamlet (ihamletFile) import Database.Persist.Sql (updateWhereCount) @@ -43,12 +46,14 @@ import Data.List (genericLength) data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) , corrProjFilterPseudonym :: Maybe (Set [CI Char]) + , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState } instance Default CorrectionTableFilterProj where def = CorrectionTableFilterProj { corrProjFilterSubmission = Nothing , corrProjFilterPseudonym = Nothing + , corrProjFilterAuthorshipStatementState = Last Nothing } makeLenses_ ''CorrectionTableFilterProj @@ -70,6 +75,7 @@ type CorrectionTableData = DBRow ( Entity Submission , Map UserId CorrectionTableUserData , CryptoFileNameSubmission , Bool {- Access to non-anonymous submission data -} + , Maybe AuthorshipStatementSubmissionState ) @@ -135,6 +141,9 @@ resultCryptoID = _dbrOutput . _7 resultNonAnonymousAccess :: Lens' CorrectionTableData Bool resultNonAnonymousAccess = _dbrOutput . _8 +resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState) +resultASState = _dbrOutput . _9 + -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere @@ -291,6 +300,22 @@ colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (ce colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell +colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) +colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x -> + let heatC :: AuthorshipStatementSubmissionState -> DBCell m a -> DBCell m a + heatC s c + = c + & cellAttrs %~ addAttrsClass "heated" + & cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (s /= ASExists))}|]) + tid = x ^. resultCourseTerm + ssh = x ^. resultCourseSchool + csh = x ^. resultCourseShorthand + shn = x ^. resultSheet . _entityVal . _sheetName + cID = x ^. resultCryptoID + + asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR + in maybeCell (x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) + filterUICourse :: Handler (OptionList Text) -> DBFilterUI filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse) @@ -326,7 +351,7 @@ filterUIIsAssigned :: DBFilterUI filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector) filterUISubmissionGroup :: DBFilterUI -filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submittors-group") $ aopt textField (fslI MsgTableSubmissionGroup) +filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submission-group") $ aopt textField (fslI MsgTableSubmissionGroup) filterUIRating :: DBFilterUI filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) @@ -334,6 +359,9 @@ filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathP filterUIComment :: DBFilterUI filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) +filterUIAuthorshipStatementState :: DBFilterUI +filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" . maybePrism _PathPiece) $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ AuthorshipStatementSubmissionState) (fslI MsgSubmissionUserAuthorshipStatementState) + makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) @@ -368,6 +396,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams let haystack = map CI.mk . unpack $ toPathPiece cid in guard $ any (`isInfixOf` haystack) criteria + mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet + asState <- for mASDefinition $ \_ -> + lift . lift . $cachedHereBinary sId $ getSubmissionAuthorshipStatement mASDefinition sId + + forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> + guard $ asState == Just criterion + submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) @@ -392,7 +427,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams (return $ not sheetAnonymousCorrection) (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) + return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess, asState) dbtRowKey = views querySubmission (E.^. SubmissionId) dbtSorting = mconcat [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm) @@ -418,7 +453,8 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done , singletonMap "last-edit" . SortColumn $ view queryLastEdit - , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID + , singletonMap "submission" . SortProjected . comparing $ views resultCryptoID toPathPiece + , singletonMap "as-state" . SortProjected . comparing $ view resultASState ] dbtFilter = mconcat [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm) @@ -461,6 +497,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment) , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~) , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~) + , singletonMap "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~) ] dbtFilterUI = fromMaybe mempty dbtFilterUI' dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } @@ -742,31 +779,41 @@ postCorrectionsR = do getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do - Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh + (Entity cid _, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do + course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh + doSubmissionGroups <- exists [SubmissionGroupCourse ==. cid] + doAuthorshipStatements <- runConduit $ + (E.selectSource . E.from $ \sheet -> sheet <$ E.where_ (sheet E.^. SheetCourse E.==. E.val cid)) + .| C.mapM getSheetAuthorshipStatement + .| C.map (is _Just) + .| C.or + return (course, doSubmissionGroups, doAuthorshipStatements) let whereClause :: CorrectionTableWhere whereClause = courseIs cid - colonnade = mconcat -- should match getSSubsR for consistent UX - [ colSelect - , colSheet - , colSMatrikel - , colSubmittors - , colSGroups - , colSubmissionLink - , colLastEdit - , colRating - , colRated - , colCorrector - , colAssigned + colonnade = mconcat $ catMaybes -- should match getSSubsR for consistent UX + [ pure colSelect + , pure colSheet + , pure colSMatrikel + , pure colSubmittors + , guardOn doSubmissionGroups colSGroups + , pure colSubmissionLink + , pure colLastEdit + , guardOn doAuthorshipStatements colAuthorshipStatementState + , pure colRating + , pure colRated + , pure colCorrector + , pure colAssigned ] -- Continue here filterUI = Just $ mconcat - [ filterUIUserNameEmail + [ filterUISheetSearch + , filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym - , filterUISheetSearch + , filterUISubmissionGroup + , filterUIAuthorshipStatementState , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated - , filterUISubmissionGroup , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway @@ -779,28 +826,35 @@ postCCorrectionsR tid ssh csh = do getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do - shid <- runDB $ fetchSheetId tid ssh csh shn + (shid, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do + sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn + doSubmissionGroups <- exists [SubmissionGroupCourse ==. sheetCourse] + doAuthorshipStatements <- is _Just <$> getSheetAuthorshipStatement sheet + return (shid, doSubmissionGroups, doAuthorshipStatements) let whereClause :: CorrectionTableWhere whereClause = sheetIs shid - colonnade = mconcat -- should match getCCorrectionsR for consistent UX - [ colSelect - , colSMatrikel - , colSubmittors - , colSubmissionLink - , colLastEdit - , colRating - , colRated - , colCorrector - , colAssigned + colonnade = mconcat $ catMaybes -- should match getCCorrectionsR for consistent UX + [ pure colSelect + , pure colSMatrikel + , pure colSubmittors + , guardOn doSubmissionGroups colSGroups + , pure colSubmissionLink + , pure colLastEdit + , guardOn doAuthorshipStatements colAuthorshipStatementState + , pure colRating + , pure colRated + , pure colCorrector + , pure colAssigned ] filterUI = Just $ mconcat [ filterUIUserNameEmail , filterUIUserMatrikelnummer , filterUIPseudonym + , filterUISubmissionGroup + , filterUIAuthorshipStatementState , filterUICorrectorNameEmail , filterUIIsAssigned , filterUIIsRated - , filterUISubmissionGroup , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 1d5e5ab7a..96a0710f9 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -11,6 +11,8 @@ module Handler.Utils.Submission , submissionMatchesSheet , submissionDeleteRoute , correctionInvisibleWidget + , AuthorshipStatementSubmissionState(..) + , getUserAuthorshipStatement, getSubmissionAuthorshipStatement ) where import Import hiding (joinPath) @@ -36,6 +38,7 @@ import Handler.Utils import qualified Handler.Utils.Rating as Rating (extractRatings) import Handler.Utils.Delete +import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils.TH as E @@ -976,3 +979,58 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d tellPoint CorrectionInvisibleExamUnfinished return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible") + + +data AuthorshipStatementSubmissionState + = ASMissing + | ASOldStatement + | ASExists + deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max` + +nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel + + +getUserAuthorshipStatement :: ( MonadResource m + , IsSqlBackend backend, SqlBackendCanRead backend + ) + => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement` + -> SubmissionId + -> UserId + -> ReaderT backend m AuthorshipStatementSubmissionState +getUserAuthorshipStatement mASDefinition subId uid = runConduit $ + getStmts + .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint) + where + getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do + E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId + E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid + return authorshipStatementSubmission + toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any + toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement + toRes :: Maybe Any -> AuthorshipStatementSubmissionState + toRes = \case + Just (Any True) -> ASExists + Just (Any False) -> ASOldStatement + Nothing -> ASMissing + +getSubmissionAuthorshipStatement :: ( MonadResource m + , IsSqlBackend backend, SqlBackendCanRead backend + ) + => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement` + -> SubmissionId + -> ReaderT backend m AuthorshipStatementSubmissionState +getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $ + sourceSubmissionUsers + .| C.map E.unValue + .| C.mapM getUserAuthorshipStatement' + .| C.maximum + where + getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId + sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId + return $ submissionUser E.^. SubmissionUserUser From 2a6248e3d5d4f4de5f1c7d6c6bcf092dc9873a2e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Aug 2021 16:54:50 +0200 Subject: [PATCH 6/9] feat(corrections-r): csv export Fixes #705 --- .../courses/submission/de-de-formal.msg | 33 ++- .../categories/courses/submission/en-eu.msg | 31 ++ src/Data/Scientific/Instances.hs | 4 +- src/Data/Word/Word24/Instances.hs | 7 + src/Foundation/I18n.hs | 2 + src/Handler/Course/User.hs | 10 +- src/Handler/Course/Users.hs | 10 +- src/Handler/Submission/Grade.hs | 2 +- src/Handler/Submission/List.hs | 269 ++++++++++++++++-- src/Handler/Utils/StudyFeatures.hs | 4 +- src/Handler/Utils/Submission.hs | 14 - src/Model/Types/DateTime.hs | 2 + src/Model/Types/Submission.hs | 23 ++ src/Utils/Csv.hs | 36 +++ ...corrections-csv-export.de-de-formal.hamlet | 2 + .../corrections-csv-export.en-eu.hamlet | 2 + test/Data/Scientific/InstancesSpec.hs | 10 + test/Utils/CsvSpec.hs | 38 +++ 18 files changed, 444 insertions(+), 55 deletions(-) create mode 100644 templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/corrections-csv-export.en-eu.hamlet create mode 100644 test/Data/Scientific/InstancesSpec.hs create mode 100644 test/Utils/CsvSpec.hs diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index 54a7795d5..b2b734946 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -228,4 +228,35 @@ SubmissionColumnAuthorshipStatementTime: Zeitstempel SubmissionColumnAuthorshipStatementWording: Wortlaut SubmissionFilterAuthorshipStatementCurrent: Aktueller Wortlaut -SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer! \ No newline at end of file +SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer! + +CsvColumnCorrectionTerm: Semester des Kurses der Abgabe +CsvColumnCorrectionSchool: Institut des Kurses der Abgabe +CsvColumnCorrectionCourse: Kürzel des Kurses der Abgabe +CsvColumnCorrectionSheet: Name des Übungsblatts der Abgabe +CsvColumnCorrectionSubmission: Nummer der Abgabe (uwa…) +CsvColumnCorrectionSurname: Nachnamen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionFirstName: Vornamen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionName: Volle Namen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionMatriculation: Matrikelnummern der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionEmail: E-Mail Adressen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionPseudonym: Abgabe-Pseudonyme der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionSubmissionGroup: Feste Abgabegruppen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionAuthorshipStatementState: Zustände der Eigenständigkeitserklärungen ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}" oder "#{toPathPiece ASExists}") als Semikolon (;) separierte Liste +CsvColumnCorrectionCorrectorName: Voller Name des Korrektors der Abgabe +CsvColumnCorrectionCorrectorEmail: E-Mail Adresse des Korrektors der Abgabe +CsvColumnCorrectionRatingDone: Bewertung abgeschlossen ("t"/"f") +CsvColumnCorrectionRatedAt: Zeitpunkt der Bewertung (ISO 8601) +CsvColumnCorrectionAssigned: Zeitpunkt der Zuteilung des Korrektors (ISO 8601) +CsvColumnCorrectionLastEdit: Zeitpunkt der letzten Änderung der Abgabe (ISO 8601) +CsvColumnCorrectionRatingPoints: Erreichte Punktezahl (Für “_{MsgSheetGradingPassBinary}” entspricht 0 “_{MsgRatingNotPassed}” und alles andere “_{MsgRatingPassed}”) +CsvColumnCorrectionRatingComment: Bewertungskommentar + +CorrectionTableCsvNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-abgaben +CorrectionTableCsvSheetNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Abgaben +CorrectionTableCsvNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-abgaben +CorrectionTableCsvSheetNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Abgaben +CorrectionTableCsvNameCorrections: abgaben +CorrectionTableCsvSheetNameCorrections: Abgaben +CorrectionTableCsvNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-abgaben +CorrectionTableCsvSheetNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Abgaben \ No newline at end of file diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index e7f96147c..1e9adbd3b 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -228,3 +228,34 @@ SubmissionColumnAuthorshipStatementWording: Wording SubmissionFilterAuthorshipStatementCurrent: Current wording SubmissionNoUsers: This submission has no associated users! + +CsvColumnCorrectionTerm: Term of the course of the submission +CsvColumnCorrectionSchool: School of the course of the submission +CsvColumnCorrectionCourse: Shorthand of the course of the submission +CsvColumnCorrectionSheet: Name of the sheet of the submission +CsvColumnCorrectionSubmission: Number of the submission (uwa…) +CsvColumnCorrectionSurname: Submittor's surnames, separated by semicolon (;) +CsvColumnCorrectionFirstName: Submittor's first names, separated by semicolon (;) +CsvColumnCorrectionName: Submittor's full names, separated by semicolon (;) +CsvColumnCorrectionMatriculation: Submittor's matriculations, separated by semicolon (;) +CsvColumnCorrectionEmail: Submittor's email addresses, separated by semicolon (;) +CsvColumnCorrectionPseudonym: Submittor's submission pseudonyms, separated by semicolon (;) +CsvColumnCorrectionSubmissionGroup: Submittor's submisson groups, separated by semicolon (;) +CsvColumnCorrectionAuthorshipStatementState: States of the statements of authorship ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}", or "#{toPathPiece ASExists}"), separated by semicolon (;) +CsvColumnCorrectionCorrectorName: Full name of the corrector of the submission +CsvColumnCorrectionCorrectorEmail: Email address of the corrector of the submission +CsvColumnCorrectionRatingDone: Rating done ("t"/"f") +CsvColumnCorrectionRatedAt: Timestamp of rating (ISO 8601) +CsvColumnCorrectionAssigned: Timestamp of when corrector was assigned (ISO 8601) +CsvColumnCorrectionLastEdit: Timestamp of the last edit of the submission (ISO 8601) +CsvColumnCorrectionRatingPoints: Achieved points (for “_{MsgSheetGradingPassBinary}” 0 means “_{MsgRatingNotPassed}”, everything else means “_{MsgRatingPassed}”) +CsvColumnCorrectionRatingComment: Rating comment + +CorrectionTableCsvNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-submissions +CorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Submissions +CorrectionTableCsvNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-submissions +CorrectionTableCsvSheetNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Submissions +CorrectionTableCsvNameCorrections: submissions +CorrectionTableCsvSheetNameCorrections: Submissions +CorrectionTableCsvNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-submissions +CorrectionTableCsvSheetNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Submissions diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs index cee91482d..8c0c83e89 100644 --- a/src/Data/Scientific/Instances.hs +++ b/src/Data/Scientific/Instances.hs @@ -9,7 +9,9 @@ import Data.Scientific import Web.PathPieces +import Text.ParserCombinators.ReadP (readP_to_S) + instance PathPiece Scientific where toPathPiece = pack . formatScientific Fixed Nothing - fromPathPiece = readFromPathPiece + fromPathPiece = fmap fst . listToMaybe . filter (\(_, rStr) -> null rStr) . readP_to_S scientificP . unpack diff --git a/src/Data/Word/Word24/Instances.hs b/src/Data/Word/Word24/Instances.hs index e1d6add1a..b80cdc620 100644 --- a/src/Data/Word/Word24/Instances.hs +++ b/src/Data/Word/Word24/Instances.hs @@ -12,6 +12,8 @@ import System.Random (Random(..)) import Data.Aeson (FromJSON(..), ToJSON(..)) import qualified Data.Aeson.Types as Aeson +import Web.PathPieces + import Data.Word.Word24 import Control.Lens @@ -19,6 +21,7 @@ import Control.Lens import Control.Monad.Fail import qualified Data.Scientific as Scientific +import Data.Scientific.Instances () import Data.Binary import Data.Bits @@ -51,6 +54,10 @@ instance FromJSON Word24 where instance ToJSON Word24 where toJSON = Aeson.Number . fromIntegral +instance PathPiece Word24 where + toPathPiece p = toPathPiece (fromIntegral p :: Word32) + fromPathPiece = Scientific.toBoundedInteger <=< fromPathPiece + -- | Big Endian instance Binary Word24 where diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 9dc051554..f85cc309a 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -308,6 +308,8 @@ embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" embedRenderMessage ''UniWorX ''SchoolAuthorshipStatementMode id embedRenderMessage ''UniWorX ''SheetAuthorshipStatementMode id +embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel + newtype ShortSex = ShortSex Sex embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 5db9da78b..7ef122422 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -240,7 +240,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget -courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do +courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid User{..}) = do guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR let whereClause :: CorrectionTableWhere @@ -268,7 +268,13 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifySheet + , cTableCsvName = MsgCorrectionTableCsvNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName + , cTableShowCorrector = True + } + (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 2a12a905c..0d25a488b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -197,17 +197,13 @@ instance Csv.ToNamedRecord UserTableCsv where , "email" Csv..= csvUserEmail , "study-features" Csv..= csvUserStudyFeatures , "submission-group" Csv..= csvUserSubmissionGroup - ] ++ - [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1 - in "tutorial" Csv..= tutsStr + , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1) ] ++ [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut) | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2 ] ++ - [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams - in "exams" Csv..= examsStr - ] ++ - [ "registration" Csv..= csvUserRegistration + [ "exams" Csv..= CsvSemicolonList csvUserExams + , "registration" Csv..= csvUserRegistration ] ++ [ encodeUtf8 (CI.foldedCase shn) Csv..= res | (shn, res) <- Map.toList csvUserSheets diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 1ddb8019e..d805b574e 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -64,7 +64,7 @@ postCorrectionsGradeR = do & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) - (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def + (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI Nothing psValidator $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR } diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 14f1fdb29..f1ded3f63 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -14,6 +14,7 @@ module Handler.Submission.List , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction + , CorrectionTableCsvQualification(..), CorrectionTableCsvSettings(..) ) where import Import hiding (link) @@ -23,7 +24,6 @@ import Handler.Utils.Submission import Handler.Utils.SheetType import Handler.Utils.Delete -import Data.List as List (foldr) import qualified Data.Set as Set import qualified Data.Map.Strict as Map @@ -42,6 +42,8 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) +import qualified Data.Csv as Csv + data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) @@ -66,7 +68,7 @@ type CorrectionTableExpr = ( E.SqlExpr (Entity Course) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableWhere = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool)) type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId) -type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName) +type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName, Maybe AuthorshipStatementSubmissionState) type CorrectionTableData = DBRow ( Entity Submission , Entity Sheet , CorrectionTableCourseData @@ -135,6 +137,9 @@ resultUserPseudonym = _2 . _Just resultUserSubmissionGroup :: Traversal' CorrectionTableUserData SubmissionGroupName resultUserSubmissionGroup = _3 . _Just +resultUserAuthorshipStatementState :: Traversal' CorrectionTableUserData AuthorshipStatementSubmissionState +resultUserAuthorshipStatementState = _4 . _Just + resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission resultCryptoID = _dbrOutput . _7 @@ -145,6 +150,159 @@ resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionS resultASState = _dbrOutput . _9 +data CorrectionTableCsv = CorrectionTableCsv + { csvCorrectionTerm :: Maybe TermIdentifier + , csvCorrectionSchool :: Maybe SchoolShorthand + , csvCorrectionCourse :: Maybe CourseShorthand + , csvCorrectionSheet :: Maybe SheetName + , csvCorrectionSubmission :: Maybe (CI Text) + , csvCorrectionLastEdit :: Maybe UTCTime + , csvCorrectionSurname :: Maybe [Maybe UserSurname] + , csvCorrectionFirstName :: Maybe [Maybe UserFirstName] + , csvCorrectionName :: Maybe [Maybe UserDisplayName] + , csvCorrectionMatriculation :: Maybe [Maybe UserMatriculation] + , csvCorrectionEmail :: Maybe [Maybe UserEmail] + , csvCorrectionPseudonym :: Maybe [Maybe Pseudonym] + , csvCorrectionSubmissionGroup :: Maybe [Maybe SubmissionGroupName] + , csvCorrectionAuthorshipStatementState :: Maybe [Maybe AuthorshipStatementSubmissionState] + , csvCorrectionAssigned :: Maybe UTCTime + , csvCorrectionCorrectorName :: Maybe UserDisplayName + , csvCorrectionCorrectorEmail :: Maybe UserEmail + , csvCorrectionRatingDone :: Maybe Bool + , csvCorrectionRatedAt :: Maybe UTCTime + , csvCorrectionRatingPoints :: Maybe Points + , csvCorrectionRatingComment :: Maybe Text + } deriving (Generic) +makeLenses_ ''CorrectionTableCsv + +correctionTableCsvOptions :: Csv.Options +correctionTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 } + +instance Csv.ToNamedRecord CorrectionTableCsv where + toNamedRecord CorrectionTableCsv{..} = Csv.namedRecord + [ "term" Csv..= csvCorrectionTerm + , "school" Csv..= csvCorrectionSchool + , "course" Csv..= csvCorrectionCourse + , "sheet" Csv..= csvCorrectionSheet + , "submission" Csv..= csvCorrectionSubmission + , "last-edit" Csv..= csvCorrectionLastEdit + , "surname" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionSurname + , "first-name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionFirstName + , "name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionName + , "matriculation" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionMatriculation + , "email" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionEmail + , "pseudonym" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionPseudonym + , "submission-group" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionSubmissionGroup + , "authorship-statement-state" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionAuthorshipStatementState + , "assigned" Csv..= csvCorrectionAssigned + , "corrector-name" Csv..= csvCorrectionCorrectorName + , "corrector-email" Csv..= csvCorrectionCorrectorEmail + , "rating-done" Csv..= csvCorrectionRatingDone + , "rated-at" Csv..= csvCorrectionRatedAt + , "rating-points" Csv..= csvCorrectionRatingPoints + , "rating-comment" Csv..= csvCorrectionRatingComment + ] + where + mkEmpty = \case + [Nothing] -> [] + x -> x + +instance Csv.DefaultOrdered CorrectionTableCsv where + headerOrder = Csv.genericHeaderOrder correctionTableCsvOptions + +instance Csv.FromNamedRecord CorrectionTableCsv where + parseNamedRecord csv + = CorrectionTableCsv + <$> csv .:?? "term" + <*> csv .:?? "school" + <*> csv .:?? "course" + <*> csv .:?? "sheet" + <*> csv .:?? "submission" + <*> csv .:?? "last-edit" + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "surname") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "first-name") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "name") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "matriculation") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "email") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "pseudonym") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "submission-group") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "authorship-statement-state") + <*> csv .:?? "assigned" + <*> csv .:?? "corrector-name" + <*> csv .:?? "corrector-email" + <*> csv .:?? "rating-done" + <*> csv .:?? "rated-at" + <*> csv .:?? "rating-points" + <*> csv .:?? "rating-comment" + +instance CsvColumnsExplained CorrectionTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations correctionTableCsvOptions $ Map.fromList + [ ('csvCorrectionTerm , MsgCsvColumnCorrectionTerm) + , ('csvCorrectionSchool , MsgCsvColumnCorrectionSchool) + , ('csvCorrectionCourse , MsgCsvColumnCorrectionCourse) + , ('csvCorrectionSheet , MsgCsvColumnCorrectionSheet) + , ('csvCorrectionSubmission , MsgCsvColumnCorrectionSubmission) + , ('csvCorrectionLastEdit , MsgCsvColumnCorrectionLastEdit) + , ('csvCorrectionSurname , MsgCsvColumnCorrectionSurname) + , ('csvCorrectionFirstName , MsgCsvColumnCorrectionFirstName) + , ('csvCorrectionName , MsgCsvColumnCorrectionName) + , ('csvCorrectionMatriculation , MsgCsvColumnCorrectionMatriculation) + , ('csvCorrectionEmail , MsgCsvColumnCorrectionEmail) + , ('csvCorrectionPseudonym , MsgCsvColumnCorrectionPseudonym) + , ('csvCorrectionSubmissionGroup, MsgCsvColumnCorrectionSubmissionGroup) + , ('csvCorrectionAuthorshipStatementState, MsgCsvColumnCorrectionAuthorshipStatementState) + , ('csvCorrectionAssigned , MsgCsvColumnCorrectionAssigned) + , ('csvCorrectionCorrectorName , MsgCsvColumnCorrectionCorrectorName) + , ('csvCorrectionCorrectorEmail , MsgCsvColumnCorrectionCorrectorEmail) + , ('csvCorrectionRatingDone , MsgCsvColumnCorrectionRatingDone) + , ('csvCorrectionRatedAt , MsgCsvColumnCorrectionRatedAt) + , ('csvCorrectionRatingPoints , MsgCsvColumnCorrectionRatingPoints) + , ('csvCorrectionRatingComment , MsgCsvColumnCorrectionRatingComment) + ] + +data CorrectionTableCsvQualification + = CorrectionTableCsvNoQualification + | CorrectionTableCsvQualifySheet + | CorrectionTableCsvQualifyCourse + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +correctionTableCsvHeader :: Bool -- ^ @showCorrector@ + -> CorrectionTableCsvQualification -> Csv.Header +correctionTableCsvHeader showCorrector qual = Csv.header $ catMaybes + [ guardOn (qual >= CorrectionTableCsvQualifyCourse) "term" + , guardOn (qual >= CorrectionTableCsvQualifyCourse) "school" + , guardOn (qual >= CorrectionTableCsvQualifyCourse) "course" + , guardOn (qual >= CorrectionTableCsvQualifySheet) "sheet" + , pure "submission" + , pure "last-edit" + , pure "surname" + , pure "first-name" + , pure "name" + , pure "matriculation" + , pure "email" + , pure "pseudonym" + , pure "submission-group" + , pure "authorship-statement-state" + , pure "assigned" + , guardOn showCorrector "corrector-name" + , guardOn showCorrector "corrector-email" + , pure "rating-done" + , pure "rated-at" + , pure "rating-points" + , pure "rating-comment" + ] + +data CorrectionTableCsvSettings = forall filename sheetName. + ( RenderMessage UniWorX filename, RenderMessage UniWorX sheetName + ) => CorrectionTableCsvSettings + { cTableCsvQualification :: CorrectionTableCsvQualification + , cTableCsvName :: filename + , cTableCsvSheetName :: sheetName + , cTableShowCorrector :: Bool + } + + -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy) @@ -206,10 +364,10 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ssh = x ^. resultCourseSchool csh = x ^. resultCourseShorthand link uCID = CourseR tid ssh csh $ CUserR uCID - protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \((encrypt -> mkUCID), u) -> + protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \(encrypt -> mkUCID, u) -> let User{..} = u ^. resultUserUser mPseudo = u ^? resultUserPseudonym - in anchorCellCM $cacheIdentHere (link <$> mkUCID) $ + in anchorCellCM $cacheIdentHere (link <$> mkUCID) [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -298,7 +456,7 @@ colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (ce (\(view (resultSubmission . _entityVal) -> Submission{..}) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell +colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^? resultLastEdit) dateTimeCell colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x -> @@ -314,7 +472,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission cID = x ^. resultCryptoID asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR - in maybeCell (x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) + in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) filterUICourse :: Handler (OptionList Text) -> DBFilterUI @@ -364,8 +522,8 @@ filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams + => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> Maybe CorrectionTableCsvSettings -> PSValidator m x -> DBParams m x -> DB (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValidator dbtParams = let dbtSQLQuery = runReaderT $ do course <- view queryCourse sheet <- view querySheet @@ -396,12 +554,6 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams let haystack = map CI.mk . unpack $ toPathPiece cid in guard $ any (`isInfixOf` haystack) criteria - mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet - asState <- for mASDefinition $ \_ -> - lift . lift . $cachedHereBinary sId $ getSubmissionAuthorshipStatement mASDefinition sId - - forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> - guard $ asState == Just criterion submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) @@ -416,8 +568,15 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams return . E.just $ submissionGroup E.^. SubmissionGroupName return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') - let - submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors + + mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet + (submittorMap, fmap getMax -> asState) <- runWriterT . flip foldMapM submittors $ \(Entity userId user, E.Value pseudo, E.Value sGroup) -> do + asState <- for mASDefinition $ \_ -> lift . lift . lift $ getUserAuthorshipStatement mASDefinition sId userId + tell $ Max <$> asState + return $ Map.singleton userId (user, pseudo, sGroup, asState) + + forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> + guard $ asState == Just criterion forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap @@ -502,7 +661,41 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams dbtFilterUI = fromMaybe mempty dbtFilterUI' dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } dbtIdent = "corrections" :: Text - dbtCsvEncode = noCsvEncode + dbtCsvEncode = do + CorrectionTableCsvSettings{..} <- mCSVSettings + return DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvNoExportData = Just id + , dbtCsvDoEncode = \() -> awaitForever $ \(_, row) -> runReaderC row $ do + 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 + <$> preview (_1 . resultCourseTerm . _TermId) + <*> preview (_1 . resultCourseSchool . _SchoolId) + <*> preview (_1 . resultCourseShorthand) + <*> preview (_1 . resultSheet . _entityVal . _sheetName) + <*> preview (_1 . resultCryptoID . re (_CI . _PathPiece)) + <*> guardNonAnonymous (preview $ _1 . resultLastEdit) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userSurname . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userFirstName . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userDisplayName . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userMatrikelnummer)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userEmail . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserPseudonym)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserSubmissionGroup)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserAuthorshipStatementState)) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingAssigned . _Just) + <*> preview (_1 . resultCorrector . _entityVal . _userDisplayName) + <*> preview (_1 . resultCorrector . _entityVal . _userEmail) + <*> preview (_1 . resultSubmission . _entityVal . to submissionRatingDone) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingTime . _Just) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingPoints . _Just) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingComment . _Just) + , dbtCsvName = cTableCsvName, dbtCsvSheetName = cTableCsvSheetName + , dbtCsvHeader = \_ -> return $ correctionTableCsvHeader cTableShowCorrector cTableCsvQualification + , dbtCsvExampleData = Nothing + } dbtCsvDecode = Nothing dbtExtraReps = [] in dbTable psValidator DBTable{..} @@ -524,16 +717,16 @@ data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous Submis | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent -correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do - (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions +correctionsR :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent +correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do + (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") -correctionsR' :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) -correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do +correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) +correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) @@ -542,7 +735,7 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do } ((actionRes', statistics), table) <- runDB $ - makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm + makeCorrectionsTable whereClause displayColumns dbtFilterUI csvSettings psValidator DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] @@ -682,7 +875,12 @@ restrictAnonymous :: PSValidator m x -> PSValidator m x restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber") . restrictFilter (\k _ -> k /= "user-name-email") . restrictFilter (\k _ -> k /= "submission-group") + . restrictFilter (\k _ -> k /= "as-state") + . restrictSorting (\k _ -> k /= "submittors") + . restrictSorting (\k _ -> k /= "submittors-matriculation") + . restrictSorting (\k _ -> k /= "submittors-group") . restrictSorting (\k _ -> k /= "last-edit") + . restrictSorting (\k _ -> k /= "as-state") restrictCorrector :: PSValidator m x -> PSValidator m x restrictCorrector = restrictFilter (\k _ -> k /= "corrector") @@ -772,7 +970,14 @@ postCorrectionsR = do & restrictAnonymous & defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ] & defaultFilter (singletonMap "israted" [toPathPiece False]) - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifyCourse + , cTableCsvName = MsgCorrectionTableCsvNameCorrections + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCorrections + , cTableShowCorrector = False + } + correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction ] @@ -817,7 +1022,13 @@ postCCorrectionsR tid ssh csh = do , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifySheet + , cTableCsvName = MsgCorrectionTableCsvNameCourseCorrections tid ssh csh + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseCorrections tid ssh csh + , cTableShowCorrector = True + } + correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction @@ -858,7 +1069,13 @@ postSSubsR tid ssh csh shn = do , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvNoQualification + , cTableCsvName = MsgCorrectionTableCsvNameSheetCorrections tid ssh csh shn + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn + , cTableShowCorrector = True + } + correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index e89b05c47..ef0d0a2e6 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -22,8 +22,6 @@ import Handler.Utils.StudyFeatures.Parse import qualified Data.Csv as Csv -import qualified Data.ByteString as ByteString - import qualified Data.Set as Set import Data.RFC5051 (compareUnicode) @@ -65,7 +63,7 @@ instance Csv.ToField UserTableStudyFeature where [] $ ShortStudyFieldType userTableFieldType instance Csv.ToField UserTableStudyFeatures where - toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures + toField = Csv.toField . CsvSemicolonList . view _UserTableStudyFeatures userTableStudyFeatureSort :: UserTableStudyFeature -> UserTableStudyFeature diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 96a0710f9..b59d1d723 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -981,20 +981,6 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible") -data AuthorshipStatementSubmissionState - = ASMissing - | ASOldStatement - | ASExists - deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) - -deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max` - -nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 - -embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel - - getUserAuthorshipStatement :: ( MonadResource m , IsSqlBackend backend, SqlBackendCanRead backend ) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 76d427ed9..8f9a3bd28 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -133,6 +133,8 @@ instance ToJSON TermIdentifier where instance FromJSON TermIdentifier where parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText +pathPieceCsv ''TermIdentifier + {- Must be defined in a later module: termField :: Field (HandlerT UniWorX IO) TermIdentifier termField = checkMMap (return . termFromText) termToText textField diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 49dfd12ce..50bee48b8 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -130,3 +130,26 @@ pseudonymWords = folding pseudonymFragments :: Fold Text [PseudonymWord] pseudonymFragments = folding $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) + + +instance PathPiece Pseudonym where + toPathPiece = review _PseudonymText + fromPathPiece t + | Just p <- t ^? _PseudonymText = Just p + | Just n <- fromPathPiece t = Just $ Pseudonym n + | otherwise = Nothing + +pathPieceCsv ''Pseudonym + + +data AuthorshipStatementSubmissionState + = ASMissing + | ASOldStatement + | ASExists + deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max` + +nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 +pathPieceCsv ''AuthorshipStatementSubmissionState diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 7070720b1..0a1d1d34d 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -10,6 +10,7 @@ module Utils.Csv , toCsvRendered , toDefaultOrderedCsvRendered , csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx + , CsvSemicolonList(..) ) where import ClassyPrelude hiding (lookup) @@ -39,6 +40,19 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.CaseInsensitive as CI +import qualified Data.Binary.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Attoparsec.ByteString as Attoparsec + +import qualified Data.Csv.Parser as Csv +import qualified Data.Csv.Builder as Csv + +import qualified Data.Vector as Vector + +import Data.Char (ord) + +import Control.Monad.Fail + deriving instance Typeable CsvParseError instance Exception CsvParseError @@ -114,3 +128,25 @@ csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (d addValues = flip foldMap (zip [2..] csvRenderedData) $ \(r, nr) -> flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, hBS) -> case HashMap.lookup hBS nr of Nothing -> mempty Just vBS -> Endo $ Xlsx.cellValueAtRC (r, c) ?~ Xlsx.CellText (decodeUtf8 vBS) + + +newtype CsvSemicolonList a = CsvSemicolonList { unCsvSemicolonList :: [a] } + deriving stock (Read, Show, Generic, Typeable) + deriving newtype (Eq, Ord) + +instance ToField a => ToField (CsvSemicolonList a) where + toField (CsvSemicolonList xs) = dropEnd 2 . LBS.toStrict . Builder.toLazyByteString $ Csv.encodeRecordWith encOpts fs + where + fs = map toField xs + encOpts = defaultEncodeOptions + { encDelimiter = fromIntegral $ ord ';' + , encQuoting = bool QuoteMinimal QuoteAll $ all null fs + , encUseCrLf = True + } + +instance FromField a => FromField (CsvSemicolonList a) where + parseField f + | null f = pure $ CsvSemicolonList [] + | otherwise = fmap CsvSemicolonList . mapM parseField . Vector.toList <=< either fail return $ Attoparsec.parseOnly (Csv.record sep) f + where + sep = fromIntegral $ ord ';' diff --git a/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet new file mode 100644 index 000000000..8a44b1939 --- /dev/null +++ b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Tabellen von Übungsblattabgaben können nun als CSV exportiert werden diff --git a/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet new file mode 100644 index 000000000..70a14aa63 --- /dev/null +++ b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Tables of exercise sheet submissions can now be exported as CSV diff --git a/test/Data/Scientific/InstancesSpec.hs b/test/Data/Scientific/InstancesSpec.hs new file mode 100644 index 000000000..0fb95c4f3 --- /dev/null +++ b/test/Data/Scientific/InstancesSpec.hs @@ -0,0 +1,10 @@ +module Data.Scientific.InstancesSpec where + +import TestImport +import Data.Scientific + + +spec :: Spec +spec = modifyMaxSuccess (* 10) $ + lawsCheckHspec (Proxy @Scientific) + [ pathPieceLaws ] diff --git a/test/Utils/CsvSpec.hs b/test/Utils/CsvSpec.hs new file mode 100644 index 000000000..ce556647a --- /dev/null +++ b/test/Utils/CsvSpec.hs @@ -0,0 +1,38 @@ +module Utils.CsvSpec where + +import TestImport + +import Utils.Csv + +import Data.Csv (toField, runParser, parseField) + +import Data.Char (ord) +import qualified Data.ByteString as BS + + +deriving newtype instance Arbitrary a => Arbitrary (CsvSemicolonList a) + + +spec :: Spec +spec = modifyMaxSuccess (* 10) . parallel $ do + lawsCheckHspec (Proxy @(CsvSemicolonList ByteString)) + [ csvFieldLaws ] + describe "CsvSemicolonList" $ do + let + test :: [ByteString] -> ByteString -> Expectation + test (CsvSemicolonList -> x) t = do + toField x `shouldBe` t + runParser (parseField t) `shouldBe` Right x + it "is transparent" . property $ \(bs :: ByteString) + -> let expectTransparent = BS.all (`notElem` [34, 10, 13, fromIntegral $ ord ';']) bs + && not (BS.null bs) + in expectTransparent ==> test [bs] bs + it "behaves as expected on some examples" $ do + test ["foo"] "foo" + test ["foo", "bar"] "foo;bar" + test [] "" + test [""] "\"\"" + test ["", ""] "\"\";\"\"" + test ["foo", ""] "foo;" + test ["", "foo"] ";foo" + test ["", "", "foo", ""] ";;foo;" From fe8e4bbd4f6a8b1b1c54808ebc96ee675a078648 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Aug 2021 19:00:12 +0200 Subject: [PATCH 7/9] feat(corrections-r): json export --- src/Handler/Submission/List.hs | 75 +++++++++++++++++++++++++++++++++- src/Model/Types/Submission.hs | 1 + 2 files changed, 74 insertions(+), 2 deletions(-) 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 From 42f1eabb2c984a7d30ea8b90710c68aff8af9f97 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Aug 2021 19:00:53 +0200 Subject: [PATCH 8/9] fix(csv): less quoting in semicolon separated lists --- src/Utils/Csv.hs | 4 +++- test/Utils/CsvSpec.hs | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 0a1d1d34d..850ef9af1 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -140,7 +140,9 @@ instance ToField a => ToField (CsvSemicolonList a) where fs = map toField xs encOpts = defaultEncodeOptions { encDelimiter = fromIntegral $ ord ';' - , encQuoting = bool QuoteMinimal QuoteAll $ all null fs + , encQuoting = case fs of + [fStr] | null fStr -> QuoteAll + _other -> QuoteMinimal , encUseCrLf = True } diff --git a/test/Utils/CsvSpec.hs b/test/Utils/CsvSpec.hs index ce556647a..b4f1c16c0 100644 --- a/test/Utils/CsvSpec.hs +++ b/test/Utils/CsvSpec.hs @@ -32,7 +32,7 @@ spec = modifyMaxSuccess (* 10) . parallel $ do test ["foo", "bar"] "foo;bar" test [] "" test [""] "\"\"" - test ["", ""] "\"\";\"\"" + test ["", ""] ";" test ["foo", ""] "foo;" test ["", "foo"] ";foo" test ["", "", "foo", ""] ";;foo;" From 7aadb6662bc8db76436f8d41ded7156acb98418e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Aug 2021 20:59:52 +0200 Subject: [PATCH 9/9] feat(corrections-r): allow csv exporting one line per submittor --- .../courses/submission/de-de-formal.msg | 2 ++ .../categories/courses/submission/en-eu.msg | 2 ++ src/Data/Scientific/Instances.hs | 10 +++++++++- src/Handler/Submission/List.hs | 17 ++++++++++++----- 4 files changed, 25 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index b2b734946..145768cc4 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -251,6 +251,8 @@ CsvColumnCorrectionAssigned: Zeitpunkt der Zuteilung des Korrektors (ISO 8601) CsvColumnCorrectionLastEdit: Zeitpunkt der letzten Änderung der Abgabe (ISO 8601) CsvColumnCorrectionRatingPoints: Erreichte Punktezahl (Für “_{MsgSheetGradingPassBinary}” entspricht 0 “_{MsgRatingNotPassed}” und alles andere “_{MsgRatingPassed}”) CsvColumnCorrectionRatingComment: Bewertungskommentar +CorrectionCsvSingleSubmittors: Eine Zeile pro Abgebende:n +CorrectionCsvSingleSubmittorsTip: Sollen Abgaben mit mehreren Abgebenden mehrfach vorkommen, sodass jeweils eine Zeile pro Abgebende:n enthalten ist, statt mehrere Abgebende in einer Zeile zusammenzufassen? CorrectionTableCsvNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-abgaben CorrectionTableCsvSheetNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Abgaben diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index 1e9adbd3b..0574c4a9d 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -250,6 +250,8 @@ CsvColumnCorrectionAssigned: Timestamp of when corrector was assigned (ISO 8601) CsvColumnCorrectionLastEdit: Timestamp of the last edit of the submission (ISO 8601) CsvColumnCorrectionRatingPoints: Achieved points (for “_{MsgSheetGradingPassBinary}” 0 means “_{MsgRatingNotPassed}”, everything else means “_{MsgRatingPassed}”) CsvColumnCorrectionRatingComment: Rating comment +CorrectionCsvSingleSubmittors: One row per submittor +CorrectionCsvSingleSubmittorsTip: Should submissions with multiple submittors be split into multiple rows, such that there is one row per submittor instead of having multiple submittors within one row? CorrectionTableCsvNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-submissions CorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Submissions diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs index 8c0c83e89..87b079e7e 100644 --- a/src/Data/Scientific/Instances.hs +++ b/src/Data/Scientific/Instances.hs @@ -11,7 +11,15 @@ import Web.PathPieces import Text.ParserCombinators.ReadP (readP_to_S) +import Control.Monad.Fail + instance PathPiece Scientific where toPathPiece = pack . formatScientific Fixed Nothing - fromPathPiece = fmap fst . listToMaybe . filter (\(_, rStr) -> null rStr) . readP_to_S scientificP . unpack + + fromPathPiece = disambiguate . readP_to_S scientificP . unpack + where + disambiguate strs = case filter (\(_, rStr) -> null rStr) strs of + [(x, _)] -> pure x + _other -> fail "fromPathPiece Scientific: Ambiguous parse" + diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index be7f33c88..d9976e95c 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -302,6 +302,12 @@ data CorrectionTableCsvSettings = forall filename sheetName. , cTableShowCorrector :: Bool } +newtype CorrectionTableCsvExportData = CorrectionTableCsvExportData + { csvCorrectionSingleSubmittors :: Bool + } deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance Default CorrectionTableCsvExportData where + def = CorrectionTableCsvExportData False + data CorrectionTableJson = CorrectionTableJson { jsonCorrectionTerm :: TermIdentifier , jsonCorrectionSchool :: SchoolShorthand @@ -698,11 +704,12 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValida dbtCsvEncode = do CorrectionTableCsvSettings{..} <- mCSVSettings return DBTCsvEncode - { dbtCsvExportForm = pure () - , dbtCsvNoExportData = Just id - , dbtCsvDoEncode = \() -> awaitForever $ \(_, row) -> runReaderC row $ do + { dbtCsvExportForm = CorrectionTableCsvExportData + <$> apopt checkBoxField (fslI MsgCorrectionCsvSingleSubmittors & setTooltip MsgCorrectionCsvSingleSubmittorsTip) (Just $ csvCorrectionSingleSubmittors def) + , dbtCsvNoExportData = Nothing + , dbtCsvDoEncode = \CorrectionTableCsvExportData{..} -> awaitForever $ \(_, row) -> runReaderC row $ do submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors - forM_ (bool pure (map pure) False submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do + forM_ (bool pure (map pure) csvCorrectionSingleSubmittors submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do let guardNonAnonymous = runMaybeT . guardMOnM (view $ _1 . resultNonAnonymousAccess) . MaybeT yieldM $ CorrectionTableCsv <$> preview (_1 . resultCourseTerm . _TermId) @@ -731,7 +738,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValida , dbtCsvExampleData = Nothing } dbtCsvDecode = Nothing - dbtExtraReps = + dbtExtraReps = maybe id (\CorrectionTableCsvSettings{..} -> withCsvExtraRep cTableCsvSheetName (def :: CorrectionTableCsvExportData) dbtCsvEncode) mCSVSettings [ DBTExtraRep $ toPrettyJSON <$> repCorrectionJson, DBTExtraRep $ toYAML <$> repCorrectionJson ]