fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(load): allow creation of submissions without login (w/ token)

Browse Source
This commit is contained in:
Gregor Kleen 2020-05-22 14:31:19 +02:00
parent 002775e192
commit 2e826d3c45
6 changed files with 41 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/submissions.model
View File

@ -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

8
src/Handler/Corrections.hs
View File

@ -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

2
src/Handler/Profile.hs
View File

@ -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

52
src/Handler/Submission.hs
View File

@ -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

8
src/Handler/Utils/Submission.hs
View File

@ -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"

6
test/Database/Fill.hs
View File

@ -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