From ed06220ce0654de7f717092a9b0a215d0e35e3c3 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Tue, 29 Jun 2021 08:48:58 +0200 Subject: [PATCH] Add AUTO_TEAM option --- Handler/ShowChallenge.hs | 42 +++++++++++++++++++++++++++------------- Settings.hs | 6 ++++++ config/settings.yml | 3 +++ 3 files changed, 38 insertions(+), 13 deletions(-) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 4933a16..58af415 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -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 diff --git a/Settings.hs b/Settings.hs index 2f43332..242e6a0 100644 --- a/Settings.hs +++ b/Settings.hs @@ -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 diff --git a/config/settings.yml b/config/settings.yml index 943fe7b..a41bc0e 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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