diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index dc1b0141f..d808b501d 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -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