feat(corrections): non-anonymous download w/ registered groups
This commit is contained in:
Gregor Kleen
parent
7f10d44aee
commit
9032f80f59
@ -325,7 +325,7 @@ 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)
|
||||
SheetAnonymousCorrectionTip: Wenn die Korrektur anonymisiert erfolgt, können Korrektoren die ihnen zugeteilten Abgaben nicht bestimmten Studierenden zuordnen (Name, Matrikelnummer und feste Abgabegruppe der Abgebenden werden versteckt)
|
||||
|
||||
SheetFormType: Wertung & Abgabe
|
||||
SheetFormTimes: Zeiten
|
||||
@ -572,7 +572,11 @@ 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
|
||||
CorrDownloadAnonymousTip: Wenn Abgaben nicht-anonymisiert heruntergeladen werden, werden an die Verzeichnisnamen der einzelnen Abgaben das ausgewählte Merkmal der Abgeber angehängt, sofern erlaubt
|
||||
SubmissionDownloadAnonymous: Anonymisiert
|
||||
SubmissionDownloadSurnames: Mit Nachnamen
|
||||
SubmissionDownloadMatriculations: Mit Matrikelnummern
|
||||
SubmissionDownloadGroups: Mit festen Abgabegruppen
|
||||
CorrUploadField: Korrekturen
|
||||
CorrUpload: Korrekturen hochladen
|
||||
CorrSetCorrector: Korrektor zuweisen
|
||||
|
||||
@ -324,7 +324,7 @@ 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)
|
||||
SheetAnonymousCorrectionTip: If correction is anonymized, correctors cannot see which students are involved in submissions that are assigned to them (names, matriculation numbers, and registered submission groups are hidden)
|
||||
|
||||
SheetFormType: Valuation & submission
|
||||
SheetFormTimes: Times
|
||||
@ -570,7 +570,7 @@ 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
|
||||
CorrDownloadAnonymousTip: If submissions are downloaded non-anonymized the selected feature of the submittors are appended to the name of the dirctory for each submission where permitted
|
||||
CorrUploadField: Corrections
|
||||
CorrUpload: Upload corrections
|
||||
CorrSetCorrector: Assign corrector
|
||||
|
||||
@ -15,8 +15,6 @@ import qualified Data.Map as Map
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import Data.Semigroup (Dual(..))
|
||||
|
||||
import Data.Sequence (Seq((:|>)))
|
||||
|
||||
|
||||
|
||||
@ -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, Bool {- Access to non-anonymous submission data -})
|
||||
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
|
||||
@ -83,6 +83,9 @@ 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)
|
||||
|
||||
querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
|
||||
querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
|
||||
|
||||
@ -155,7 +158,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
link cid = CourseR tid ssh csh $ CUserR cid
|
||||
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
|
||||
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})|]
|
||||
@ -164,10 +167,19 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
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)
|
||||
let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
|
||||
in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
| otherwise -> mempty
|
||||
|
||||
colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSGroups = sortable (Just "submittors-group") (i18nCell MsgSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } ->
|
||||
let protoCell = listCell (nubOn (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
|
||||
|
||||
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, _, _, _, _, _) } ->
|
||||
let csh = course ^. _2
|
||||
@ -198,7 +210,7 @@ colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOu
|
||||
|
||||
colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let
|
||||
lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
|
||||
lCell = listCell (catMaybes $ view (_2 . _2) <$> Map.toList users) $ \pseudo ->
|
||||
cell [whamlet|#{review _PseudonymText pseudo}|]
|
||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
@ -249,9 +261,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
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]
|
||||
return (user, pseudonym E.?. SheetPseudonymPseudonym)
|
||||
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) -> Map.insert userId (user, pseudo)) Map.empty submittors
|
||||
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
|
||||
nonAnonymousAccess <- or2M
|
||||
(return $ not sheetAnonymousCorrection)
|
||||
(hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
|
||||
@ -298,10 +315,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
|
||||
)
|
||||
, ( "submittors"
|
||||
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, Entity _ Sheet{..}, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors
|
||||
, SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, 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
|
||||
, 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
|
||||
@ -381,6 +401,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
|
||||
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)
|
||||
@ -424,7 +451,7 @@ instance Finite ActionCorrections
|
||||
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ActionCorrections id
|
||||
|
||||
data ActionCorrectionsData = CorrDownloadData Bool {- Not anonymized? -}
|
||||
data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous
|
||||
| CorrSetCorrectorData (Maybe UserId)
|
||||
| CorrAutoSetCorrectorData SheetId
|
||||
| CorrDeleteData
|
||||
@ -582,11 +609,22 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
let route = CSubmissionR tid ssh csh shn cID SubAssignR
|
||||
(== Authorized) <$> evalAccessDB route True
|
||||
|
||||
restrictAnonymous :: PSValidator m x -> PSValidator m x
|
||||
restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber")
|
||||
. restrictFilter (\k _ -> k /= "user-name-email")
|
||||
. restrictFilter (\k _ -> k /= "submission-group")
|
||||
. restrictSorting (\k _ -> k /= "last-edit")
|
||||
|
||||
restrictCorrector :: PSValidator m x -> PSValidator m x
|
||||
restrictCorrector = restrictFilter (\k _ -> k /= "corrector")
|
||||
. restrictFilter (\k _ -> k /= "corrector-name-email")
|
||||
. restrictSorting (\k _ -> k /= "corrector")
|
||||
|
||||
type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData)
|
||||
|
||||
downloadAction, deleteAction :: ActionCorrections'
|
||||
downloadAction = ( CorrDownload
|
||||
, CorrDownloadData <$> apopt (convertField not not checkBoxField) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just False)
|
||||
, CorrDownloadData <$> apopt (selectField optionsFinite) (fslI MsgCorrDownloadAnonymous & setTooltip MsgCorrDownloadAnonymousTip) (Just SubmissionDownloadAnonymous)
|
||||
)
|
||||
deleteAction = ( CorrDelete
|
||||
, pure CorrDeleteData
|
||||
@ -630,6 +668,7 @@ postCorrectionsR = do
|
||||
, colSheet
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSGroups
|
||||
, colPseudonyms
|
||||
, colSubmissionLink
|
||||
, colAssigned
|
||||
@ -655,8 +694,8 @@ postCorrectionsR = do
|
||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
||||
|
||||
psValidator = def
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictSorting (\name _ -> name /= "corrector")
|
||||
& restrictCorrector
|
||||
& restrictAnonymous
|
||||
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
||||
-- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
|
||||
correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
|
||||
@ -673,6 +712,7 @@ postCCorrectionsR tid ssh csh = do
|
||||
, colSheet
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSGroups
|
||||
, colSubmissionLink
|
||||
, colLastEdit
|
||||
, colRating
|
||||
@ -688,6 +728,7 @@ postCCorrectionsR tid ssh csh = do
|
||||
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
|
||||
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
|
||||
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
||||
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
|
||||
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
|
||||
]
|
||||
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
||||
@ -719,6 +760,7 @@ postSSubsR tid ssh csh shn = do
|
||||
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
|
||||
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
|
||||
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
||||
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
|
||||
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
|
||||
-- "pseudonym" TODO DB only stores Word24
|
||||
]
|
||||
@ -1052,6 +1094,7 @@ postCorrectionsGradeR = do
|
||||
, colSheet
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSGroups
|
||||
, colPseudonyms
|
||||
, colSubmissionLink
|
||||
, colRated
|
||||
@ -1080,6 +1123,8 @@ postCorrectionsGradeR = do
|
||||
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
|
||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
||||
psValidator = def
|
||||
& 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)
|
||||
|
||||
|
||||
@ -719,7 +719,7 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
|
||||
when (null subs) $ do
|
||||
addMessageI Info MsgNoOpenSubmissions
|
||||
redirect CorrectionsR
|
||||
submissionMultiArchive True $ Set.fromList subs -- not anonymized, where permissable
|
||||
submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs
|
||||
|
||||
|
||||
getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
|
||||
@ -3,6 +3,7 @@ module Handler.Utils.Submission
|
||||
, assignSubmissions, writeSubmissionPlan, planSubmissions
|
||||
, submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
|
||||
, submissionFileSource, submissionFileQuery
|
||||
, SubmissionDownloadAnonymous(..)
|
||||
, submissionMultiArchive
|
||||
, SubmissionSinkException(..)
|
||||
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
|
||||
@ -270,8 +271,19 @@ submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.a
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
return (sf, f)
|
||||
|
||||
submissionMultiArchive :: Bool -> Set SubmissionId -> Handler TypedContent
|
||||
submissionMultiArchive notAnonymized (Set.toList -> ids) = do
|
||||
data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous
|
||||
| SubmissionDownloadSurnames
|
||||
| SubmissionDownloadMatriculations
|
||||
| SubmissionDownloadGroups
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''SubmissionDownloadAnonymous $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''SubmissionDownloadAnonymous id
|
||||
makePrisms ''SubmissionDownloadAnonymous
|
||||
|
||||
submissionMultiArchive :: SubmissionDownloadAnonymous -> Set SubmissionId -> Handler TypedContent
|
||||
submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
(dbrunner, cleanup) <- getDBRunner
|
||||
|
||||
ratedSubmissions <- runDBRunner dbrunner $ do
|
||||
@ -299,16 +311,33 @@ submissionMultiArchive notAnonymized (Set.toList -> ids) = do
|
||||
dirFrag :: PathPiece p => p -> FilePath
|
||||
dirFrag = Text.unpack . toPathPiece
|
||||
|
||||
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
|
||||
userFeature :: SubmissionDownloadAnonymous -> Maybe (E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe Text)))
|
||||
userFeature SubmissionDownloadSurnames = Just $ E.just . (E.^. UserSurname)
|
||||
userFeature SubmissionDownloadMatriculations = Just $ E.castString . (E.^. UserMatrikelnummer)
|
||||
userFeature _ = Nothing
|
||||
|
||||
withNames fp
|
||||
| is _SubmissionDownloadGroups anonymous = do
|
||||
groups <- lift . E.select . 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_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
|
||||
E.where_ $ E.subSelectForeign submissionUser SubmissionUserSubmission (\submission -> E.subSelectForeign submission SubmissionSheet (E.^. SheetGrouping)) E.==. E.val RegisteredGroups
|
||||
return $ submissionGroup E.^. SubmissionGroupName
|
||||
let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
|
||||
return . intercalate "_" $ asciiGroups `snoc` fp
|
||||
| Just feature <- userFeature anonymous
|
||||
= do
|
||||
features <- 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 $ feature user
|
||||
let asciiFeatures = sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features
|
||||
return . intercalate "_" $ asciiFeatures `snoc` fp
|
||||
| otherwise = return fp
|
||||
|
||||
notAnonymized' <- and2M
|
||||
(return notAnonymized)
|
||||
(return $ isn't _SubmissionDownloadAnonymous anonymous)
|
||||
(or2M (return $ not sheetAnonymous) (hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR))
|
||||
|
||||
submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission)
|
||||
@ -707,7 +736,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
sId <- decrypt (cID :: CryptoFileNameSubmission)
|
||||
Just sId <$ get404 sId
|
||||
| otherwise = return Nothing
|
||||
Alt msId <- lift . flip foldMapM segments' $ \seg -> Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
|
||||
Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
|
||||
return (msId, fp)
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
|
||||
case msId of
|
||||
|
||||
@ -59,7 +59,7 @@ import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Min(..), Max(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..))
|
||||
import Data.Binary as Import (Binary)
|
||||
import Data.Binary.Instances as Import ()
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user