Handle tags and description from gonito.yaml

.gitmodules

@@ -0,0 +1,8 @@
+[submodule "test/fake-git-repos/simple"]
+	path = test/fake-git-repos/simple
+	url = git://gonito.net/gonito-fake-repo-for-tests
+	branch = simple
+[submodule "test/fake-git-repos/with-gonito-yaml"]
+	path = test/fake-git-repos/with-gonito-yaml
+	url = git://gonito.net/gonito-fake-repo-for-tests
+	branch = with-gonito-yaml

Gonito/ExtractMetadata.hs

@@ -0,0 +1,173 @@
+module Gonito.ExtractMetadata (
+  extractMetadataFromRepoDir,
+  GonitoMetadata(..),
+  ExtractionOptions(..),
+  parseCommitMessage,
+  getLastCommitMessage,
+  parseTags)
+   where
+
+import Import
+
+import Data.Attoparsec.Text
+import Data.Text
+
+import Data.Aeson
+import qualified Data.Yaml as Y
+
+import System.Exit
+import System.Process
+
+import qualified Data.Set as S
+import qualified Data.HashMap.Strict as H
+
+import Handler.Shared (gitPath)
+
+data ExtractionOptions = ExtractionOptions {
+  extractionOptionsDescription :: Maybe Text,
+  extractionOptionsTags :: Maybe Text,
+  extractionOptionsGeneralParams :: Maybe Text,
+  extractionOptionsParamFiles :: Maybe Text,
+  extractionOptionsMLRunPath :: Maybe FilePath
+  }
+
+instance FromJSON ExtractionOptions where
+    parseJSON = withObject "ExtractionOptions" $ \v -> ExtractionOptions
+        <$> v .:? "description"
+        <*> v .:? "tags"
+        <*> v .:? "params"
+        <*> v .:? "param-files"
+        <*> v .:? "mlrun-path"
+
+instance Default ExtractionOptions where
+  def = ExtractionOptions {
+    extractionOptionsDescription = Nothing,
+    extractionOptionsTags = Nothing,
+    extractionOptionsGeneralParams = Nothing,
+    extractionOptionsParamFiles = Nothing,
+    extractionOptionsMLRunPath = Nothing
+    }
+
+data GonitoMetadata = GonitoMetadata {
+  gonitoMetadataDescription :: Text,
+  gonitoMetadataTags :: S.Set Text,
+  gonitoMetadataGeneralParams :: H.HashMap Text Text
+  }
+  deriving (Eq, Show)
+
+gonitoYamlFile :: FilePath
+gonitoYamlFile = "gonito.yaml"
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe (Left _) = Nothing
+eitherToMaybe (Right v) = Just v
+
+combineExtractionOptions :: Maybe ExtractionOptions -> ExtractionOptions -> ExtractionOptions
+combineExtractionOptions Nothing options = options
+combineExtractionOptions (Just otherOptions) options = ExtractionOptions {
+  extractionOptionsDescription = combineWithT extractionOptionsDescription,
+  extractionOptionsTags = combineWithT extractionOptionsTags,
+  extractionOptionsGeneralParams = combineWithT extractionOptionsGeneralParams,
+  extractionOptionsParamFiles = combineWithT extractionOptionsParamFiles,
+  extractionOptionsMLRunPath = combineWithF extractionOptionsMLRunPath }
+  where combineWithT fun = case fun options of
+                            Nothing -> fun otherOptions
+                            Just v -> Just v
+        combineWithF fun = case fun options of
+                            Nothing -> fun otherOptions
+                            Just v -> Just v
+
+extractMetadataFromRepoDir :: FilePath -> ExtractionOptions -> IO GonitoMetadata
+extractMetadataFromRepoDir repoDir formExtractionOptions = do
+  commitMessage <- getLastCommitMessage repoDir
+  let (mCommitDescription, mCommitTags) = parseCommitMessage commitMessage
+
+  mGonitoYamlOptions <- eitherToMaybe <$> Y.decodeFileEither (repoDir </> gonitoYamlFile)
+
+  let extractionOptions = combineExtractionOptions mGonitoYamlOptions formExtractionOptions
+
+  let description = case extractionOptionsDescription extractionOptions of
+                      Just d -> d
+                      Nothing -> case mCommitDescription of
+                        Just d -> d
+                        Nothing -> "???"
+
+  let commitTagsParsed = parseTags mCommitTags
+  let formTagsParsed = parseTags $ extractionOptionsTags extractionOptions
+  let tagsParsed = union commitTagsParsed formTagsParsed
+
+  pure $ GonitoMetadata {
+    gonitoMetadataDescription = description,
+    gonitoMetadataTags = tagsParsed,
+    gonitoMetadataGeneralParams = H.empty
+  }
+
+getLastCommitMessage :: FilePath -> IO (Maybe Text)
+getLastCommitMessage repoDir = do
+  (exitCode, out) <- runProgram repoDir gitPath ["log", "-1", "--pretty=%B"]
+  return $ case exitCode of
+             ExitSuccess -> Just out
+             ExitFailure _ -> Nothing
+
+runProgram :: FilePath -> FilePath -> [String] -> IO (ExitCode, Text)
+runProgram dir prog args = do
+  (_, o, _, p) <- runInteractiveProcess prog args (Just dir) Nothing
+  hSetBuffering o NoBuffering
+  out <- hGetContents o
+  exitCode <- Import.length out `seq` waitForProcess p
+  return (exitCode, decodeUtf8 out)
+
+parseTags :: Maybe Text -> S.Set Text
+parseTags (Just tags) = S.fromList $ Import.map Data.Text.strip $ Data.Text.split (== ',') tags
+parseTags Nothing = S.empty
+
+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
+
+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 :: Data.Attoparsec.Text.Parser ()
+emptyLine = do
+  many space *> endOfLine

