Subtask for #233. Rights checked for Corrector assignment
This commit is contained in:
SJost
parent
b27fb8f391
commit
dc4f37c921
@ -231,6 +231,7 @@ CorrAutoSetCorrector: Korrekturen verteilen
|
||||
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
|
||||
|
||||
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
|
||||
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
|
||||
UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
|
||||
NoCorrector: Kein Korrektor
|
||||
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
|
||||
|
||||
4
routes
4
routes
@ -77,10 +77,10 @@
|
||||
/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
|
||||
/subs/own SubmissionOwnR GET !free -- just redirect
|
||||
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
|
||||
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner
|
||||
/assign SAssignR GET POST !lecturerANDtime
|
||||
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
|
||||
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
|
||||
/correctors SCorrR GET POST
|
||||
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions
|
||||
|
||||
@ -302,9 +302,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
|
||||
unless (null unassigned) $ do
|
||||
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
|
||||
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
|
||||
unless (null unassignedUnauth) $ do
|
||||
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
|
||||
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
|
||||
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
|
||||
unless (null unassignedAuth) $ do
|
||||
num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth]
|
||||
[ SubmissionRatingBy =. Just uid
|
||||
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
|
||||
]
|
||||
@ -316,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
|
||||
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
num <- updateWhereCount [SubmissionId <-. subs]
|
||||
[ SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
[ SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingAssigned =. Nothing
|
||||
, SubmissionRatingTime =. Nothing
|
||||
-- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector
|
||||
-- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector
|
||||
]
|
||||
addMessageI Success $ MsgRemovedCorrections num
|
||||
redirect currentRoute
|
||||
@ -337,8 +341,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
unless (null unassigned) $ do
|
||||
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned)
|
||||
(unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
|
||||
unless (null unassignedUnauth) $ do
|
||||
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
|
||||
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
|
||||
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
|
||||
unless (null unassignedAuth) $ do
|
||||
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
|
||||
unless (null assigned) $
|
||||
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
|
||||
unless (null stillUnassigned) $ do
|
||||
@ -350,7 +359,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
setTitleI MsgCourseCorrectionsTitle
|
||||
$(widgetFile "corrections")
|
||||
|
||||
where
|
||||
authorizedToAssign :: SubmissionId -> DB Bool
|
||||
authorizedToAssign sId = do
|
||||
[(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
|
||||
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ submission E.^. SubmissionId E.==. E.val sId
|
||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
|
||||
cID <- encrypt sId
|
||||
let route = CSubmissionR tid ssh csh shn cID SAssignR
|
||||
(== Authorized) <$> evalAccessDB route True
|
||||
|
||||
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
|
||||
|
||||
@ -768,12 +788,12 @@ postSAssignR tid ssh csh shn cID = do
|
||||
sId <- decrypt cID
|
||||
(currentCorrector, sheetCorrectors) <- runDB $ do
|
||||
Submission{submissionRatingBy, submissionSheet} <- get404 sId
|
||||
-- Beginn Verify that CryptoId matches ordinary prameters
|
||||
-- Beginn Verify that CryptoId matches ordinary prameters, see #233
|
||||
-- Necessarry, since authorisation checks those parameters only, but can be changed by user!
|
||||
Sheet{sheetCourse, sheetName} <- get404 submissionSheet
|
||||
Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse
|
||||
let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName]
|
||||
unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch]
|
||||
unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] -- maybe remove message if refactored
|
||||
-- End Verification
|
||||
sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
|
||||
userCorrector <- traverse getJustEntity submissionRatingBy
|
||||
|
||||
20
src/Utils.hs
20
src/Utils.hs
@ -306,9 +306,9 @@ ifMaybeM (Just x) _ act = act x
|
||||
|
||||
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
|
||||
maybePositive a | a > 0 = Just a
|
||||
| otherwise = Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
|
||||
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
|
||||
positiveSum (Sum x) = maybePositive x
|
||||
|
||||
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
|
||||
@ -443,6 +443,22 @@ orM = Fold.foldr or2M (return False)
|
||||
anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
|
||||
anyM xs f = orM $ fmap f xs
|
||||
|
||||
partitionM :: forall mono m .
|
||||
( MonoFoldable mono
|
||||
, Monoid mono
|
||||
, MonoPointed mono
|
||||
, Monad m)
|
||||
=> (Element mono -> m Bool) -> mono -> m (mono, mono)
|
||||
partitionM crit = ofoldlM dist mempty
|
||||
where
|
||||
dist :: (mono,mono) -> Element mono -> m (mono,mono)
|
||||
dist acc x = do
|
||||
okay <- crit x
|
||||
return $ if
|
||||
| okay -> acc `mappend` (opoint x, mempty)
|
||||
| otherwise -> acc `mappend` (mempty, opoint x)
|
||||
|
||||
|
||||
--------------
|
||||
-- Sessions --
|
||||
--------------
|
||||
|
||||
5
templates/messages/submissionsAssignUnauthorized.hamlet
Normal file
5
templates/messages/submissionsAssignUnauthorized.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
|
||||
|
||||
<ul>
|
||||
$forall cID <- unassignedUnauth'
|
||||
<li><pre>#{toPathPiece cID}
|
||||
Loading…
Reference in New Issue
Block a user