take description & tags from commit log message

This commit is contained in:
Filip Gralinski 2017-09-27 22:44:00 +02:00
parent ef00b8d9d1
commit 029ff775a4
5 changed files with 89 additions and 13 deletions

View File

@ -30,6 +30,8 @@ import qualified Data.ByteString as BS
import Text.Printf import Text.Printf
import Database.Persist.Sql import Database.Persist.Sql
import Yesod.Form.Bootstrap3 (bfs)
atom = Control.Concurrent.STM.atomically atom = Control.Concurrent.STM.atomically
type Channel = TChan (Maybe Text) type Channel = TChan (Maybe Text)
@ -153,6 +155,13 @@ getHeadCommit repoDir chan = do
err chan "cannot determine HEAD commit" err chan "cannot determine HEAD commit"
return Nothing 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' :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
cloneRepo' url branch referenceUrl referenceBranch chan = do cloneRepo' url branch referenceUrl referenceBranch chan = do
msg chan $ concat ["Preparing to clone repo ", url] msg chan $ concat ["Preparing to clone repo ", url]
@ -324,3 +333,6 @@ formatSubmitter user = if userIsAnonymous user
case userName user of case userName user of
Just name -> name Just name -> name
Nothing -> "[name not given]" 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 }

View File

@ -30,6 +30,10 @@ import Options.Applicative
import System.IO (readFile) import System.IO (readFile)
import Data.Attoparsec.Text
import Data.Text (pack)
getShowChallengeR :: Text -> Handler Html getShowChallengeR :: Text -> Handler Html
getShowChallengeR name = do getShowChallengeR name = do
(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
@ -107,19 +111,25 @@ postChallengeSubmissionR name = do
let submissionData = case result of let submissionData = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> 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 :: Key Challenge -> Maybe Text -> Maybe Text -> Text -> Text -> Channel -> Handler ()
doCreateSubmission challengeId description mTags url branch chan = do doCreateSubmission challengeId mDescription mTags url branch chan = do
maybeRepoKey <- getSubmissionRepo challengeId url branch chan maybeRepoKey <- getSubmissionRepo challengeId url branch chan
case maybeRepoKey of case maybeRepoKey of
Just repoId -> do Just repoId -> do
repo <- runDB $ get404 repoId 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 _ <- getOuts chan submissionId
runDB $ addTags submissionId mTags []
runDB $ addTags submissionId (if isNothing mTags then mCommitTags else mTags) []
msg chan "Done" msg chan "Done"
Nothing -> return () Nothing -> return ()
@ -128,7 +138,7 @@ getSubmission repoId commit challengeId description chan = do
maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId maybeSubmission <- runDB $ getBy $ UniqueSubmissionRepoCommitChallenge repoId commit challengeId
userId <- requireAuthId userId <- requireAuthId
case maybeSubmission of case maybeSubmission of
Just (Entity submissionId submission) -> do Just (Entity submissionId _) -> do
msg chan "Submission already there, re-checking" msg chan "Submission already there, re-checking"
return submissionId return submissionId
Nothing -> do Nothing -> do
@ -143,6 +153,59 @@ getSubmission repoId commit challengeId description chan = do
submissionSubmitter=userId, submissionSubmitter=userId,
submissionIsPublic=False } 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 :: Channel -> Key Submission -> Handler ([Out])
getOuts chan submissionId = do getOuts chan submissionId = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
@ -206,7 +269,7 @@ checkOrInsertEvaluation repoDir chan out = do
err chan $ "Evaluation failed: " ++ (T.pack $ show exception) err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
rawEval :: FilePath -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) 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, "--expected-directory", challengeDir,
"--out-directory", repoDir, "--out-directory", repoDir,
"--test-name", (T.unpack name)]) "--test-name", (T.unpack name)])
@ -256,9 +319,9 @@ checkRepoAvailibility challengeId repoId chan = do
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission") 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 $ (,,,) submissionForm defaultUrl = renderBootstrap3 BootstrapBasicForm $ (,,,)
<$> areq textField (bfs MsgSubmissionDescription) Nothing <$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing <*> aopt textField (tagsfs MsgSubmissionTags) Nothing
<*> areq textField (bfs MsgSubmissionUrl) defaultUrl <*> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) (Just "master") <*> areq textField (bfs MsgSubmissionBranch) (Just "master")

View File

@ -11,6 +11,8 @@ import qualified Data.ByteString.Lazy as L
import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage) import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage)
import Handler.Shared
getYourAccountR :: Handler Html getYourAccountR :: Handler Html
getYourAccountR = do getYourAccountR = do
userId <- requireAuthId userId <- requireAuthId
@ -51,9 +53,6 @@ checkPassword (Just passwd) = isPasswordAcceptable passwd
autocompleteOff name tooltip = setts { fsAttrs = (fsAttrs setts) ++ [("autocomplete", "nope")]} autocompleteOff name tooltip = setts { fsAttrs = (fsAttrs setts) ++ [("autocomplete", "nope")]}
where setts = (bfs name) { fsTooltip = Just $ SomeMessage tooltip } 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 :: 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 $ (,,,,,) yourAccountForm maybeName maybeLocalId maybeSshPubKey anonimised = renderBootstrap3 BootstrapBasicForm $ (,,,,,)
<$> aopt textField (fieldWithTooltip MsgAccountName MsgAccountNameTooltip) (Just maybeName) <$> aopt textField (fieldWithTooltip MsgAccountName MsgAccountNameTooltip) (Just maybeName)

View File

@ -136,6 +136,7 @@ library
, nonce , nonce
, esqueleto , esqueleto
, extra , extra
, attoparsec
executable gonito executable gonito
if flag(library-only) if flag(library-only)

View File

@ -47,3 +47,4 @@ AchievementPoints: points
WantToBeAnonimised: I want to stay anonymous for other user of Gonito.net WantToBeAnonimised: I want to stay anonymous for other user of Gonito.net
YourScore: your score YourScore: your score
PasswordForNewAccount: enter a password for your new account 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