From fd2c2881ea5a465458eb3f64d7767be3a307dc46 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 17 Apr 2020 15:19:26 +0200 Subject: [PATCH] feat(submissions): non-anonymized correction Fixes #524 Fixes #292 --- messages/uniworx/de-de-formal.msg | 4 + messages/uniworx/en-eu.msg | 4 + models/sheets.model | 1 + package.yaml | 1 + src/Foundation.hs | 4 +- src/Handler/Corrections.hs | 97 +++++++++++--------- src/Handler/Sheet.hs | 5 + src/Handler/Submission.hs | 2 +- src/Handler/Utils/Submission.hs | 43 +++++++-- src/Handler/Utils/Table/Pagination.hs | 8 +- src/Utils.hs | 2 +- src/Utils/Tooltip.hs | 6 -- stack.yaml | 2 + stack.yaml.lock | 7 ++ templates/allocation/show.hamlet | 15 +-- templates/i18n/changelog/de-de-formal.hamlet | 2 + templates/i18n/changelog/en-eu.hamlet | 2 + templates/widgets/text-tooltip.hamlet | 6 -- test/Database/Fill.hs | 10 +- 19 files changed, 135 insertions(+), 86 deletions(-) delete mode 100644 src/Utils/Tooltip.hs delete mode 100644 templates/widgets/text-tooltip.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b41073150..da03651c3 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -324,6 +324,8 @@ SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren könn SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren SheetPseudonym: Persönliches Abgabe-Pseudonym SheetGeneratePseudonym: Generieren +SheetAnonymousCorrection: Anonymisierte Korrektur +SheetAnonymousCorrectionTip: Wenn die Korrektur anonymisiert erfolgt, können Korrektoren die ihnen zugeteilten Abgaben nicht bestimmten Studierenden zuordnen (Name & Matrikelnummer der Abgebenden werden versteckt) SheetFormType: Wertung & Abgabe SheetFormTimes: Zeiten @@ -565,6 +567,8 @@ DBTablePagesize: Einträge pro Seite DBTablePagesizeAll: Alle CorrDownload: Herunterladen +CorrDownloadAnonymous: Anonymisiert +CorrDownloadAnonymousTip: Wenn Abgaben nicht-anonymisiert heruntergeladen werden, werden an die Verzeichnisnamen der einzelnen Abgaben die Nachnamen der Abgeber angehängt, sofern erlaubt CorrUploadField: Korrekturen CorrUpload: Korrekturen hochladen CorrSetCorrector: Korrektor zuweisen diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 11330d032..ea28a16a6 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -323,6 +323,8 @@ SheetSolutionFromTip: Always invisible for participants if left empty; corrector SheetMarkingTip: Instructions for correction, visible only to correctors SheetPseudonym: Personal pseudonym SheetGeneratePseudonym: Generate +SheetAnonymousCorrection: Anonymized correction +SheetAnonymousCorrectionTip: If correction is anonymized, correctors cannot see which students are involved in submissions that are assigned to them (names & matriculation numbers are hidden) SheetFormType: Valuation & submission SheetFormTimes: Times @@ -563,6 +565,8 @@ DBTablePagesize: Entries per page DBTablePagesizeAll: All CorrDownload: Download +CorrDownloadAnonymous: Anonymized +CorrDownloadAnonymousTip: If submissions are downloaded non-anonymized the surnames of the submittors are appended to the name of the dirctory for each submission where permitted CorrUploadField: Corrections CorrUpload: Upload corrections CorrSetCorrector: Assign corrector diff --git a/models/sheets.model b/models/sheets.model index fcd2cadc4..418590e52 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -12,6 +12,7 @@ Sheet -- exercise sheet for a given course solutionFrom UTCTime Maybe -- Solution is made available submissionMode SubmissionMode -- Submission upload by students and/or through tutors? autoDistribute Bool default=false -- Should correctors be assigned submissions automagically? + anonymousCorrection Bool default=true CourseSheet course name deriving Generic SheetEdit -- who edited when a row in table "Course", kept indefinitely diff --git a/package.yaml b/package.yaml index 7f86a5a01..a6f3ec960 100644 --- a/package.yaml +++ b/package.yaml @@ -141,6 +141,7 @@ dependencies: - wai-middleware-prometheus - extended-reals - rfc5051 + - unidecode - pandoc other-extensions: diff --git a/src/Foundation.hs b/src/Foundation.hs index 878510f3d..2a15e13c8 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2009,13 +2009,13 @@ getSystemMessageState smId = liftHandler $ do where getSystemMessageStateRequest = (lookupRegisteredCookiesJson id CookieSystemMessageState :: Handler (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)) - >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (HashMap.singleton <$> decrypt cID <*> pure v)) + >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v)) getDBSystemMessageState uid = runDB . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt where foldSt (Entity _ SystemMessageHidden{..}) = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime } applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () -applySystemMessages = liftHandler . maybeT_ $ do +applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden cRoute <- lift getCurrentRoute diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index db79ad6c4..fdea529a2 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -67,7 +67,7 @@ import qualified Data.Conduit.List as C 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), CryptoFileNameSubmission) +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym), 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 @@ -119,7 +119,7 @@ colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _) } -> courseCellCL (tid,sid,csh) + $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh) colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row -> @@ -133,12 +133,12 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row -> colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case - DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _) } -> cell mempty - DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _) } -> userCell userDisplayName userSurname + DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty + DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmissionLink = sortable (Just "submission") (i18nCell MsgSubmission) - $ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid) } -> + $ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid, _) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 @@ -146,27 +146,30 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgSubmission) in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid) colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) -colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid) } -> return cid +colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _) } -> 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 protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] +colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, 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 colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _) } -> let - protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) - in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] +colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } -> + let protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) + in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + | otherwise -> mempty colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) -colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _) } -> +colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 @@ -186,43 +189,43 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E ] colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _) } -> +colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } -> maybe mempty dateTimeCell submissionRatingAssigned colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _) } -> +colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } -> maybe mempty dateTimeCell submissionRatingTime colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _) } -> let +colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo -> cell [whamlet|#{review _PseudonymText pseudo}|] in lCell & 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 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) 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 + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) -colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _) } -> sheetType) +colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (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 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $ - \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _) } -> maybe mempty dateTimeCell mbLastEdit + \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) @@ -239,7 +242,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams in (submission, sheet, crse, corrector, lastEditQuery submission) ) dbtProj :: DBRow _ -> DB CorrectionTableData - dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do + dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do submittors <- 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) @@ -249,8 +252,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors + nonAnonymousAccess <- or2M + (return $ not sheetAnonymousCorrection) + (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) cid <- encrypt sId - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid) + return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId @@ -292,13 +298,10 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned ) , ( "submittors" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> - E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] - E.limit 1 - return (user E.^. UserSurname) + , SortProjected . comparing $ \DBRow{ dbrOutput = (_, Entity _ Sheet{..}, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors + ) + , ( "submittors-matriculation" + , SortProjected . comparing $ \DBRow{ dbrOutput = (_, Entity _ Sheet{..}, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ 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 @@ -421,7 +424,7 @@ instance Finite ActionCorrections nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ActionCorrections id -data ActionCorrectionsData = CorrDownloadData +data ActionCorrectionsData = CorrDownloadData Bool {- Not anonymized? -} | CorrSetCorrectorData (Maybe UserId) | CorrAutoSetCorrectorData SheetId | CorrDeleteData @@ -470,10 +473,10 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet formResult actionRes $ \case - (CorrDownloadData, subs) -> do + (CorrDownloadData nonAnonymous, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|] - sendResponse =<< submissionMultiArchive ids + sendResponse =<< submissionMultiArchive nonAnonymous ids (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' now <- liftIO getCurrentTime @@ -583,7 +586,7 @@ type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionC downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload - , pure CorrDownloadData + , CorrDownloadData <$> apopt (convertField not not checkBoxField) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just False) ) deleteAction = ( CorrDelete , pure CorrDeleteData @@ -625,6 +628,8 @@ postCorrectionsR = do , colTerm , colCourse , colSheet + , colSMatrikel + , colSubmittors , colPseudonyms , colSubmissionLink , colAssigned @@ -1045,6 +1050,8 @@ postCorrectionsGradeR = do , colTerm , colCourse , colSheet + , colSMatrikel + , colSubmittors , colPseudonyms , colSubmissionLink , colRated @@ -1074,7 +1081,7 @@ postCorrectionsGradeR = do optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & 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 $ \DBRow{ dbrOutput = (Entity _ 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/Sheet.hs b/src/Handler/Sheet.hs index be86eca93..a73a54403 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -66,6 +66,7 @@ data SheetForm = SheetForm , sfSubmissionMode :: SubmissionMode , sfAutoDistribute :: Bool , sfMarkingText :: Maybe Html + , sfAnonymousCorrection :: Bool , sfCorrectors :: Loads -- Keine SheetId im Formular! } @@ -126,6 +127,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction)) <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) + <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template) return $ case result of FormSuccess sheetResult @@ -534,6 +536,7 @@ getSheetNewR tid ssh csh = do , sfMarkingText = sheetMarkingText , sfAutoDistribute = sheetAutoDistribute , sfCorrectors = loads + , sfAnonymousCorrection = sheetAnonymousCorrection } _other -> Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing @@ -570,6 +573,7 @@ getSEditR tid ssh csh shn = do , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking , sfMarkingText = sheetMarkingText , sfAutoDistribute = sheetAutoDistribute + , sfAnonymousCorrection = sheetAnonymousCorrection , sfCorrectors = currentLoads } @@ -603,6 +607,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetSolutionFrom = sfSolutionFrom , sheetSubmissionMode = sfSubmissionMode , sheetAutoDistribute = sfAutoDistribute + , sheetAnonymousCorrection = sfAnonymousCorrection } mbsid <- dbAction newSheet case mbsid of diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 7878ae211..4e67cd86a 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -684,7 +684,7 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions when (null subs) $ do addMessageI Info MsgNoOpenSubmissions redirect CorrectionsR - submissionMultiArchive $ Set.fromList subs + submissionMultiArchive True $ Set.fromList subs -- not anonymized, where permissable getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index c6bce6821..ca8192ae6 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -48,6 +48,10 @@ import qualified Control.Monad.Catch as E (Handler(..)) import qualified Data.CaseInsensitive as CI +import Text.Unidecode (unidecode) +import Data.Char (isAlphaNum) + + data AssignSubmissionException = NoCorrectors | NoCorrectorsByProportion | SubmissionsNotFound (NonNull (Set SubmissionId)) @@ -256,14 +260,18 @@ submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File)) submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) + E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor + E.where_ . E.not_ . E.exists . E.from $ \(sf' `E.InnerJoin` f') -> do + E.on $ f' E.^. FileId E.==. sf' E.^. SubmissionFileFile + E.where_ $ sf' E.^. SubmissionFileIsDeletion + E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission + E.&&. f' E.^. FileTitle E.==. f E.^. FileTitle E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first return (sf, f) -submissionMultiArchive :: Set SubmissionId -> Handler TypedContent -submissionMultiArchive (Set.toList -> ids) = do +submissionMultiArchive :: Bool -> Set SubmissionId -> Handler TypedContent +submissionMultiArchive notAnonymized (Set.toList -> ids) = do (dbrunner, cleanup) <- getDBRunner ratedSubmissions <- runDBRunner dbrunner $ do @@ -271,26 +279,41 @@ submissionMultiArchive (Set.toList -> ids) = do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionId `E.in_` E.valList ids - return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm)) + return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm, sheet E.^. SheetAnonymousCorrection)) forM submissions $ \(s@(Entity submissionId _), courseSheetInfo) -> - maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 4) courseSheetInfo)) =<< getRating submissionId + maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 5) courseSheetInfo)) =<< getRating submissionId let (setSheet,setCourse,setSchool,setTerm) = - execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) -> + execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid,_anon)) -> tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid) archiveName <- ap getMessageRender $ pure MsgSubmissionArchiveName setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip) (<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do let - fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> ConduitT () File (YesodDB UniWorX) () - fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do + fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) () + fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid,sheetAnonymous)) = do cID <- encrypt submissionID let dirFrag :: PathPiece p => p -> FilePath dirFrag = Text.unpack . toPathPiece - submissionDirectory = dirFrag (cID :: CryptoFileNameSubmission) + + withNames fp = do + surnames <- lift . E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do + E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID + return $ user E.^. UserSurname + let asciiNames = sort $ map (filter isAlphaNum . foldMap unidecode . unpack . E.unValue) surnames + return . intercalate "_" $ fp : asciiNames + + notAnonymized' <- and2M + (return notAnonymized) + (or2M (return $ not sheetAnonymous) (hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR)) + + submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission) + + let directoryName | Set.size setTerm > 1 = dirFrag tid dirFrag ssh dirFrag csh dirFrag shn submissionDirectory | Set.size setSchool > 1 = dirFrag ssh dirFrag csh dirFrag shn submissionDirectory diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index f41dc29f4..12e9304b0 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -38,7 +38,7 @@ module Handler.Utils.Table.Pagination , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM' , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM' , cellTooltip - , listCell + , listCell, listCell' , formCell, DBFormResult(..), getDBFormResult , dbSelect , (&) @@ -1527,7 +1527,11 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a -listCell xs mkCell = review dbCell . ([], ) $ do +listCell = listCell' . return + +listCell' :: (IsDBTable m a, Traversable f) => WriterT a m (f r') -> (r' -> DBCell m a) -> DBCell m a +listCell' mkXS mkCell = review dbCell . ([], ) $ do + xs <- mkXS cells <- forM xs $ \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget return $(widgetFile "table/cell/list") diff --git a/src/Utils.hs b/src/Utils.hs index c69b4cde9..3addd9116 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -664,7 +664,7 @@ assertM_ f x = guard . f =<< x assertM' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) -guardOn :: Alternative m => Bool -> a -> m a +guardOn :: forall m a. Alternative m => Bool -> a -> m a guardOn b x = x <$ guard b guardOnM :: Alternative m => Bool -> m a -> m a diff --git a/src/Utils/Tooltip.hs b/src/Utils/Tooltip.hs deleted file mode 100644 index 5332868b6..000000000 --- a/src/Utils/Tooltip.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Utils.Tooltip where - -import ClassyPrelude.Yesod hiding (Proxy) - -textTooltip :: forall site. WidgetFor site () -> WidgetFor site () -> WidgetFor site () -textTooltip ttHandle ttContent = $(whamletFile "templates/widgets/text-tooltip.hamlet") diff --git a/stack.yaml b/stack.yaml index 07c492062..298cfb02d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -102,5 +102,7 @@ extra-deps: - acid-state-0.16.0 + - unidecode-0.1.0.4 + resolver: lts-15.0 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index f8e0d7b61..e8cc7d86d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -274,6 +274,13 @@ packages: sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f original: hackage: acid-state-0.16.0 +- completed: + hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 + pantry-tree: + size: 492 + sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283 + original: + hackage: unidecode-0.1.0.4 snapshots: - completed: size: 488576 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index f6a2312a3..ec3a41cce 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -47,25 +47,16 @@ $newline never
$maybe _ <- allocationRegisterByStaffTo _{MsgAllocationRegisterByStaff} - - - - _{MsgAllocationRegisterByStaffTip} + ^{iconTooltip (i18n MsgAllocationRegisterByStaffTip) Nothing True} $nothing _{MsgAllocationRegisterByStaffFrom} - - - - _{MsgAllocationRegisterByStaffFromTip} + ^{iconTooltip (i18n MsgAllocationRegisterByStaffFromTip) Nothing True}
^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo} $maybe fromT <- allocationRegisterByCourse
_{MsgAllocationRegisterByCourseFrom} - - - - _{MsgAllocationRegisterByCourseFromTip} + ^{iconTooltip (i18n MsgAllocationRegisterByCourseFromTip) Nothing True}
^{formatTimeW SelFormatDateTime fromT} $maybe toT <- allocationOverrideDeregister diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index c19951a81..2d4d809cc 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -6,6 +6,8 @@ $newline never