From af2c789a837b7d663d02332dba189c9069488c0d Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Wed, 3 Mar 2021 13:15:38 +0100 Subject: [PATCH] A solution can be submitted as team --- Handler/ShowChallenge.hs | 35 +++++++++++++----- Handler/Team.hs | 79 ++++++++++++++++++++++++++++++++++++++++ config/models | 2 +- messages/en.msg | 1 + 4 files changed, 107 insertions(+), 10 deletions(-) create mode 100644 Handler/Team.hs diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 02599c9..aaa62f8 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -434,7 +434,9 @@ getChallengeSubmissionR challengeName = do let defaultUrl = fromMaybe (defaultRepo scheme repoHost challenge repo maybeUser) ((<> challengeName) <$> (join $ userAltRepoScheme <$> entityVal <$> maybeUser)) - (formWidget, formEnctype) <- generateFormPost $ submissionForm (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) + Entity userId _ <- requireAuth + + (formWidget, formEnctype) <- generateFormPost $ submissionForm userId (Just defaultUrl) (defaultBranch scheme) (repoGitAnnexRemote repo) challengeLayout True challenge $ challengeSubmissionWidget formWidget formEnctype challenge @@ -520,7 +522,7 @@ postChallengeSubmissionJsonR challengeName = do Entity userId _ <- requireAuthPossiblyByToken challengeEnt@(Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName - ((result, _), _) <- runFormPostNoToken $ submissionForm Nothing Nothing Nothing + ((result, _), _) <- runFormPostNoToken $ submissionForm userId Nothing Nothing Nothing let submissionData' = case result of FormSuccess res -> Just res _ -> Nothing @@ -558,7 +560,7 @@ postChallengeSubmissionR challengeName = do userId <- requireAuthId (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName - ((result, _), _) <- runFormPost $ submissionForm Nothing Nothing Nothing + ((result, _), _) <- runFormPost $ submissionForm userId Nothing Nothing Nothing let submissionData' = case result of FormSuccess res -> Just res _ -> Nothing @@ -750,7 +752,10 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do extractionOptionsExternalLinks = Nothing, extractionOptionsDependencies = Nothing }) + let mTeamId = challengeSubmissionDataTeam challengeSubmissionData + submissionId <- getSubmission userId + mTeamId repoId (repoCurrentCommit repo) challengeId @@ -876,8 +881,8 @@ getScoreForOut mainTestId out = do Just evaluation -> evaluationScore $ entityVal evaluation Nothing -> Nothing -getSubmission :: UserId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission) -getSubmission userId repoId commit challengeId subDescription chan = do +getSubmission :: UserId -> Maybe TeamId -> Key Repo -> SHA1 -> Key Challenge -> Text -> Channel -> Handler (Key Submission) +getSubmission userId mTeamId repoId commit challengeId subDescription chan = do challenge <- runDB $ get404 challengeId maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId case maybeSubmission of @@ -897,7 +902,7 @@ getSubmission userId repoId commit challengeId subDescription chan = do submissionIsPublic=False, submissionIsHidden=False, submissionVersion=challengeVersion challenge, - submissionTeam=Nothing } + submissionTeam=mTeamId } getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo)) getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan @@ -925,16 +930,28 @@ challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "chall data ChallengeSubmissionData = ChallengeSubmissionData { challengeSubmissionDataDescription :: Maybe Text, challengeSubmissionDataTags :: Maybe Text, - challengeSubmissionDataRepo :: RepoSpec } + challengeSubmissionDataRepo :: RepoSpec, + challengeSubmissionDataTeam :: Maybe TeamId } -submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form ChallengeSubmissionData -submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData + +submissionForm userId defaultUrl defBranch defaultGitAnnexRemote = 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 + 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 + + optionsPairs $ map (\t -> (teamIdent $ entityVal t, entityKey t)) myTeams + getUserInfoR :: Handler Value getUserInfoR = do diff --git a/Handler/Team.hs b/Handler/Team.hs new file mode 100644 index 0000000..106731c --- /dev/null +++ b/Handler/Team.hs @@ -0,0 +1,79 @@ +module Handler.Team where + +import Import + +import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) + +import Handler.Shared (fieldWithTooltip) + +import PersistTeamActionType + +import Data.Conduit.Binary +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +getMyTeamsR :: Handler Html +getMyTeamsR = do + _ <- requireAuth + doMyTeams + +data TeamCreationData = TeamCreationData { + teamCreationTeamIdent :: Text, + teamCreationTeamAvatar :: Maybe FileInfo } + +postCreateTeamR :: Handler Html +postCreateTeamR = do + Entity userId _ <- requireAuth + ((result, _), _) <- runFormPost createTeamForm + case result of + FormSuccess teamCreationData -> do + runDB $ createTeam userId teamCreationData + _ -> do + return () + doMyTeams + +createTeam :: (PersistStoreWrite backend, MonadUnliftIO m, BaseBackend backend ~ SqlBackend) + => Key User -> TeamCreationData -> ReaderT backend m () +createTeam userId teamCreationData = do + let theIdent = teamCreationTeamIdent teamCreationData + let theAvatar = teamCreationTeamAvatar teamCreationData + + avatarBytes <- case theAvatar of + Just avatarFile -> do + fileBytes <- runResourceT $ fileSource avatarFile $$ sinkLbs + return $ Just (S.pack . L.unpack $ fileBytes) + Nothing -> return Nothing + + newTeamId <- insert Team { + teamIdent = theIdent, + teamAvatar = avatarBytes } + + _ <- insert TeamMember { + teamMemberUser = userId, + teamMemberTeam = newTeamId, + teamMemberIsCaptain = True + } + + theNow <- liftIO getCurrentTime + + _ <- insert TeamLog { + teamLogStamp = theNow, + teamLogActionType = TeamCreation, + teamLogAgens = userId, + teamLogPatiens = Nothing, + teamLogVerificationKey = Nothing + } + + return () + +doMyTeams :: Handler Html +doMyTeams = do + (formWidget, formEnctype) <- generateFormPost createTeamForm + defaultLayout $ do + setTitle "Teams" + $(widgetFile "my-teams") + +createTeamForm :: Form TeamCreationData +createTeamForm = renderBootstrap3 BootstrapBasicForm $ TeamCreationData + <$> areq textField (fieldWithTooltip MsgTeamIdent MsgTeamIdentTooltip) Nothing + <*> fileAFormOpt (bfs MsgAvatar) diff --git a/config/models b/config/models index c9b2e86..24f7c03 100644 --- a/config/models +++ b/config/models @@ -104,7 +104,7 @@ Submission isHidden Bool default=False -- challenge version present when the submission was done version SHA1 - team UserId Maybe + team TeamId Maybe UniqueSubmissionRepoCommitChallenge repo commit challenge Variant submission SubmissionId diff --git a/messages/en.msg b/messages/en.msg index cc06503..0248cec 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -102,3 +102,4 @@ Heal: Heal TeamIdent: Team name TeamIdentTooltip: Note that it cannot be changed later YourTeams: your teams +AsTeam: As team