Handler/Achievements.hs

@@ -15,6 +15,9 @@ import Data.Time.LocalTime
 
 import Data.Text
 
+import qualified Data.Set as S
+import Gonito.ExtractMetadata (parseTags)
+
 import qualified Yesod.Table as Table
 
 getGonitoInClassR :: Handler Html
@@ -38,7 +41,7 @@ postAchievementsR = do
       FormSuccess (name, description, points, deadlineDay, deadlineTime, maxSubmitters, mTags, challengeId, courseId) -> do
                             achievementId <- runDB $ insert $ Achievement name challengeId points description (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) maxSubmitters courseId
 
-                            tids <- runDB $ tagsAsTextToTagIds mTags
+                            tids <- runDB $ tagsAsTextToTagIds (parseTags mTags)
 
                             _ <- mapM (\tid -> runDB $ insert $ AchievementTag achievementId tid) tids
 
@@ -83,11 +86,14 @@ achievementsTable canEdit = mempty
   ++ Table.string "max submitters" (formatMaxSubmitters . achievementInfoMaxWinners)
   ++ workingOnCell
 
+achievementNameEntry :: Bool -> Table.Table App AchievementInfo
 achievementNameEntry True = Table.linked "achievement" (achievementInfoName) (EditAchievementR . achievementInfoId)
 achievementNameEntry False = Table.text "achievement" achievementInfoName
 
+workingOnCell :: Table.Table App AchievementInfo
 workingOnCell = Table.widget "who's working on it?" workingOnWidget
 
