faster cloning

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)

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

gonito.cabal

@@ -113,6 +113,7 @@ library
                  , filepath
                  , yesod-table
                  , regex-tdfa
+                 , optparse-applicative
 
 executable         gonito
     if flag(library-only)

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