From dce08f5ce6beccd2726ab6c209973fcd590a004c Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 5 Sep 2020 14:22:12 +0200 Subject: [PATCH] Repository is cloned if not found on a local disk --- Handler/CreateChallenge.hs | 12 +++++----- Handler/Evaluate.hs | 4 ++-- Handler/MakePublic.hs | 2 +- Handler/Shared.hs | 47 ++++++++++++++++++++++++++++++++++---- Handler/ShowChallenge.hs | 2 +- 5 files changed, 53 insertions(+), 14 deletions(-) diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index b2001ae..e1f57e0 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -105,7 +105,7 @@ doCreateChallenge creationData chan = do case maybePublicRepoId of Just publicRepoId -> do publicRepo <- runDB $ get404 publicRepoId - publicRepoDir <- getRepoDir publicRepoId + publicRepoDir <- getRepoDirOrClone publicRepoId chan maybePrivateRepoId <- cloneRepo (RepoCloningSpec { cloningSpecRepo = RepoSpec { repoSpecUrl = privateUrl, @@ -226,7 +226,7 @@ doChallengeUpdate challengeId challengeData chan = do when isValidated $ do privateRepo <- runDB $ get404 $ privateRepoId - repoDir <- getRepoDir privateRepoId + repoDir <- getRepoDirOrClone privateRepoId chan (Just versionDescription) <- liftIO $ getLastCommitMessage repoDir theNow <- liftIO getCurrentTime let commit = (repoCurrentCommit privateRepo) @@ -286,7 +286,7 @@ defaultInitialDescription = "initial version" extractChallengeMetadata :: Key Repo -> Channel -> Handler (Text, Text, Maybe ByteString) extractChallengeMetadata publicRepoId chan = do - publicRepoDir <- getRepoDir publicRepoId + publicRepoDir <- getRepoDirOrClone publicRepoId chan let readmeFilePath = publicRepoDir readmeFile doesReadmeExist <- liftIO $ doesFileExist readmeFilePath (title, description) <- if doesReadmeExist @@ -349,7 +349,7 @@ updateTests :: (Key Challenge) -> Channel -> Handler () updateTests challengeId chan = do challenge <- runDB $ get404 challengeId let repoId = challengePrivateRepo challenge - repoDir <- getRepoDir repoId + repoDir <- getRepoDirOrClone repoId chan repo <- runDB $ get404 repoId let commit = repoCurrentCommit repo testDirs <- liftIO $ findTestDirs repoDir @@ -372,7 +372,7 @@ checkTestDir chan challengeId challenge commit testDir = do then do msg chan $ concat ["Test dir ", (T.pack testDir), " found."] checksum <- liftIO $ gatherSHA1 testDir - challengeRepoDir <- getRepoDir $ challengePrivateRepo challenge + challengeRepoDir <- getRepoDirOrClone (challengePrivateRepo challenge) chan optionsParsingResult <- liftIO $ getOptions [ "--expected-directory", challengeRepoDir, "--test-name", takeFileName testDir] @@ -461,7 +461,7 @@ validateChallenge False _ chan = do validateChallenge True repoId chan = do msg chan "Validating the challenge..." - repoDir <- getRepoDir repoId + repoDir <- getRepoDirOrClone repoId chan optionsParsingResult <- liftIO $ getOptions [ "--expected-directory", repoDir] diff --git a/Handler/Evaluate.hs b/Handler/Evaluate.hs index 3082faa..66395ce 100644 --- a/Handler/Evaluate.hs +++ b/Handler/Evaluate.hs @@ -116,7 +116,7 @@ getOuts chan submissionId generalParams = do submission <- runDB $ get404 submissionId let challengeId = submissionChallenge submission let version = submissionVersion submission - repoDir <- getRepoDir $ submissionRepo submission + repoDir <- getRepoDirOrClone (submissionRepo submission) chan activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True, TestCommit ==. submissionVersion submission] [] @@ -218,7 +218,7 @@ checkOrInsertEvaluation repoDir chan version out = do msg chan $ concat ["Already evaluated with score ", (fromMaybe "???" $ formatNonScientifically <$> evaluationScore evaluation)] Nothing -> do msg chan $ "Start evaluation..." - challengeDir <- getRepoDir $ challengePrivateRepo challenge + challengeDir <- getRepoDirOrClone (challengePrivateRepo challenge) chan variant <- runDB $ get404 $ outVariant out resultOrException <- liftIO $ rawEval challengeDir (testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv") case resultOrException of diff --git a/Handler/MakePublic.hs b/Handler/MakePublic.hs index 4c83ed9..efcc8cc 100644 --- a/Handler/MakePublic.hs +++ b/Handler/MakePublic.hs @@ -28,7 +28,7 @@ doMakePublic userId submissionId chan = do challenge <- runDB $ get404 $ submissionChallenge submission repo <- runDB $ get404 $ challengePublicRepo challenge let submissionRepoId = submissionRepo submission - submissionRepoDir <- getRepoDir submissionRepoId + submissionRepoDir <- getRepoDirOrClone submissionRepoId chan app <- getYesod let scheme = appRepoScheme $ appSettings app diff --git a/Handler/Shared.hs b/Handler/Shared.hs index a2c484f..86e275d 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -24,7 +24,7 @@ import qualified Data.List as DL import System.Random -import System.Directory (doesFileExist, renameDirectory) +import System.Directory (doesFileExist, renameDirectory, doesDirectoryExist) import PersistSHA1 @@ -145,7 +145,7 @@ cloneRepo repoCloningSpec chan = do updateRepo :: Key Repo -> Channel -> Handler Bool updateRepo repoId chan = do repo <- runDB $ get404 repoId - repoDir <- getRepoDir repoId + repoDir <- getRepoDirOrClone repoId chan let branch = repoBranch repo exitCode <- runWithChannel chan $ do runProg (Just repoDir) gitPath ["fetch", @@ -172,7 +172,7 @@ updateRepo repoId chan = do getSubmissionRepoDir :: SubmissionId -> Channel -> Handler (Maybe FilePath) getSubmissionRepoDir submissionId chan = do submission <- runDB $ get404 submissionId - repoDir <- getRepoDir $ submissionRepo submission + repoDir <- getRepoDirOrClone (submissionRepo submission) chan let sha1Code = submissionCommit submission -- this is not right... it should be fixed in the future -- 1. All kinds of mayhem may ensue in case of concurrency @@ -230,7 +230,7 @@ getPossiblyExistingRepo checkRepo userId challengeId repoSpec chan = do challenge <- runDB $ get404 challengeId let repoId = challengePublicRepo challenge repo <- runDB $ get404 repoId - repoDir <- getRepoDir repoId + repoDir <- getRepoDirOrClone repoId chan let repoCloningSpec = RepoCloningSpec { cloningSpecRepo = repoSpec, cloningSpecReferenceRepo = RepoSpec { @@ -330,6 +330,45 @@ getStuffUsingGitAnnex tmpRepoDir (Just gitAnnexRemote) = do runGitAnnex :: FilePath -> [String] -> Runner () runGitAnnex tmpRepoDir args = runProg (Just tmpRepoDir) gitPath ("annex":args) +-- Gets a directory for an already cloned repo (e.g. arena/r1234). If, +-- for some reason, the directory does not exist (e.g. the database +-- was recovered on a new computer), it will re-clone the repository. +getRepoDirOrClone :: RepoId -> Channel -> Handler FilePath +getRepoDirOrClone repoId chan = do + repoDir <- getRepoDir repoId + repoDirExists <- liftIO $ doesDirectoryExist repoDir + if repoDirExists + then + return () + else + do + repo <- runDB $ get404 repoId + let repoSpec = RepoSpec { + repoSpecUrl = repoUrl repo, + repoSpecBranch = repoBranch repo, + repoSpecGitAnnexRemote = repoGitAnnexRemote repo } + let repoCloningSpec = RepoCloningSpec { + cloningSpecRepo = repoSpec, + cloningSpecReferenceRepo = repoSpec } + (exitCode, tmpRepoDir) <- cloneRepoToTempDir repoCloningSpec chan + case exitCode of + ExitSuccess -> do + let commitHash = fromSHA1ToText $ repoCurrentCommit repo + (exitCode', _) <- runProgram (Just tmpRepoDir) gitPath ["reset", + "--hard", + T.unpack commitHash] chan + case exitCode' of + ExitSuccess -> do + liftIO $ renameDirectory tmpRepoDir repoDir + return () + ExitFailure _ -> do + err chan $ "cannot reset to commit" ++ commitHash + return () + ExitFailure _ -> do + err chan "git failed" + return () + return repoDir + getRepoDir :: Key Repo -> Handler FilePath getRepoDir repoId = do arenaDir <- arena diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index aa20749..c9502bd 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -424,7 +424,7 @@ doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do repo <- runDB $ get404 repoId - repoDir <- getRepoDir repoId + repoDir <- getRepoDirOrClone repoId chan gonitoMetadata <- liftIO $ extractMetadataFromRepoDir repoDir (ExtractionOptions {