diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..33ec757 --- /dev/null +++ b/.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 diff --git a/Gonito/ExtractMetadata.hs b/Gonito/ExtractMetadata.hs new file mode 100644 index 0000000..bda0806 --- /dev/null +++ b/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 diff --git a/Handler/Achievements.hs b/Handler/Achievements.hs index 82d5590..7e932a8 100644 --- a/Handler/Achievements.hs +++ b/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) diff --git a/Handler/EditSubmission.hs b/Handler/EditSubmission.hs index 8b91388..955726e 100644 --- a/Handler/EditSubmission.hs +++ b/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 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 9425027..d426cd0 100644 --- a/Handler/Shared.hs +++ b/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 diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index a4fd96c..061e044 100644 --- a/Handler/ShowChallenge.hs +++ b/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 diff --git a/Handler/TagUtils.hs b/Handler/TagUtils.hs index 92acc84..40a3bfa 100644 --- a/Handler/TagUtils.hs +++ b/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 diff --git a/gonito.cabal b/gonito.cabal index ef61d49..dc8a74c 100644 --- a/gonito.cabal +++ b/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 diff --git a/templates/challenge-how-to.hamlet b/templates/challenge-how-to.hamlet index 2fcdeef..7c4f927 100644 --- a/templates/challenge-how-to.hamlet +++ b/templates/challenge-how-to.hamlet @@ -121,3 +121,14 @@ $maybe token <- mToken

Manual submission

In case other methods fail, you can submit your solution manually — go to the submit form. + +

Submission metadata + +

Gonito can take the description, tags and parameters of a submission from a number of sources (in order of precedence): + +

    +
  1. submission form (when submitting manually), +
  2. git commit message, +
  3. names of output files (only for parameters) + +

    It might seem a little bit complicated, but you could simply use the method which is the most convenient for you. diff --git a/test/Gonito/ExtractMetadataSpec.hs b/test/Gonito/ExtractMetadataSpec.hs new file mode 100644 index 0000000..eab343f --- /dev/null +++ b/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 + } diff --git a/test/fake-git-repos/simple b/test/fake-git-repos/simple new file mode 160000 index 0000000..061e9d9 --- /dev/null +++ b/test/fake-git-repos/simple @@ -0,0 +1 @@ +Subproject commit 061e9d9153fed7e6776af470506b15d611f65cea diff --git a/test/fake-git-repos/with-gonito-yaml b/test/fake-git-repos/with-gonito-yaml new file mode 160000 index 0000000..2e6ba6c --- /dev/null +++ b/test/fake-git-repos/with-gonito-yaml @@ -0,0 +1 @@ +Subproject commit 2e6ba6c762135075094b119a461f7d6e4f476a44