feat(submissions): non-anonymized correction

Fixes #524
Fixes #292

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

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

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

package.yaml

@@ -141,6 +141,7 @@ dependencies:
   - wai-middleware-prometheus
   - extended-reals
   - rfc5051
+  - unidecode
   - pandoc
 
 other-extensions:

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

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 = (_, _, _, Nothing  , _, _, _, _) } -> cell mempty
-  DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _) } -> userCell userDisplayName userSurname
+  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
+colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } ->
-  csh = course ^. _2
+  let
-  tid = course ^. _3
+    csh = course ^. _2
-  ssh = course ^. _4
+    tid = course ^. _3
-  link cid = CourseR tid ssh csh $ CUserR cid
+    ssh = course ^. _4
-  protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
+    link cid = CourseR tid ssh csh $ CUserR cid
-    anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
+    protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
-      Nothing -> nameWidget userDisplayName userSurname
+      anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
-      Just p  -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
+        Nothing -> nameWidget userDisplayName userSurname
-  in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+        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
+colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
-  protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
+  let protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer)
-  in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+  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 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 _ (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 subId _, _, _, _, _, _, _, _) } -> return subId)
-  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _) } mkUnique -> case sheetType of
+  (\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 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 _ 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` _) ->
+        , SortProjected . comparing $ \DBRow{ dbrOutput = (_, Entity _ Sheet{..}, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors
-            E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+        )
-              E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+      , ( "submittors-matriculation"
-              E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+        , SortProjected . comparing $ \DBRow{ dbrOutput = (_, Entity _ Sheet{..}, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ Map.elems submittors
-              E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
-              E.limit 1
-              return (user E.^. UserSurname)
         )
       , ( "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

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

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

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 :: Bool -> Set SubmissionId -> Handler TypedContent
-submissionMultiArchive (Set.toList -> ids) = do
+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 Submission, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
-      fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do
+      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

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

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

src/Utils/Tooltip.hs

@@ -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")

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

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

templates/allocation/show.hamlet

@@ -47,25 +47,16 @@ $newline never
       <dt .deflist__dt>
         $maybe _ <- allocationRegisterByStaffTo
           _{MsgAllocationRegisterByStaff}
-          <span .tooltip>
+          ^{iconTooltip (i18n MsgAllocationRegisterByStaffTip) Nothing True}
-            <span .tooltip__handle>
-            <span .tooltip__content>
-                _{MsgAllocationRegisterByStaffTip}
         $nothing
           _{MsgAllocationRegisterByStaffFrom}
-          <span .tooltip>
+          ^{iconTooltip (i18n MsgAllocationRegisterByStaffFromTip) Nothing True}
-            <span .tooltip__handle>
-            <span .tooltip__content>
-                _{MsgAllocationRegisterByStaffFromTip}
       <dd .deflist__dd>
         ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo}
     $maybe fromT <- allocationRegisterByCourse
       <dt .deflist__dt>
         _{MsgAllocationRegisterByCourseFrom}
-        <span .tooltip>
+        ^{iconTooltip (i18n MsgAllocationRegisterByCourseFromTip) Nothing True}
-          <span .tooltip__handle>
-          <span .tooltip__content>
-            _{MsgAllocationRegisterByCourseFromTip}
       <dd .deflist__dd>
         ^{formatTimeW SelFormatDateTime fromT}
     $maybe toT <- allocationOverrideDeregister

templates/i18n/changelog/de-de-formal.hamlet

@@ -6,6 +6,8 @@ $newline never
     <ul>
       <li>
         Anzeige von Abgaben, Tutorien und Klausuren auf der Seite für einzelne Kursteilnehmer
+      <li>
+        Nicht-anonymisierte Korrektur von Übungsblatt-Abgaben
 
   <dt .deflist__dt>
     ^{formatGregorianW 2020 04 15}

templates/i18n/changelog/en-eu.hamlet

@@ -6,6 +6,8 @@ $newline never
     <ul>
       <li>
         Submissions, tutorials, and exams are now shown on the detail page for course participants
+      <li>
+        Non-anonymized correction of sheet submissions
 
   <dt .deflist__dt>
     ^{formatGregorianW 2020 04 15}

templates/widgets/text-tooltip.hamlet

@@ -1,6 +0,0 @@
-$newline never
-<span .tooltip>
-  <span>
-    ^{ttHandle}
-  <span .tooltip__content>
-    ^{ttContent}

test/Database/Fill.hs

@@ -209,7 +209,7 @@ fillDb = do
     , userEmail  = "tester@campus.lmu.de"
     , userDisplayEmail = "tina@tester.example"
     , userDisplayName = "Tina Tester"
-    , userSurname = "von Terror"
+    , userSurname = "vön Tërrör¿"
     , userFirstName = "Sabrina"
     , userTitle = Just "Magister"
     , userMaxFavourites = 5
@@ -570,6 +570,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = False
+    , sheetAnonymousCorrection = True
     }
   insert_ $ SheetEdit gkleen now adhoc
   feste <- insert Sheet
@@ -586,6 +587,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = False
+    , sheetAnonymousCorrection = True
     }
   insert_ $ SheetEdit gkleen now feste
   keine <- insert Sheet
@@ -602,6 +604,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = False
+    , sheetAnonymousCorrection = True
     }
   insert_ $ SheetEdit gkleen now keine
   void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing)
@@ -747,6 +750,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = True
+    , sheetAnonymousCorrection = False
     }
   void . insert $ SheetEdit jost now sh1
   forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
@@ -797,6 +801,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = True
+    , sheetAnonymousCorrection = False
     }
   void . insert $ SheetEdit jost now sh2
   sh3 <- insert Sheet
@@ -813,6 +818,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = True
+    , sheetAnonymousCorrection = True
     }
   void . insert $ SheetEdit jost now sh3
   sh4 <- insert Sheet
@@ -829,6 +835,7 @@ fillDb = do
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     , sheetAutoDistribute = True
+    , sheetAnonymousCorrection = True
     }
   void . insert $ SheetEdit jost now sh4
   tut1 <- insert Tutorial
@@ -1025,6 +1032,7 @@ fillDb = do
       , sheetHintFrom = Nothing
       , sheetSolutionFrom = Nothing
       , sheetAutoDistribute = False
+      , sheetAnonymousCorrection = True
       }
     manyUsers' <- shuffleM $ take 1024 manyUsers
     groupSizes <- getRandomRs (1, 3)