filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

fix updating repos, evaluation non-default test sets

Browse Source
This commit is contained in:
Filip Gralinski 2015-11-11 10:24:03 +01:00
parent 17d32aa8e7
commit bd8fc83c05
3 changed files with 25 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Handler/CreateChallenge.hs
View File

@ -43,10 +43,11 @@ postCreateChallengeR = do
doCreateChallenge :: Text -> Text -> Text -> Text -> Text -> Channel -> Handler () doCreateChallenge :: Text -> Text -> Text -> Text -> Text -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do doCreateChallenge name publicUrl publicBranch privateUrl privateBranch chan = do
maybePublicRepoId <- cloneRepo publicUrl publicBranch chan maybePublicRepoId <- cloneRepo publicUrl publicBranch publicUrl publicBranch chan
case maybePublicRepoId of case maybePublicRepoId of
Just publicRepoId -> do Just publicRepoId -> do
maybePrivateRepoId <- cloneRepo privateUrl privateBranch chan publicRepo <- runDB $ get404 publicRepoId
maybePrivateRepoId <- cloneRepo privateUrl privateBranch (T.pack $ getRepoDir publicRepoId) (repoBranch publicRepo) chan
case maybePrivateRepoId of case maybePrivateRepoId of
Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan
Nothing -> return () Nothing -> return ()

33
Handler/Shared.hs
View File

@ -65,40 +65,41 @@ err = msg
raw :: Channel -> Text -> Handler () raw :: Channel -> Text -> Handler ()
raw = msg raw = msg
doRepoCloning :: Text -> Text -> Channel -> Handler ()
doRepoCloning url branch chan = do
msg chan "Did something"
_ <- cloneRepo url branch chan
return ()
validGitProtocols :: [String] validGitProtocols :: [String]
validGitProtocols = ["git", "http", "https", "ssh"] validGitProtocols = ["git", "http", "https", "ssh"]
validGitProtocolsAsText :: Text validGitProtocolsAsText :: Text
validGitProtocolsAsText = T.pack $ intercalate ", " $ map (++"://") validGitProtocols validGitProtocolsAsText = T.pack $ intercalate ", " $ map (++"://") validGitProtocols
cloneRepo :: Text -> Text -> Channel -> Handler (Maybe (Key Repo)) cloneRepo :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
cloneRepo url branch chan = do cloneRepo url branch referenceUrl referenceBranch chan = do
maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch maybeRepo <- runDB $ getBy $ UniqueUrlBranch url branch
case maybeRepo of case maybeRepo of
Just _ -> do Just _ -> do
err chan "Repo already there" err chan "Repo already there"
return Nothing return Nothing
Nothing -> cloneRepo' url branch url branch chan Nothing -> cloneRepo' url branch referenceUrl referenceBranch chan
updateRepo :: Key Repo -> Channel -> Handler Bool updateRepo :: Key Repo -> Channel -> Handler Bool
updateRepo repoId chan = do updateRepo repoId chan = do
repo <- runDB $ get404 repoId repo <- runDB $ get404 repoId
let repoDir = getRepoDir repoId let repoDir = getRepoDir repoId
(exitCode, _) <- runProgram (Just repoDir) gitPath ["pull", "--progress"] chan (exitCode, _) <- runProgram (Just repoDir) gitPath ["fetch", "--progress"] chan
case exitCode of case exitCode of
ExitSuccess -> do ExitSuccess -> do
maybeHeadCommit <- getHeadCommit repoDir chan (exitCode, _) <- runProgram (Just repoDir) gitPath ["reset",
case maybeHeadCommit of "--hard",
Just headCommit -> do "FETCH_HEAD"] chan
runDB $ update repoId [RepoCurrentCommit =. headCommit] case exitCode of
return True ExitSuccess -> do
Nothing -> return False maybeHeadCommit <- getHeadCommit repoDir chan
case maybeHeadCommit of
Just headCommit -> do
runDB $ update repoId [RepoCurrentCommit =. headCommit]
return True
Nothing -> return False
_ -> return False
_ -> return False
getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1) getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1)
getHeadCommit repoDir chan = do getHeadCommit repoDir chan = do

9
Handler/ShowChallenge.hs
View File

@ -134,7 +134,7 @@ checkOrInsertEvaluation repoDir chan out = do
msg chan $ concat ["Already evaluated with score ", (T.pack $ fromMaybe "???" $ show <$> evaluationScore evaluation)] msg chan $ concat ["Already evaluated with score ", (T.pack $ fromMaybe "???" $ show <$> evaluationScore evaluation)]
Nothing -> do Nothing -> do
msg chan $ "Start evaluation..." msg chan $ "Start evaluation..."
resultOrException <- liftIO $ rawEval challenge repoDir resultOrException <- liftIO $ rawEval challenge repoDir (testName test)
case resultOrException of case resultOrException of
Right (Left parseResult) -> do Right (Left parseResult) -> do
err chan "Cannot parse options, check the challenge repo" err chan "Cannot parse options, check the challenge repo"
@ -153,10 +153,11 @@ checkOrInsertEvaluation repoDir chan out = do
Left exception -> do Left exception -> do
err chan $ "Evaluation failed: " ++ (T.pack $ show exception) err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
rawEval :: Challenge -> FilePath -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue))) rawEval :: Challenge -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue)))
rawEval challenge repoDir = try (runGEvalGetOptions [ rawEval challenge repoDir name = try (runGEvalGetOptions [
"--expected-directory", (getRepoDir $ challengePrivateRepo challenge), "--expected-directory", (getRepoDir $ challengePrivateRepo challenge),
"--out-directory", repoDir]) "--out-directory", repoDir,
"--test-name", (T.unpack name)])
getSubmissionRepo :: Key Challenge -> Text -> Text -> Channel -> Handler (Maybe (Key Repo)) getSubmissionRepo :: Key Challenge -> Text -> Text -> Channel -> Handler (Maybe (Key Repo))
getSubmissionRepo challengeId url branch chan = do getSubmissionRepo challengeId url branch chan = do