faster cloning
This commit is contained in:
parent
8c7e9f4a13
commit
17d32aa8e7
@ -84,7 +84,7 @@ cloneRepo url branch chan = do
|
|||||||
Just _ -> do
|
Just _ -> do
|
||||||
err chan "Repo already there"
|
err chan "Repo already there"
|
||||||
return Nothing
|
return Nothing
|
||||||
Nothing -> cloneRepo' url branch chan
|
Nothing -> cloneRepo' url branch url branch chan
|
||||||
|
|
||||||
updateRepo :: Key Repo -> Channel -> Handler Bool
|
updateRepo :: Key Repo -> Channel -> Handler Bool
|
||||||
updateRepo repoId chan = do
|
updateRepo repoId chan = do
|
||||||
@ -113,20 +113,15 @@ getHeadCommit repoDir chan = do
|
|||||||
err chan "cannot determine HEAD commit"
|
err chan "cannot determine HEAD commit"
|
||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
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
|
||||||
msg chan $ concat ["Preparing to clone repo ", url]
|
msg chan $ concat ["Preparing to clone repo ", url]
|
||||||
if checkRepoUrl url
|
if checkRepoUrl url
|
||||||
then do
|
then do
|
||||||
msg chan "Cloning..."
|
msg chan "Cloning..."
|
||||||
r <- randomInt
|
r <- randomInt
|
||||||
let tmpRepoDir = arena </> ("t" ++ show r)
|
let tmpRepoDir = arena </> ("t" ++ show r)
|
||||||
(exitCode, _) <- runProgram Nothing gitPath ["clone",
|
exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan
|
||||||
"--progress",
|
|
||||||
"--branch",
|
|
||||||
T.unpack branch,
|
|
||||||
T.unpack url,
|
|
||||||
tmpRepoDir] chan
|
|
||||||
case exitCode of
|
case exitCode of
|
||||||
ExitSuccess -> do
|
ExitSuccess -> do
|
||||||
maybeHeadCommit <- getHeadCommit tmpRepoDir chan
|
maybeHeadCommit <- getHeadCommit tmpRepoDir chan
|
||||||
@ -154,6 +149,37 @@ cloneRepo' url branch chan = do
|
|||||||
err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
|
err chan $ concat ["Wrong URL to a Git repo (note that one of the following protocols must be specified: ", validGitProtocolsAsText]
|
||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
|
rawClone :: FilePath -> Text -> Text -> Text -> Text -> Channel -> Handler (ExitCode)
|
||||||
|
rawClone tmpRepoDir url branch referenceUrl referenceBranch chan = do
|
||||||
|
(exitCode, _) <- runProgram Nothing gitPath ["clone",
|
||||||
|
"--progress",
|
||||||
|
"--branch",
|
||||||
|
T.unpack referenceBranch,
|
||||||
|
T.unpack referenceUrl,
|
||||||
|
tmpRepoDir] chan
|
||||||
|
if url /= referenceUrl || branch /= referenceBranch
|
||||||
|
then
|
||||||
|
do
|
||||||
|
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["remote",
|
||||||
|
"set-url",
|
||||||
|
"origin",
|
||||||
|
T.unpack url] chan
|
||||||
|
case exitCode of
|
||||||
|
ExitSuccess -> do
|
||||||
|
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["fetch",
|
||||||
|
"origin",
|
||||||
|
T.unpack branch] chan
|
||||||
|
case exitCode of
|
||||||
|
ExitSuccess -> do
|
||||||
|
(exitCode, _) <- runProgram (Just tmpRepoDir) gitPath ["reset",
|
||||||
|
"--hard",
|
||||||
|
"FETCH_HEAD"] chan
|
||||||
|
return exitCode
|
||||||
|
_ -> return exitCode
|
||||||
|
_ -> return exitCode
|
||||||
|
|
||||||
|
else
|
||||||
|
return exitCode
|
||||||
|
|
||||||
getRepoDir :: Key Repo -> FilePath
|
getRepoDir :: Key Repo -> FilePath
|
||||||
getRepoDir repoId = arena </> ("r" ++ repoIdAsString)
|
getRepoDir repoId = arena </> ("r" ++ repoIdAsString)
|
||||||
|
@ -25,6 +25,8 @@ import qualified Data.Map as Map
|
|||||||
|
|
||||||
import PersistSHA1
|
import PersistSHA1
|
||||||
|
|
||||||
|
import Options.Applicative
|
||||||
|
|
||||||
getShowChallengeR :: Text -> Handler Html
|
getShowChallengeR :: Text -> Handler Html
|
||||||
getShowChallengeR name = do
|
getShowChallengeR name = do
|
||||||
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
(Entity _ challenge) <- runDB $ getBy404 $ UniqueName name
|
||||||
@ -132,12 +134,11 @@ 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..."
|
||||||
result <- liftIO $ runGEvalGetOptions ["--expected-directory", (getRepoDir $ challengePrivateRepo challenge),
|
resultOrException <- liftIO $ rawEval challenge repoDir
|
||||||
"--out-directory", repoDir]
|
case resultOrException of
|
||||||
case result of
|
Right (Left parseResult) -> do
|
||||||
Left parseResult -> do
|
|
||||||
err chan "Cannot parse options, check the challenge repo"
|
err chan "Cannot parse options, check the challenge repo"
|
||||||
Right (opts, Just result) -> do
|
Right (Right (opts, Just result)) -> do
|
||||||
msg chan $ concat [ "Evaluated! Score ", (T.pack $ show result) ]
|
msg chan $ concat [ "Evaluated! Score ", (T.pack $ show result) ]
|
||||||
time <- liftIO getCurrentTime
|
time <- liftIO getCurrentTime
|
||||||
runDB $ insert $ Evaluation {
|
runDB $ insert $ Evaluation {
|
||||||
@ -147,9 +148,15 @@ checkOrInsertEvaluation repoDir chan out = do
|
|||||||
evaluationErrorMessage=Nothing,
|
evaluationErrorMessage=Nothing,
|
||||||
evaluationStamp=time }
|
evaluationStamp=time }
|
||||||
msg chan "Evaluation done"
|
msg chan "Evaluation done"
|
||||||
Right (_, Nothing) -> do
|
Right (Right (_, Nothing)) -> do
|
||||||
err chan "Error during the evaluation"
|
err chan "Error during the evaluation"
|
||||||
|
Left exception -> do
|
||||||
|
err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
|
||||||
|
|
||||||
|
rawEval :: Challenge -> FilePath -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe MetricValue)))
|
||||||
|
rawEval challenge repoDir = try (runGEvalGetOptions [
|
||||||
|
"--expected-directory", (getRepoDir $ challengePrivateRepo challenge),
|
||||||
|
"--out-directory", repoDir])
|
||||||
|
|
||||||
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
|
||||||
@ -169,8 +176,11 @@ getSubmissionRepo challengeId url branch chan = do
|
|||||||
return Nothing
|
return Nothing
|
||||||
else
|
else
|
||||||
return Nothing
|
return Nothing
|
||||||
Nothing -> cloneRepo' url branch chan
|
Nothing -> do
|
||||||
|
challenge <- runDB $ get404 challengeId
|
||||||
|
let repoId = challengePublicRepo challenge
|
||||||
|
repo <- runDB $ get404 repoId
|
||||||
|
cloneRepo' url branch (T.pack $ getRepoDir repoId) (repoBranch repo) chan
|
||||||
|
|
||||||
checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
|
checkRepoAvailibility :: Key Challenge -> Key Repo -> Channel -> Handler Bool
|
||||||
checkRepoAvailibility challengeId repoId chan = do
|
checkRepoAvailibility challengeId repoId chan = do
|
||||||
|
@ -113,6 +113,7 @@ library
|
|||||||
, filepath
|
, filepath
|
||||||
, yesod-table
|
, yesod-table
|
||||||
, regex-tdfa
|
, regex-tdfa
|
||||||
|
, optparse-applicative
|
||||||
|
|
||||||
executable gonito
|
executable gonito
|
||||||
if flag(library-only)
|
if flag(library-only)
|
||||||
|
@ -5,5 +5,5 @@ flags:
|
|||||||
packages:
|
packages:
|
||||||
- '.'
|
- '.'
|
||||||
- '../geval'
|
- '../geval'
|
||||||
extra-deps: [markdown-0.1.13.2,geval-0.1.0.0]
|
extra-deps: [markdown-0.1.13.2,geval-0.2.0.0]
|
||||||
resolver: lts-3.11
|
resolver: lts-3.13
|
||||||
|
Loading…
Reference in New Issue
Block a user