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

fix(submission-form): fix display of all courseParticipants

Browse Source
This commit is contained in:
Gregor Kleen 2019-10-23 11:57:27 +02:00
parent 38e511291e
commit b67819d061
2 changed files with 25 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/Handler/Submission.hs
View File

@ -155,9 +155,24 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return user return user
previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
previousCoSubmittors uid = E.from $ \(user `E.InnerJoin` submissionUser `E.InnerJoin` submission `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.&&. sheet E.^. SheetCourse E.==. E.val cid
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
E.where_ . E.exists . E.from $ \submissionUser' ->
E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid
E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.orderBy [E.asc $ user E.^. UserEmail]
return user
addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Bool -> Field m (Set (Either UserEmail UserId)) addField, addFieldLecturer :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId))
addField isAdmin = multiUserField True $ courseUsers <$ guard isAdmin addField = addField' False
addFieldLecturer = addField' True
addField' isAdmin uid = multiUserField True . Just $ if
| isAdmin -> courseUsers
| otherwise -> previousCoSubmittors uid
addFieldSettings, submittorSettings, singleSubSettings :: FieldSettings UniWorX addFieldSettings, submittorSettings, singleSubSettings :: FieldSettings UniWorX
addFieldSettings = fslI MsgSubmissionMembers addFieldSettings = fslI MsgSubmissionMembers
@ -176,12 +191,13 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag) miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
submittorsForm submittorsForm
| isLecturer = do-- Form is being used by lecturer; allow Everything™ | isLecturer = do -- Form is being used by lecturer; allow Everything™
uid <- liftHandler requireAuthId
let let
miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd nudge btn csrf = do miAdd nudge btn csrf = do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing (addRes, addView) <- mpreq (addFieldLecturer uid) (addFieldSettings & addName (nudge "emails")) Nothing
let addRes' = addRes <&> \newData oldData -> if let addRes' = addRes <&> \newData oldData -> if
| existing <- newData `Set.intersection` Set.fromList oldData | existing <- newData `Set.intersection` Set.fromList oldData
, not $ Set.null existing , not $ Set.null existing
@ -208,7 +224,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge btn = Just $ \csrf -> do miAdd _ _ nudge btn = Just $ \csrf -> do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing (addRes, addView) <- mpreq (addField uid) (addFieldSettings & addName (nudge "emails")) Nothing
let addRes' = addRes <&> \newData oldData -> if let addRes' = addRes <&> \newData oldData -> if
| existing <- newData `Set.intersection` setOf folded oldData | existing <- newData `Set.intersection` setOf folded oldData
, not $ Set.null existing , not $ Set.null existing

7
src/Handler/Utils/Form.hs
View File

@ -1126,14 +1126,15 @@ multiUserField onlySuggested suggestions = Field{..}
|] |]
whenIsJust suggestions $ \suggestions' -> do whenIsJust suggestions $ \suggestions' -> do
suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandler . runDB . E.select $ do suggestedEmails <- fmap (Set.fromList . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
user <- suggestions' user <- suggestions'
return $ user E.^. UserEmail return $ (user E.^. UserEmail, user E.^. UserDisplayName)
[whamlet| [whamlet|
$newline never $newline never
<datalist id=#{datalistId}> <datalist id=#{datalistId}>
$forall email <- suggestedEmails $forall (email, dName) <- suggestedEmails
<option value=#{email}> <option value=#{email}>
#{email} (#{dName})
|] |]
fieldParse (all Text.null -> True) _ = return $ Right Nothing fieldParse (all Text.null -> True) _ = return $ Right Nothing
fieldParse ts _ = runExceptT . fmap Just $ do fieldParse ts _ = runExceptT . fmap Just $ do