+workingOnWidget :: AchievementInfo -> WidgetFor App ()
 workingOnWidget ainfo = [whamlet|
 #{srs}
 
@@ -180,6 +186,7 @@ determineWhetherCanGiveUpWorkingOn (Just (Entity userId _)) peopleWorkingOn =
 checkLimit _ Nothing = True
 checkLimit peopleWorkingOn (Just m) = (Import.length peopleWorkingOn) < m
 
+formatSubmitters :: [Entity User] -> Text
 formatSubmitters userEnts = Data.Text.intercalate ", " $ Import.map (formatSubmitter . entityVal) userEnts
 
 formatMaxSubmitters :: Maybe Int -> String
@@ -198,6 +205,7 @@ achievementForm mAchievement mTags = renderBootstrap3 BootstrapBasicForm $ (,,,,
     <*> challengesSelectFieldList (achievementChallenge <$> mAchievement)
     <*> coursesSelectFieldList (achievementCourse <$> mAchievement)
 
+tagsToText :: [Entity Tag] -> Maybe Text
 tagsToText [] = Nothing
 tagsToText tags = Just $ Data.Text.intercalate ", " $ Import.map (tagName . entityVal) tags
 
@@ -246,7 +254,7 @@ postEditAchievementR achievementId = do
                                 AchievementCourse =. courseId]
 
           deleteWhere [AchievementTagAchievement ==. achievementId]
-          tids <- tagsAsTextToTagIds mTags
+          tids <- tagsAsTextToTagIds (parseTags mTags)
           mapM (\tid -> insert $ AchievementTag achievementId tid) tids
 
         setMessage $ toHtml ("OK! Achievement modified" :: Text)

Handler/EditSubmission.hs

@@ -10,6 +10,8 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
 import Handler.TagUtils
 import Handler.MakePublic
 
+import Gonito.ExtractMetadata (parseTags)
+
 import Data.Text as T
 
 postAddVariantParamR :: SubmissionId -> VariantId -> Handler Html
@@ -58,7 +60,7 @@ postEditSubmissionG submissionId mVariantId = do
       sts <- selectList [SubmissionTagSubmission ==. submissionId] []
       let currentTagIds = Import.map (submissionTagTag . entityVal) sts
 
-      addTags submissionId tags currentTagIds
+      addTags submissionId (parseTags tags) currentTagIds
 
       return ()
     else

Handler/Shared.hs

@@ -173,13 +173,6 @@ 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' :: UserId -> RepoCloningSpec -> Channel -> Handler (Maybe (Key Repo))
 cloneRepo' userId repoCloningSpec chan = do
       let url = repoSpecUrl $ cloningSpecRepo repoCloningSpec

Handler/ShowChallenge.hs

@@ -20,6 +20,8 @@ import Handler.Tables
 import Handler.TagUtils
 import Handler.MakePublic
 
+import Gonito.ExtractMetadata (ExtractionOptions(..), extractMetadataFromRepoDir, GonitoMetadata(..))
+
 import qualified Text.Read as TR
 
 import GEval.Core
@@ -34,8 +36,6 @@ import System.IO (readFile)
 
 import System.FilePath (takeFileName, dropExtensions)
 
-import Data.Attoparsec.Text
-
 import Data.Text (pack, unpack)
 
 import Data.Conduit.SmartSource
@@ -238,15 +238,26 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
       repo <- runDB $ get404 repoId
 
       repoDir <- getRepoDir repoId
-      commitMessage <- getLastCommitMessage repoDir chan
-      let (mCommitDescription, mCommitTags) = parseCommitMessage commitMessage
 
-      submissionId <- getSubmission userId repoId (repoCurrentCommit repo) challengeId (fromMaybe (fromMaybe "???" mCommitDescription) mDescription) chan
+      gonitoMetadata <- liftIO
+                       $ extractMetadataFromRepoDir repoDir (ExtractionOptions {
+                                                                extractionOptionsDescription = mDescription,
+                                                                extractionOptionsTags = mTags,
+                                                                extractionOptionsGeneralParams = Nothing,
+                                                                extractionOptionsParamFiles = Nothing,
+                                                                extractionOptionsMLRunPath = Nothing })
+
+      submissionId <- getSubmission userId
+                                   repoId
+                                   (repoCurrentCommit repo)
+                                   challengeId
+                                   (gonitoMetadataDescription gonitoMetadata)
+                                   chan
       _ <- getOuts chan submissionId
 
       currentTagIds <- runDB $ selectList [SubmissionTagSubmission ==. submissionId] []
 
-      runDB $ addTags submissionId (if isNothing mTags then mCommitTags else mTags) (
+      runDB $ addTags submissionId (gonitoMetadataTags gonitoMetadata)  (
         map (submissionTagTag . entityVal) currentTagIds)
       msg chan "SUBMISSION CREATED"
 
@@ -278,60 +289,6 @@ getSubmission userId repoId commit challengeId description chan = do
         submissionIsPublic=False,
         submissionIsHidden=Just 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 :: Data.Attoparsec.Text.Parser a -> Data.Attoparsec.Text.Parser [a]
-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 :: Data.Attoparsec.Text.Parser ()
-emptyLine = do
-  many space *> endOfLine
-
 getOuts :: Channel -> Key Submission -> Handler ([Out])
 getOuts chan submissionId = do
   submission <- runDB $ get404 submissionId

Handler/TagUtils.hs

@@ -3,8 +3,11 @@ module Handler.TagUtils where
 import Import
 import Yesod.Form.Bootstrap3 (bfs)
 
-import Data.Text as T
+import qualified Data.Set as S
 
+import Gonito.ExtractMetadata (parseTags)
+
+getAvailableTagsAsJSON :: (BaseBackend backend ~ SqlBackend, MonadIO m, PersistQueryRead backend) => ReaderT backend m Value
 getAvailableTagsAsJSON = do
   tagsAvailable <- selectList [] [Asc TagName]
   return $ toJSON $ Import.map (tagName . entityVal) tagsAvailable
@@ -13,18 +16,18 @@ tagsfs :: RenderMessage site msg => msg -> FieldSettings site
 tagsfs msg = attrs { fsAttrs = ("data-role"::Text,"tagsinput"::Text):(fsAttrs attrs)}
    where attrs = bfs msg
 
-addTags submissionId tagsAsText existingOnes = do
-  tids <- tagsAsTextToTagIds tagsAsText
+addTags :: (BaseBackend backend ~ SqlBackend, Element mono ~ Key Tag, Eq (Element mono), MonoFoldable mono, PersistQueryWrite backend, MonadIO m, PersistUniqueRead backend) => Key Submission -> S.Set Text -> mono -> ReaderT backend m ()
+addTags submissionId tags existingOnes = do
+  tids <- tagsAsTextToTagIds tags
 
   deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids]
 
   _ <- mapM (\tid -> insert $ SubmissionTag submissionId tid Nothing) (Import.filter (not . (`elem` existingOnes)) tids)
   return ()
 
-tagsAsTextToTagIds mTagsAsText = do
-  let newTags = case mTagsAsText of
-                       Just tags' -> Import.map T.strip $ T.split (== ',') tags'
-                       Nothing -> []
+tagsAsTextToTagIds :: (BaseBackend backend ~ SqlBackend, PersistUniqueRead backend, MonadIO m) => S.Set Text -> ReaderT backend m [Key Tag]
+tagsAsTextToTagIds tags = do
+  let newTags = S.toList $ tags
   mTs <- mapM (\t -> getBy $ UniqueTagName t) newTags
   return $ Import.map entityKey $ Import.catMaybes mTs
 

gonito.cabal

@@ -54,6 +54,7 @@ library
                      Handler.Runner
                      Handler.Dashboard
                      Data.SubmissionConditions
+                     Gonito.ExtractMetadata
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -206,3 +207,5 @@ test-suite test
                  , classy-prelude-yesod
                  , wai-handler-fastcgi
                  , wai
+                 , containers
+                 , unordered-containers

templates/challenge-how-to.hamlet

@@ -121,3 +121,14 @@ $maybe token <- mToken
 <h3>Manual submission
 
 <p>In case other methods fail, you can submit your solution manually — go to the <a href="@{ChallengeSubmissionR $ challengeName challenge}">submit form</a>.
+
+<h2>Submission metadata
+
+<p>Gonito can take the description, tags and parameters of a submission from a number of sources (in order of precedence):
+
+<ol>
+  <li>submission form (when submitting manually),
+  <li>git commit message,
+  <li>names of output files (only for parameters)
+
+<p>It might seem a little bit complicated, but you could simply use the method which is the most convenient for you.

test/Gonito/ExtractMetadataSpec.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Gonito.ExtractMetadataSpec (spec) where
+
+import Import
+
+import qualified Data.Set as S
+import qualified Data.HashMap.Strict as H
+
+import Test.Hspec
+import Gonito.ExtractMetadata (extractMetadataFromRepoDir, GonitoMetadata(..), ExtractionOptions(..))
+
+spec :: Spec
+spec = do
+  describe "extract metadata from repos" $ do
+    it "simple" $ do
+      extractMetadataFromRepoDir "test/fake-git-repos/simple/" def `shouldReturn` GonitoMetadata {
+        gonitoMetadataDescription = "Simple solution",
+        gonitoMetadataTags = S.fromList ["foo", "simple-solution", "baz"],
+        gonitoMetadataGeneralParams = H.empty
+        }
+    it "simple with some fields from the form" $ do
+      extractMetadataFromRepoDir "test/fake-git-repos/simple/" def {
+        extractionOptionsDescription = Just "Other solution",
+        extractionOptionsTags = Just "other-tag,baz"
+        } `shouldReturn` GonitoMetadata {
+        gonitoMetadataDescription = "Other solution",
+        gonitoMetadataTags = S.fromList ["foo", "simple-solution", "baz", "other-tag"],
+        gonitoMetadataGeneralParams = H.empty
+        }
+    it "with gonito.yaml" $ do
+      extractMetadataFromRepoDir "test/fake-git-repos/with-gonito-yaml/" def `shouldReturn` GonitoMetadata {
+        gonitoMetadataDescription = "Test solution",
+        gonitoMetadataTags = S.fromList ["zzz", "baz", "simple", "machine-learning"],
+        gonitoMetadataGeneralParams = H.empty
+        }

test/fake-git-repos/simple

@@ -0,0 +1 @@
+Subproject commit 061e9d9153fed7e6776af470506b15d611f65cea

test/fake-git-repos/with-gonito-yaml

@@ -0,0 +1 @@
+Subproject commit 2e6ba6c762135075094b119a461f7d6e4f476a44