diff --git a/models/submissions.model b/models/submissions.model index c29e0373f..e7e85f02c 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -7,7 +7,7 @@ Submission -- submission for marking by a CourseParticipa ratingTime UTCTime Maybe -- "Just" here indicates done; marking is made visible to participant deriving Show Generic SubmissionEdit -- user uploads new version of their submission - user UserId -- track id, important for group submissions + user UserId Maybe -- track id, important for group submissions time UTCTime submission SubmissionId SubmissionFile -- files that are part of a submission diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 94da99e6a..24703e72e 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -847,7 +847,7 @@ postCorrectionR tid ssh csh shn cid = do redirect $ CSubmissionR tid ssh csh shn cid CorrectionR formResult uploadResult $ \fileUploads -> do - uid <- requireAuthId + uid <- maybeAuthId res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True case res of @@ -998,7 +998,7 @@ postCorrectionsCreateR = do in case sheetGrouping of Arbitrary maxSize -> do subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId + void . insert $ SubmissionEdit (Just uid) now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser @@ -1023,7 +1023,7 @@ postCorrectionsCreateR = do , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers -> do subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId + void . insert $ SubmissionEdit (Just uid) now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser { submissionUserUser = sheetUser @@ -1043,7 +1043,7 @@ postCorrectionsCreateR = do addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc NoGroups -> do subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId + void . insert $ SubmissionEdit (Just uid) now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 7efe43acd..e54e982b5 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -517,7 +517,7 @@ mkSubmissionTable = lastSubEdit uid submission = -- latest Edit-Time of this user for submission E.subSelectMaybe . E.from $ \subEdit -> do E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId - E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid + E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid) return . E.max_ $ subEdit E.^. SubmissionEditTime dbtProj x = return $ x diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 69da80c81..cdaf46ca8 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -184,12 +184,9 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident E.orderBy [E.asc $ user E.^. UserEmail] return user - addField, addFieldLecturer :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId)) - addField = addField' False - addFieldLecturer = addField' True - addField' isAdmin uid - | isAdmin = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers - | otherwise = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid + addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId)) + addField uid = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid + addFieldLecturer = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail @@ -210,12 +207,11 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident submittorsForm | isLecturer = do -- Form is being used by lecturer; allow Everything™ - uid <- liftHandler requireAuthId let miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) miAdd nudge btn csrf = do MsgRenderer mr <- getMsgRenderer - (addRes, addView) <- mpreq (addFieldLecturer uid) (addFieldSettings mr & addName (nudge "emails")) Nothing + (addRes, addView) <- mpreq addFieldLecturer (addFieldSettings mr & addName (nudge "emails")) Nothing let addRes' = addRes <&> \newData oldData -> if | existing <- newData `Set.intersection` Set.fromList oldData , not $ Set.null existing @@ -327,7 +323,7 @@ getSubmissionOwnR tid ssh csh shn = do submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html submissionHelper tid ssh csh shn mcid = do - uid <- requireAuthId + muid <- maybeAuthId msmid <- traverse decrypt mcid actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute @@ -338,7 +334,7 @@ submissionHelper tid ssh csh shn mcid = do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid + 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 @@ -357,20 +353,20 @@ submissionHelper tid ssh csh shn mcid = 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_ $ subUser E.^. SubmissionUserUser E.==. E.val uid + 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.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid + 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 (Set.insert $ Right uid) (not isLecturer)) + & assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer)) & fromMaybe Set.empty , [] , maySubmit @@ -385,9 +381,9 @@ submissionHelper tid ssh csh shn mcid = do 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_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ user E.^. UserId E.!=. E.val uid + 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 @@ -423,8 +419,8 @@ submissionHelper tid ssh csh shn mcid = do E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserId let breakUserFromBuddies (E.Value userID) - | uid == userID = (Any True , mempty ) - | otherwise = (mempty , Set.singleton $ Right userID) + | muid == Just userID = (Any True , mempty ) + | otherwise = (mempty , Set.singleton $ Right userID) invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) @@ -432,7 +428,7 @@ submissionHelper tid ssh csh shn mcid = do lastEdits <- do raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do - E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) + 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 @@ -445,9 +441,17 @@ submissionHelper tid ssh csh shn mcid = do 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 (Set.insert $ Right uid) isOwner buddies + ((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 @@ -513,7 +517,7 @@ submissionHelper tid ssh csh shn mcid = do (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid (Just files, _) -> -- new files - runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False + runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> do sid <- insert Submission @@ -535,7 +539,7 @@ submissionHelper tid ssh csh shn mcid = do groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do @@ -546,7 +550,7 @@ submissionHelper tid ssh csh shn mcid = do return $ submissionGroupUser' E.^. SubmissionGroupUserUser -- SubmissionUser for all group members (pre-registered & ad-hoc) - return $ Set.insert (Right uid) groupUids + return $ maybe id (Set.insert . Right) muid groupUids | otherwise -> return adhocMembers -- Since invitations carry no data we only need to consider changes to @@ -566,7 +570,7 @@ submissionHelper tid ssh csh shn mcid = do -- user exists and has an id => insert as SubmissionUser and audit insert_ $ SubmissionUser subUid smid audit $ TransactionSubmissionUserEdit smid subUid - unless (subUid == uid) $ + unless (Just subUid == muid) $ queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid -- change is an old user that is not a submission user anymore => delete invitation / delete | otherwise -> case change of @@ -574,7 +578,7 @@ submissionHelper tid ssh csh shn mcid = do Right subUid -> do deleteBy $ UniqueSubmissionUser subUid smid audit $ TransactionSubmissionUserDelete smid subUid - unless (subUid == uid) $ + unless (Just subUid == muid) $ queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 7e1e79356..f45158877 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -445,7 +445,7 @@ msgSubmissionErrors = flip catches ] . fmap Just -sinkSubmission :: UserId +sinkSubmission :: Maybe UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId @@ -564,7 +564,7 @@ sinkSubmission userId mExists isUpdate = do now <- liftIO getCurrentTime let - rated = submissionRatingBy submission == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files + rated = fromMaybe False $ (==) <$> submissionRatingBy submission <*> userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files r'@Rating'{..} = r { ratingTime = now <$ guard rated -- Ignore `ratingTime` from result @r@ of `parseRating` to ensure plausible timestamps (`parseRating` returns file modification time for consistency with `ratingFile`) } @@ -572,7 +572,7 @@ sinkSubmission userId mExists isUpdate = do { submissionRatingPoints = ratingPoints , submissionRatingComment = ratingComment , submissionRatingTime = ratingTime - , submissionRatingBy = userId <$ guard rated -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) + , submissionRatingBy = userId <* guard rated -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) } tellSt $ mempty{ sinkSeenRating = Last $ Just r' } @@ -726,7 +726,7 @@ sinkMultiSubmission userId isUpdate = do Sheet{..} <- get404 submissionSheet Course{..} <- get404 sheetCourse guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True - return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate + return . newResumableSink $ sinkSubmission (Just userId) (Right sId) isUpdate sink' <- lift $ yield val ++$$ sink case sink' of Left _ -> error "sinkSubmission returned prematurely" diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1bdefbe09..cfd1ab532 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -781,12 +781,12 @@ fillDb = do , submissionRatingAssigned = Just now , submissionRatingTime = Nothing } - void . insert $ SubmissionEdit maxMuster now sub1 + void . insert $ SubmissionEdit (Just maxMuster) now sub1 void . insert $ SubmissionUser maxMuster sub1 sub1fid1 <- insertFile "AbgabeH10-1.hs" void . insert $ SubmissionFile sub1 sub1fid1 False False sub2 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing - void . insert $ SubmissionEdit fhamann now sub2 + void . insert $ SubmissionEdit (Just fhamann) now sub2 void . insert $ SubmissionUser fhamann sub2 sh2 <- insert Sheet { sheetCourse = pmo @@ -1071,7 +1071,7 @@ fillDb = do , submissionRatingTime = Nothing } forM_ grpUsers $ void . insert . flip SubmissionUser sub - void . insert $ SubmissionEdit pUid now sub + void . insert $ SubmissionEdit (Just pUid) now sub _other -> return () forM_ ([1..100] :: [Int]) $ \n -> do