fix(submission): race condition allowed creating multiple subs

src/Handler/Submission/Helper.hs

@@ -204,23 +204,12 @@ 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
+  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
 
-    submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
-      E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
-      E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid
-           E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
-      return $ submission E.^. SubmissionId
-    case (msmid, submissions) of
-      (Nothing, E.Value smid : _) -> do
-        cID <- encrypt smid
-        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
@@ -319,22 +308,37 @@ submissionHelper tid ssh csh shn mcid = do
 
           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
+  ((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)
+      E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid
+           E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
+      return $ submission E.^. SubmissionId
+    case (msmid, submissions) of
+      (Nothing, E.Value smid : _) -> do
+        cID <- encrypt smid
+        addMessageI Info MsgSubmissionAlreadyExists
+        redirect $ CSubmissionR tid ssh csh shn cID SubShowR
+      _other -> return ()
+
+    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