diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 87b3a7f..7d41dfe 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -84,7 +84,7 @@ cloneRepo url branch chan = do Just _ -> do err chan "Repo already there" return Nothing - Nothing -> cloneRepo' url branch chan + Nothing -> cloneRepo' url branch url branch chan updateRepo :: Key Repo -> Channel -> Handler Bool updateRepo repoId chan = do @@ -113,20 +113,15 @@ getHeadCommit repoDir chan = do err chan "cannot determine HEAD commit" return Nothing -cloneRepo' :: Text -> Text -> Channel -> Handler (Maybe (Key Repo)) -cloneRepo' url branch chan = do +cloneRepo' :: Text -> Text -> Text -> Text -> Channel -> Handler (Maybe (Key Repo)) +cloneRepo' url branch referenceUrl referenceBranch chan = do msg chan $ concat ["Preparing to clone repo ", url] if checkRepoUrl url then do msg chan "Cloning..." r <- randomInt let tmpRepoDir = arena ("t" ++ show r) - (exitCode, _) <- runProgram Nothing gitPath ["clone", - "--progress", - "--branch", - T.unpack branch, - T.unpack url, - tmpRepoDir] chan + exitCode <- rawClone tmpRepoDir url branch referenceUrl referenceBranch chan case exitCode of ExitSuccess -> do 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] 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 repoId = arena ("r" ++ repoIdAsString) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 334c161..556b611 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -25,6 +25,8 @@ import qualified Data.Map as Map import PersistSHA1 +import Options.Applicative + getShowChallengeR :: Text -> Handler Html getShowChallengeR name = do (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)] Nothing -> do msg chan $ "Start evaluation..." - result <- liftIO $ runGEvalGetOptions ["--expected-directory", (getRepoDir $ challengePrivateRepo challenge), - "--out-directory", repoDir] - case result of - Left parseResult -> do + resultOrException <- liftIO $ rawEval challenge repoDir + case resultOrException of + Right (Left parseResult) -> do 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) ] time <- liftIO getCurrentTime runDB $ insert $ Evaluation { @@ -147,9 +148,15 @@ checkOrInsertEvaluation repoDir chan out = do evaluationErrorMessage=Nothing, evaluationStamp=time } msg chan "Evaluation done" - Right (_, Nothing) -> do + Right (Right (_, Nothing)) -> do 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 challengeId url branch chan = do @@ -169,8 +176,11 @@ getSubmissionRepo challengeId url branch chan = do return Nothing else 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 challengeId repoId chan = do diff --git a/gonito.cabal b/gonito.cabal index 1a261ce..7e26918 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -113,6 +113,7 @@ library , filepath , yesod-table , regex-tdfa + , optparse-applicative executable gonito if flag(library-only) diff --git a/stack.yaml b/stack.yaml index 7a7344c..44d1937 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,5 +5,5 @@ flags: packages: - '.' - '../geval' -extra-deps: [markdown-0.1.13.2,geval-0.1.0.0] -resolver: lts-3.11 +extra-deps: [markdown-0.1.13.2,geval-0.2.0.0] +resolver: lts-3.13