From 029ff775a4dbb9c028ec48fa4c67814e8c5b937f Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Wed, 27 Sep 2017 22:44:00 +0200 Subject: [PATCH] take description & tags from commit log message --- Handler/Shared.hs | 12 ++++++ Handler/ShowChallenge.hs | 83 +++++++++++++++++++++++++++++++++++----- Handler/YourAccount.hs | 5 +-- gonito.cabal | 1 + messages/en.msg | 1 + 5 files changed, 89 insertions(+), 13 deletions(-) diff --git a/Handler/Shared.hs b/Handler/Shared.hs index d837bbd..e7e26cf 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -30,6 +30,8 @@ import qualified Data.ByteString as BS import Text.Printf import Database.Persist.Sql +import Yesod.Form.Bootstrap3 (bfs) + atom = Control.Concurrent.STM.atomically type Channel = TChan (Maybe Text) @@ -153,6 +155,13 @@ getHeadCommit repoDir chan = do err chan "cannot determine HEAD commit" return Nothing +getLastCommitMessage :: FilePath -> Channel -> Handler (Maybe Text) +getLastCommitMessage repoDir chan = do + (exitCode, out) <- runProgram (Just repoDir) gitPath ["log", "-1", "--pretty=%B"] chan + return $ case exitCode of + ExitSuccess -> Just out + ExitFailure _ -> Nothing + cloneRepo' :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo)) cloneRepo' url branch referenceUrl referenceBranch chan = do msg chan $ concat ["Preparing to clone repo ", url] @@ -324,3 +333,6 @@ formatSubmitter user = if userIsAnonymous user case userName user of Just name -> name Nothing -> "[name not given]" + +fieldWithTooltip :: forall master msg msg1. (RenderMessage master msg, RenderMessage master msg1) => msg -> msg1 -> FieldSettings master +fieldWithTooltip name tooltip = (bfs name) { fsTooltip = Just $ SomeMessage tooltip } diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 9edb6ab..3c66e5e 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -30,6 +30,10 @@ import Options.Applicative import System.IO (readFile) +import Data.Attoparsec.Text + +import Data.Text (pack) + getShowChallengeR :: Text -> Handler Html getShowChallengeR name = do (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name @@ -107,19 +111,25 @@ postChallengeSubmissionR name = do let submissionData = case result of FormSuccess res -> Just res _ -> Nothing - Just (description, mTags, submissionUrl, submissionBranch) = submissionData + Just (mDescription, mTags, submissionUrl, submissionBranch) = submissionData - runViewProgress $ doCreateSubmission challengeId description mTags submissionUrl submissionBranch + runViewProgress $ doCreateSubmission challengeId mDescription mTags submissionUrl submissionBranch -doCreateSubmission :: Key Challenge -> Text -> Maybe Text -> Text -> Text -> Channel -> Handler () -doCreateSubmission challengeId description mTags url branch chan = do +doCreateSubmission :: Key Challenge -> Maybe Text -> Maybe Text -> Text -> Text -> Channel -> Handler () +doCreateSubmission challengeId mDescription mTags url branch chan = do maybeRepoKey <- getSubmissionRepo challengeId url branch chan case maybeRepoKey of Just repoId -> do repo <- runDB $ get404 repoId - submissionId <- getSubmission repoId (repoCurrentCommit repo) challengeId description chan + + repoDir <- getRepoDir repoId + commitMessage <- getLastCommitMessage repoDir chan + let (mCommitDescription, mCommitTags) = parseCommitMessage commitMessage + + submissionId <- getSubmission repoId (repoCurrentCommit repo) challengeId (fromMaybe (fromMaybe "???" mCommitDescription) mDescription) chan _ <- getOuts chan submissionId - runDB $ addTags submissionId mTags [] + + runDB $ addTags submissionId (if isNothing mTags then mCommitTags else mTags) [] msg chan "Done" Nothing -> return () @@ -128,7 +138,7 @@ getSubmission repoId commit challengeId description chan = do maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId userId <- requireAuthId case maybeSubmission of - Just (Entity submissionId submission) -> do + Just (Entity submissionId _) -> do msg chan "Submission already there, re-checking" return submissionId Nothing -> do @@ -143,6 +153,59 @@ getSubmission repoId commit challengeId description chan = do submissionSubmitter=userId, submissionIsPublic=False } +parseCommitMessage :: Maybe Text -> (Maybe Text, Maybe Text) +parseCommitMessage Nothing = (Nothing, Nothing) +parseCommitMessage (Just commitMessage) = + case parseOnly commitMessageParser commitMessage of + Left _ -> (Nothing, Nothing) + Right (d, ts) -> (d, ts) + +commitMessageParser :: Data.Attoparsec.Text.Parser (Maybe Text, Maybe Text) +commitMessageParser = do + skipMany emptyLine + d <- nonEmptyLine + mTs <- (do + ts <- findTagsLine + return $ Just ts) <|> (return Nothing) + return (Just d, mTs) + +findTagsLine :: Data.Attoparsec.Text.Parser Text +findTagsLine = tagsLine <|> (anyLine >> findTagsLine) + +tagsLine :: Data.Attoparsec.Text.Parser Text +tagsLine = do + (string "tags" <|> string "labels" <|> string "Tags" <|> string "Labels") + char ':' + skipMany space + s <- many notEndOfLine + endOfLine + return $ Data.Text.pack s + +commaSep p = p `sepBy` (skipMany space *> char ',' *> skipMany space) + +nonEmptyLine :: Data.Attoparsec.Text.Parser Text +nonEmptyLine = do + skipMany space + l1 <- notSpace + l <- (many notEndOfLine) + endOfLine + return $ Data.Text.pack (l1:l) + +anyLine :: Data.Attoparsec.Text.Parser () +anyLine = do + skipMany notEndOfLine + endOfLine + +notSpace :: Data.Attoparsec.Text.Parser Char +notSpace = satisfy (\c -> c /= '\r' && c /= '\n' && c /= ' ' && c /= '\t') + +notEndOfLine :: Data.Attoparsec.Text.Parser Char +notEndOfLine = satisfy (\c -> c /= '\r' && c /= '\n') + +emptyLine = do + many space + endOfLine + getOuts :: Channel -> Key Submission -> Handler ([Out]) getOuts chan submissionId = do submission <- runDB $ get404 submissionId @@ -206,7 +269,7 @@ checkOrInsertEvaluation repoDir chan out = do err chan $ "Evaluation failed: " ++ (T.pack $ show exception) rawEval :: FilePath -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) -rawEval challengeDir repoDir name = try (runGEvalGetOptions [ +rawEval challengeDir repoDir name = Import.try (runGEvalGetOptions [ "--expected-directory", challengeDir, "--out-directory", repoDir, "--test-name", (T.unpack name)]) @@ -256,9 +319,9 @@ checkRepoAvailibility challengeId repoId chan = do challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission") -submissionForm :: Maybe Text -> Form (Text, Maybe Text, Text, Text) +submissionForm :: Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text) submissionForm defaultUrl = renderBootstrap3 BootstrapBasicForm $ (,,,) - <$> areq textField (bfs MsgSubmissionDescription) Nothing + <$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing <*> aopt textField (tagsfs MsgSubmissionTags) Nothing <*> areq textField (bfs MsgSubmissionUrl) defaultUrl <*> areq textField (bfs MsgSubmissionBranch) (Just "master") diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index 03e3e81..e3ce000 100644 --- a/Handler/YourAccount.hs +++ b/Handler/YourAccount.hs @@ -11,6 +11,8 @@ import qualified Data.ByteString.Lazy as L import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage) +import Handler.Shared + getYourAccountR :: Handler Html getYourAccountR = do userId <- requireAuthId @@ -51,9 +53,6 @@ checkPassword (Just passwd) = isPasswordAcceptable passwd autocompleteOff name tooltip = setts { fsAttrs = (fsAttrs setts) ++ [("autocomplete", "nope")]} where setts = (bfs name) { fsTooltip = Just $ SomeMessage tooltip } -fieldWithTooltip :: forall master msg msg1. (RenderMessage master msg, RenderMessage master msg1) => msg -> msg1 -> FieldSettings master -fieldWithTooltip name tooltip = (bfs name) { fsTooltip = Just $ SomeMessage tooltip } - yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Bool -> Form (Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe FileInfo, Bool) yourAccountForm maybeName maybeLocalId maybeSshPubKey anonimised = renderBootstrap3 BootstrapBasicForm $ (,,,,,) <$> aopt textField (fieldWithTooltip MsgAccountName MsgAccountNameTooltip) (Just maybeName) diff --git a/gonito.cabal b/gonito.cabal index 57fb33c..d575e5a 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -136,6 +136,7 @@ library , nonce , esqueleto , extra + , attoparsec executable gonito if flag(library-only) diff --git a/messages/en.msg b/messages/en.msg index 50a12fc..6881a9d 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -47,3 +47,4 @@ AchievementPoints: points WantToBeAnonimised: I want to stay anonymous for other user of Gonito.net YourScore: your score PasswordForNewAccount: enter a password for your new account +SubmissionDescriptionTooltip: the first non-empty line of the commit message will be used, if this is left empty