fix(submission): race condition allowed creating multiple subs
This commit is contained in:
Gregor Kleen
parent
de53c80a1e
commit
02fc0d476f
@ -204,10 +204,122 @@ submissionHelper tid ssh csh shn mcid = do
|
|||||||
msmid <- traverse decrypt mcid
|
msmid <- traverse decrypt mcid
|
||||||
actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
|
actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
|
||||||
|
|
||||||
(Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner, msubmission, corrector) <- runDB $ do
|
let
|
||||||
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
getSheetInfo = do
|
||||||
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
|
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||||
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
|
||||||
|
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
||||||
|
|
||||||
|
case (msmid, sheetGrouping) of
|
||||||
|
(Nothing, Arbitrary maxBuddies) -> do
|
||||||
|
-- fetch buddies from previous submission in this course
|
||||||
|
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||||
|
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
||||||
|
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
|
||||||
|
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
||||||
|
E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
||||||
|
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
|
||||||
|
E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid
|
||||||
|
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||||
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
||||||
|
E.limit 1
|
||||||
|
return $ submission E.^. SubmissionId
|
||||||
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
|
||||||
|
E.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid
|
||||||
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||||
|
return $ user E.^. UserId
|
||||||
|
return ( csheet
|
||||||
|
, buddies
|
||||||
|
& map (Right . E.unValue)
|
||||||
|
& Set.fromList
|
||||||
|
& assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer))
|
||||||
|
& fromMaybe Set.empty
|
||||||
|
, []
|
||||||
|
, maySubmit
|
||||||
|
, isLecturer
|
||||||
|
, not isLecturer
|
||||||
|
, Nothing, Nothing
|
||||||
|
)
|
||||||
|
(Nothing, RegisteredGroups) -> do
|
||||||
|
buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
|
||||||
|
E.on . E.exists . E.from $ \submissionGroupUser ->
|
||||||
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
|
||||||
|
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||||
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
||||||
|
E.where_ . E.exists . E.from $ \submissionGroupUser ->
|
||||||
|
E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
|
||||||
|
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||||
|
E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid
|
||||||
|
E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
||||||
|
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||||
|
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
||||||
|
E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||||
|
|
||||||
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||||
|
|
||||||
|
return $ user E.^. UserId
|
||||||
|
|
||||||
|
return ( csheet
|
||||||
|
, buddies
|
||||||
|
& map (Right . E.unValue)
|
||||||
|
& Set.fromList
|
||||||
|
, []
|
||||||
|
, maySubmit
|
||||||
|
, isLecturer
|
||||||
|
, not isLecturer
|
||||||
|
, Nothing, Nothing
|
||||||
|
)
|
||||||
|
(Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing)
|
||||||
|
(Just smid, _) -> do
|
||||||
|
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
|
||||||
|
|
||||||
|
sub@Submission{..} <- get404 smid
|
||||||
|
let shid' = submissionSheet
|
||||||
|
unless (shid == shid') $
|
||||||
|
invalidArgsI [MsgSubmissionWrongSheet]
|
||||||
|
-- fetch buddies from current submission
|
||||||
|
(Any isOwner, buddies) <- do
|
||||||
|
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||||
|
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
||||||
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
|
||||||
|
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||||
|
return $ user E.^. UserId
|
||||||
|
let breakUserFromBuddies (E.Value userID)
|
||||||
|
| muid == Just userID = (Any True , mempty )
|
||||||
|
| otherwise = (mempty , Set.singleton $ Right userID)
|
||||||
|
|
||||||
|
invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
|
||||||
|
|
||||||
|
return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
|
||||||
|
|
||||||
|
lastEdits <- do
|
||||||
|
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
||||||
|
E.on $ E.just (user E.^. UserId) E.==. submissionEdit E.^. SubmissionEditUser
|
||||||
|
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
|
||||||
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
||||||
|
-- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
|
||||||
|
let userName = if isOwner || maySubmit
|
||||||
|
then E.just $ user E.^. UserDisplayName
|
||||||
|
else E.nothing
|
||||||
|
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||||
|
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||||
|
|
||||||
|
corrector <- fmap join $ traverse getEntity submissionRatingBy
|
||||||
|
|
||||||
|
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
|
||||||
|
|
||||||
|
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
|
||||||
|
-- Therefore we do not restrict upload behaviour in any way in that case
|
||||||
|
((res,formWidget'), formEnctype) <- do
|
||||||
|
(Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo
|
||||||
|
runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
||||||
|
let formWidget = wrapForm' BtnHandIn formWidget' def
|
||||||
|
{ formAction = Just $ SomeRoute actionUrl
|
||||||
|
, formEncoding = formEnctype
|
||||||
|
}
|
||||||
|
|
||||||
|
mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
|
||||||
|
(Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo
|
||||||
|
|
||||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||||
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
||||||
@ -220,121 +332,13 @@ submissionHelper tid ssh csh shn mcid = do
|
|||||||
addMessageI Info MsgSubmissionAlreadyExists
|
addMessageI Info MsgSubmissionAlreadyExists
|
||||||
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||||
_other -> return ()
|
_other -> return ()
|
||||||
|
|
||||||
case (msmid, sheetGrouping) of
|
|
||||||
(Nothing, Arbitrary maxBuddies) -> do
|
|
||||||
-- fetch buddies from previous submission in this course
|
|
||||||
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
|
||||||
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
|
||||||
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
|
|
||||||
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
|
||||||
E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
|
||||||
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
|
|
||||||
E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid
|
|
||||||
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
|
|
||||||
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
|
||||||
E.limit 1
|
|
||||||
return $ submission E.^. SubmissionId
|
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
|
|
||||||
E.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid
|
|
||||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
||||||
return $ user E.^. UserId
|
|
||||||
return ( csheet
|
|
||||||
, buddies
|
|
||||||
& map (Right . E.unValue)
|
|
||||||
& Set.fromList
|
|
||||||
& assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer))
|
|
||||||
& fromMaybe Set.empty
|
|
||||||
, []
|
|
||||||
, maySubmit
|
|
||||||
, isLecturer
|
|
||||||
, not isLecturer
|
|
||||||
, Nothing, Nothing
|
|
||||||
)
|
|
||||||
(Nothing, RegisteredGroups) -> do
|
|
||||||
buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
|
|
||||||
E.on . E.exists . E.from $ \submissionGroupUser ->
|
|
||||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
|
|
||||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
||||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
|
|
||||||
E.where_ . E.exists . E.from $ \submissionGroupUser ->
|
|
||||||
E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
|
|
||||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
||||||
E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid
|
|
||||||
E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
|
|
||||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
|
||||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
|
|
||||||
E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
|
||||||
|
|
||||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
when ( is _Nothing muid
|
||||||
|
&& is _Nothing msubmission
|
||||||
return $ user E.^. UserId
|
&& not isLecturer
|
||||||
|
)
|
||||||
return ( csheet
|
notAuthenticated
|
||||||
, buddies
|
|
||||||
& map (Right . E.unValue)
|
|
||||||
& Set.fromList
|
|
||||||
, []
|
|
||||||
, maySubmit
|
|
||||||
, isLecturer
|
|
||||||
, not isLecturer
|
|
||||||
, Nothing, Nothing
|
|
||||||
)
|
|
||||||
(Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing)
|
|
||||||
(Just smid, _) -> do
|
|
||||||
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
|
|
||||||
|
|
||||||
sub@Submission{..} <- get404 smid
|
|
||||||
let shid' = submissionSheet
|
|
||||||
unless (shid == shid') $
|
|
||||||
invalidArgsI [MsgSubmissionWrongSheet]
|
|
||||||
-- fetch buddies from current submission
|
|
||||||
(Any isOwner, buddies) <- do
|
|
||||||
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
|
||||||
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
|
|
||||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
|
||||||
return $ user E.^. UserId
|
|
||||||
let breakUserFromBuddies (E.Value userID)
|
|
||||||
| muid == Just userID = (Any True , mempty )
|
|
||||||
| otherwise = (mempty , Set.singleton $ Right userID)
|
|
||||||
|
|
||||||
invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
|
|
||||||
|
|
||||||
return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
|
|
||||||
|
|
||||||
lastEdits <- do
|
|
||||||
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
|
|
||||||
E.on $ E.just (user E.^. UserId) E.==. submissionEdit E.^. SubmissionEditUser
|
|
||||||
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
|
|
||||||
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
|
||||||
-- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
|
|
||||||
let userName = if isOwner || maySubmit
|
|
||||||
then E.just $ user E.^. UserDisplayName
|
|
||||||
else E.nothing
|
|
||||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
|
||||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
|
||||||
|
|
||||||
corrector <- fmap join $ traverse getEntity submissionRatingBy
|
|
||||||
|
|
||||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
|
|
||||||
|
|
||||||
if | is _Nothing muid
|
|
||||||
, is _Nothing msubmission
|
|
||||||
, not isLecturer
|
|
||||||
-> notAuthenticated
|
|
||||||
| otherwise
|
|
||||||
-> return ()
|
|
||||||
|
|
||||||
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
|
|
||||||
-- Therefore we do not restrict upload behaviour in any way in that case
|
|
||||||
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
|
|
||||||
let formWidget = wrapForm' BtnHandIn formWidget' def
|
|
||||||
{ formAction = Just $ SomeRoute actionUrl
|
|
||||||
, formEncoding = formEnctype
|
|
||||||
}
|
|
||||||
|
|
||||||
mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
|
|
||||||
-- Determine old submission users
|
-- Determine old submission users
|
||||||
subUsersOld <- if
|
subUsersOld <- if
|
||||||
| Just smid <- msmid -> Set.union
|
| Just smid <- msmid -> Set.union
|
||||||
@ -475,6 +479,8 @@ submissionHelper tid ssh csh shn mcid = do
|
|||||||
| otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
|
| otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
|
|
||||||
|
(Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
|
||||||
|
|
||||||
showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
|
showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||||
|
|
||||||
-- Maybe construct a table to display uploaded archive files
|
-- Maybe construct a table to display uploaded archive files
|
||||||
|
|||||||
Reference in New Issue
Block a user