Add AUTO_TEAM option

This commit is contained in:
Filip Gralinski 2021-06-29 08:48:58 +02:00
parent 96d03875d7
commit ed06220ce0
3 changed files with 38 additions and 13 deletions

View File

@ -580,7 +580,9 @@ getChallengeSubmissionR challengeName = do
Entity userId _ <- requireAuth
(formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo)
defaultTeam <- fetchDefaultTeam userId
(formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) (Just defaultTeam)
challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge
@ -666,7 +668,7 @@ postChallengeSubmissionJsonR challengeName = do
Entity userId _ <- requireAuthPossiblyByToken
challengeEnt@(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing
((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing Nothing
let submissionData' = case result of
FormSuccess res -> Just res
_ -> Nothing
@ -704,7 +706,7 @@ postChallengeSubmissionR challengeName = do
userId <- requireAuthId
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName
((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing
((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing Nothing
let submissionData' = case result of
FormSuccess res -> Just res
_ -> Nothing
@ -897,7 +899,9 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
extractionOptionsExternalLinks = Nothing,
extractionOptionsDependencies = Nothing })
let mTeamId = challengeSubmissionDataTeam challengeSubmissionData
mTeamId <- case challengeSubmissionDataTeam challengeSubmissionData of
Just tid -> return $ Just tid
Nothing -> fetchDefaultTeam userId
submissionId <- getSubmission userId
mTeamId
@ -1079,22 +1083,34 @@ data ChallengeSubmissionData = ChallengeSubmissionData {
challengeSubmissionDataTeam :: Maybe TeamId }
fetchUserTeams :: (YesodPersist site, BackendCompatible SqlBackend (YesodPersistBackend site), PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site)) => Key User -> HandlerFor site [Entity Team]
fetchUserTeams userId = runDB $ E.select $ E.from $ \(team, teamMember) -> do
E.where_ (teamMember ^. TeamMemberTeam E.==. team ^. TeamId
E.&&. teamMember ^. TeamMemberUser E.==. E.val userId)
E.orderBy [E.desc (teamMember ^. TeamMemberIsCaptain), E.asc (team ^. TeamIdent)]
return team
submissionForm userId defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
fetchDefaultTeam :: Key User -> HandlerFor App (Maybe (Key Team))
fetchDefaultTeam userId = do
myTeams <- fetchUserTeams userId
app <- getYesod
let autoTeam = appAutoTeam $ appSettings app
if autoTeam
then
return $ entityKey <$> listToMaybe myTeams
else
return Nothing
submissionForm userId defaultUrl defBranch defaultGitAnnexRemote defaultTeam = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
<$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing
<*> (RepoSpec <$> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) defBranch
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
<*> aopt (selectField teams) (bfs MsgAsTeam) Nothing
<*> aopt (selectField teams) (bfs MsgAsTeam) defaultTeam
where teams = do
myTeams <- runDB $ E.select $ E.from $ \(team, teamMember) -> do
E.where_ (teamMember ^. TeamMemberTeam E.==. team ^. TeamId
E.&&. teamMember ^. TeamMemberUser E.==. E.val userId)
E.orderBy [E.asc (team ^. TeamIdent)]
E.limit 1
return team
myTeams <- fetchUserTeams userId
optionsPairs $ map (\t -> (teamIdent $ entityVal t, entityKey t)) myTeams

View File

@ -110,6 +110,10 @@ data AppSettings = AppSettings
-- ^ Take the team name from a given metadata field
-- Currently makes sense only when JWT token is used
, appTeamField :: Maybe Text
-- ^ Automatically assign the team.
-- The team for which the user is the captain
-- will be preferred
, appAutoTeam :: Bool
}
instance FromJSON AppSettings where
@ -161,6 +165,8 @@ instance FromJSON AppSettings where
appTeamField <- o .:? "team-field"
appAutoTeam <- o .:? "auto-team" .!= False
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and

View File

@ -76,4 +76,7 @@ json-web-key: "_env:JSON_WEB_KEY"
# If one of these is set, it is not considered a part of the username.
team-field: "_env:TEAM_FIELD"
# Whether to automatically assign teams for submissions.
auto-team: "_env:AUTO_TEAM:false"
#analytics: UA-YOURCODE