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
|
||||
actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
(Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner, msubmission, corrector) <- runDB $ do
|
||||
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
|
||||
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
|
||||
let
|
||||
getSheetInfo = do
|
||||
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
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
|
||||
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
||||
@ -220,121 +332,13 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
addMessageI Info MsgSubmissionAlreadyExists
|
||||
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
_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]
|
||||
|
||||
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)
|
||||
|
||||
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
|
||||
when ( is _Nothing muid
|
||||
&& is _Nothing msubmission
|
||||
&& not isLecturer
|
||||
)
|
||||
notAuthenticated
|
||||
|
||||
-- Determine old submission users
|
||||
subUsersOld <- if
|
||||
| Just smid <- msmid -> Set.union
|
||||
@ -475,6 +479,8 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
| otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
|
||||
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
|
||||
|
||||
-- Maybe construct a table to display uploaded archive files
|
||||
|
||||
Loading…
Reference in New Issue
Block a user