Clone Git monorepos with several dependencies only once (purescript#1275

)

CHANGELOG.md

@@ -23,6 +23,8 @@ Other improvements:
   overwrite the file if the marker isn't present, assuming that the file was
   manually created or edited, not generated by Spago itself.
 - migrated tests to the `spec-node` runner.
+- when multiple dependencies share a monorepo, that repo is cloned only once and
+  cached locally.
 - `spago publish` now allows to publish a package with some test (but only
   test!) dependencies not present in the registry.
 

core/src/Log.purs

@@ -19,6 +19,8 @@ module Spago.Log
   , module DodoExport
   , output
   , prepareToDie
+  , rightOrDie
+  , rightOrDie_
   , rightOrDieWith
   , rightOrDieWith'
   , toDoc
@@ -180,14 +182,20 @@ justOrDieWith' value msg = case value of
   Nothing ->
     die' msg
 
-rightOrDieWith :: forall a b m err x. MonadEffect m => MonadAsk (LogEnv b) m => Loggable a => Either err x -> (err -> a) -> m x
+rightOrDie :: ∀ b m err x. MonadEffect m => MonadAsk (LogEnv b) m => Loggable err => Either err x -> m x
+rightOrDie value = rightOrDieWith value identity
+
+rightOrDie_ :: ∀ b m err x. MonadEffect m => MonadAsk (LogEnv b) m => Loggable err => Either err x -> m Unit
+rightOrDie_ = void <<< rightOrDie
+
+rightOrDieWith :: ∀ a b m err x. MonadEffect m => MonadAsk (LogEnv b) m => Loggable a => Either err x -> (err -> a) -> m x
 rightOrDieWith value toMsg = case value of
   Right a ->
     pure a
   Left err ->
     die $ toMsg err
 
-rightOrDieWith' :: forall a b m err x. MonadEffect m => MonadAsk (LogEnv b) m => Loggable a => Either err x -> (err -> Array a) -> m x
+rightOrDieWith' :: ∀ a b m err x. MonadEffect m => MonadAsk (LogEnv b) m => Loggable a => Either err x -> (err -> Array a) -> m x
 rightOrDieWith' value toMsg = case value of
   Right a ->
     pure a

core/src/Prelude.purs

@@ -48,7 +48,7 @@ import Partial.Unsafe (unsafeCrashWith)
 import Registry.ManifestIndex (ManifestIndex) as Extra
 import Registry.Types (PackageName, Version, Range, Location, License, Manifest(..), Metadata(..), Sha256) as Extra
 import Spago.Json (printJson, parseJson) as Extra
-import Spago.Log (logDebug, logError, logInfo, Docc, logSuccess, logWarn, die, die', justOrDieWith, justOrDieWith', rightOrDieWith, rightOrDieWith', toDoc, indent, indent2, output, LogEnv, LogOptions, OutputFormat(..)) as Extra
+import Spago.Log (logDebug, logError, logInfo, Docc, logSuccess, logWarn, die, die', justOrDieWith, justOrDieWith', rightOrDie, rightOrDie_, rightOrDieWith, rightOrDieWith', toDoc, indent, indent2, output, LogEnv, LogOptions, OutputFormat(..)) as Extra
 import Spago.Yaml (YamlDoc, printYaml, parseYaml) as Extra
 
 newtype Spago env a = Spago (ReaderT env Extra.Aff a)

src/Spago/Command/Fetch.purs

@@ -429,29 +429,49 @@ toAllDependencies =
 
 getGitPackageInLocalCache :: forall a. PackageName -> GitPackage -> Spago (Git.GitEnv a) Unit
 getGitPackageInLocalCache name package = do
+  ensureRepoCloned
+  ensureRefPresent
+
   let localPackageLocation = Config.getPackageLocation name (GitPackage package)
-  tempDir <- mkTemp' (Just $ printJson Config.gitPackageCodec package)
-  logDebug $ "Cloning repo in " <> tempDir
-  Git.fetchRepo package tempDir >>= case _ of
-    Left err -> die err
-    Right _ -> do
-      logDebug $ "Repo cloned. Moving to " <> localPackageLocation
-      FS.mkdirp $ Path.concat [ Paths.localCachePackagesPath, PackageName.print name ]
-      FS.moveSync { src: tempDir, dst: localPackageLocation }
-
-      -- Note: the package might have been cloned with a tag, but we stick the commit hash in the lockfiles
-      -- so we need to make a copy to a location that has the commit hash too.
-      -- So we run getRef here and then do a copy if the ref is different than the original one
-      -- (since it might be a commit to start with)
-      logDebug $ "Checking if we need to copy the package to a commit hash location..."
-      Git.getRef (Just localPackageLocation) >>= case _ of
-        Left err -> die err
-        Right ref -> do
-          when (ref /= package.ref) do
-            let commitHashLocation = Config.getPackageLocation name (GitPackage $ package { ref = ref })
-            logDebug $ "Copying the repo also to " <> commitHashLocation
-            FS.mkdirp $ Path.concat [ Paths.localCachePackagesPath, PackageName.print name ]
-            FS.copyTree { src: localPackageLocation, dst: commitHashLocation }
+  logDebug $ "Copying repo to " <> localPackageLocation
+  FS.mkdirp $ Path.concat [ Paths.localCachePackagesPath, PackageName.print name ]
+  FS.copyTree { src: repoCacheLocation, dst: localPackageLocation }
+  logDebug $ "Checking out ref '" <> package.ref <> "'"
+  Git.checkout { repo: localPackageLocation, ref: package.ref } >>= rightOrDie_
+
+  -- Note: the package might have been cloned with a tag, but we stick the commit hash in the lockfiles
+  -- so we need to make a copy to a location that has the commit hash too.
+  -- So we run getRef here and then do a copy if the ref is different than the original one
+  -- (since it might be a commit to start with)
+  logDebug $ "Checking if we need to copy the package to a commit hash location..."
+  commitHash <- Git.getRef (Just localPackageLocation) >>= rightOrDie
+  when (commitHash /= package.ref) do
+    let commitHashLocation = Config.getPackageLocation name (GitPackage $ package { ref = commitHash })
+    logDebug $ "Copying the repo also to " <> commitHashLocation
+    FS.copyTree { src: localPackageLocation, dst: commitHashLocation }
+  where
+  repoCacheLocation = Path.concat [ Paths.localCacheGitPath, Config.fileSystemCharEscape package.git ]
+
+  ensureRepoCloned = unlessM (FS.exists repoCacheLocation) do
+    tempDir <- mkTemp' (Just $ printJson Config.gitPackageCodec package)
+    logDebug $ "Cloning repo in " <> tempDir
+    Git.fetchRepo package tempDir >>= rightOrDie_
+
+    logDebug $ "Repo cloned. Moving to " <> repoCacheLocation
+    FS.mkdirp $ Path.concat [ Paths.localCachePackagesPath, PackageName.print name ]
+    FS.moveSync { src: tempDir, dst: repoCacheLocation }
+
+  ensureRefPresent = do
+    logDebug $ "Verifying ref " <> package.ref
+    { offline } <- ask
+    Git.getRefType { repo: repoCacheLocation, ref: package.ref } >>= case _, offline of
+      Right _, _ ->
+        pure unit
+      Left _, Offline ->
+        die $ "Repo " <> package.git <> " does not have ref " <> package.ref <> " in local cache. Cannot pull from origin in offline mode."
+      Left _, Online -> do
+        logDebug $ "Ref " <> package.ref <> " is not present, trying to pull from origin"
+        Git.fetch { repo: repoCacheLocation, remote: "origin" } >>= rightOrDie_
 
 getPackageDependencies :: forall a. PackageName -> Package -> Spago (FetchEnv a) (Maybe (ByEnv (Map PackageName Range)))
 getPackageDependencies packageName package = case package of

src/Spago/Git.purs

@@ -6,6 +6,9 @@ module Spago.Git
   , getRef
   , getRemotes
   , getStatus
+  , checkout
+  , fetch
+  , getRefType
   , isIgnored
   , listTags
   , parseRemote
@@ -48,7 +51,7 @@ runGit args cwd = ExceptT do
     Right r -> Right r.stdout
     Left r -> Left r.stderr
 
-fetchRepo :: forall a b. { git :: String, ref :: String | a } -> FilePath -> Spago (GitEnv b) (Either (Array String) Unit)
+fetchRepo :: ∀ a b. { git :: String, ref :: String | a } -> FilePath -> Spago (GitEnv b) (Either (Array String) Unit)
 fetchRepo { git, ref } path = do
   repoExists <- FS.exists path
   { offline } <- ask
@@ -91,6 +94,18 @@ fetchRepo { git, ref } path = do
           logDebug $ "Successfully fetched the repo '" <> git <> "' at ref '" <> ref <> "'"
           pure $ Right unit
 
+checkout :: ∀ a. { repo :: String, ref :: String } -> Spago (GitEnv a) (Either String Unit)
+checkout { repo, ref } = Except.runExceptT $ void $ runGit [ "checkout", ref ] (Just repo)
+
+fetch :: ∀ a. { repo :: String, remote :: String } -> Spago (GitEnv a) (Either String Unit)
+fetch { repo, remote } = do
+  remoteUrl <- runGit [ "remote", "get-url", remote ] (Just repo) # Except.runExceptT >>= rightOrDie
+  logInfo $ "Fetching from " <> remoteUrl
+  Except.runExceptT $ runGit_ [ "fetch", remote, "--tags" ] (Just repo)
+
+getRefType :: ∀ a. { repo :: String, ref :: String } -> Spago (GitEnv a) (Either String String)
+getRefType { repo, ref } = Except.runExceptT $ runGit [ "cat-file", "-t", ref ] (Just repo)
+
 listTags :: forall a. Maybe FilePath -> Spago (GitEnv a) (Either Docc (Array String))
 listTags cwd = do
   let opts = Cmd.defaultExecOptions { pipeStdout = false, pipeStderr = false, cwd = cwd }

src/Spago/Paths.purs

@@ -32,12 +32,18 @@ localCachePath = toLocalCachePath cwd
 localCachePackagesPath :: FilePath
 localCachePackagesPath = toLocalCachePackagesPath cwd
 
+localCacheGitPath :: FilePath
+localCacheGitPath = toLocalCacheGitPath cwd
+
 toLocalCachePath :: FilePath -> FilePath
 toLocalCachePath rootDir = Path.concat [ rootDir, ".spago" ]
 
 toLocalCachePackagesPath :: FilePath -> FilePath
 toLocalCachePackagesPath rootDir = Path.concat [ toLocalCachePath rootDir, "p" ]
 
+toLocalCacheGitPath :: FilePath -> FilePath
+toLocalCacheGitPath rootDir = Path.concat [ toLocalCachePath rootDir, "g" ]
+
 registryPath ∷ FilePath
 registryPath = Path.concat [ globalCachePath, "registry" ]
 

src/Spago/Prelude.purs

@@ -159,7 +159,7 @@ mkTemp' maybeSuffix = liftAff do
     sha <- Sha256.hashString $ show now <> fromMaybe "" maybeSuffix
     shaToHex sha
   -- Return the dir, but don't make it - that's the responsibility of the client
-  let tempDirPath = Path.concat [ Paths.paths.temp, random ]
+  let tempDirPath = Path.concat [ Paths.paths.temp, String.drop 50 random ]
   pure tempDirPath
 
 mkTemp :: forall m. MonadAff m => m FilePath

test-fixtures/circular-dependencies.txt

@@ -2,7 +2,6 @@ Reading Spago workspace configuration...
 
 ✓ Selecting package to build: bbb
 
-Cloning https://github.com/purescript/spago.git
 Cloning https://github.com/purescript/spago.git
 
 ✘ The following packages have circular dependencies:

test-fixtures/monorepo/1208-no-double-cloning/expected-stderr/four-deps.txt

@@ -0,0 +1,7 @@
+Reading Spago workspace configuration...
+
+✓ Selecting package to build: consumer
+
+Downloading dependencies...
+No lockfile found, generating it...
+Lockfile written to spago.lock. Please commit this file.

test-fixtures/monorepo/1208-no-double-cloning/expected-stderr/three-deps-offline.txt

@@ -0,0 +1,6 @@
+Reading Spago workspace configuration...
+
+✓ Selecting package to build: consumer
+
+
+✘ Repo <library-repo-path> does not have ref v3 in local cache. Cannot pull from origin in offline mode.

test-fixtures/monorepo/1208-no-double-cloning/expected-stderr/three-deps.txt

@@ -0,0 +1,8 @@
+Reading Spago workspace configuration...
+
+✓ Selecting package to build: consumer
+
+Fetching from <library-repo-path>
+Downloading dependencies...
+No lockfile found, generating it...
+Lockfile written to spago.lock. Please commit this file.

test-fixtures/monorepo/1208-no-double-cloning/expected-stderr/two-deps.txt

@@ -0,0 +1,8 @@
+Reading Spago workspace configuration...
+
+✓ Selecting package to build: consumer
+
+Cloning <library-repo-path>
+Downloading dependencies...
+No lockfile found, generating it...
+Lockfile written to spago.lock. Please commit this file.

test-fixtures/monorepo/1208-no-double-cloning/library/lib1/spago.yaml

@@ -0,0 +1,4 @@
+package:
+  name: lib1
+  dependencies:
+    - prelude

test-fixtures/monorepo/1208-no-double-cloning/library/lib2/spago.yaml

@@ -0,0 +1,5 @@
+package:
+  name: lib2
+  dependencies:
+    - lib1
+    - prelude

test-fixtures/monorepo/1208-no-double-cloning/library/lib3/spago.yaml

@@ -0,0 +1,6 @@
+package:
+  name: lib3
+  dependencies:
+    - lib1
+    - lib2
+    - prelude

test-fixtures/monorepo/1208-no-double-cloning/library/lib4/spago.yaml

@@ -0,0 +1,5 @@
+package:
+  name: lib4
+  dependencies:
+    - lib1
+    - prelude

test-fixtures/monorepo/1208-no-double-cloning/library/spago.yaml

@@ -0,0 +1,3 @@
+workspace:
+  packageSet:
+    registry: 56.4.0

test-fixtures/monorepo/1208-no-double-cloning/spago-four-deps.yaml

@@ -0,0 +1,27 @@
+package:
+  name: consumer
+  dependencies:
+    - lib1
+    - lib2
+    - lib3
+    - lib4
+workspace:
+  packageSet:
+    registry: 56.4.0
+  extraPackages:
+    lib1:
+      git: <library-repo-path>
+      subdir: lib1
+      ref: v1
+    lib2:
+      git: <library-repo-path>
+      subdir: lib2
+      ref: v2
+    lib3:
+      git: <library-repo-path>
+      subdir: lib3
+      ref: v3
+    lib4:
+      git: <library-repo-path>
+      subdir: lib4
+      ref: v4

test-fixtures/monorepo/1208-no-double-cloning/spago-three-deps.yaml

@@ -0,0 +1,22 @@
+package:
+  name: consumer
+  dependencies:
+    - lib1
+    - lib2
+    - lib3
+workspace:
+  packageSet:
+    registry: 56.4.0
+  extraPackages:
+    lib1:
+      git: <library-repo-path>
+      subdir: lib1
+      ref: v1
+    lib2:
+      git: <library-repo-path>
+      subdir: lib2
+      ref: v2
+    lib3:
+      git: <library-repo-path>
+      subdir: lib3
+      ref: v3

test-fixtures/monorepo/1208-no-double-cloning/spago-two-deps.yaml

@@ -0,0 +1,17 @@
+package:
+  name: consumer
+  dependencies:
+    - lib1
+    - lib2
+workspace:
+  packageSet:
+    registry: 56.4.0
+  extraPackages:
+    lib1:
+      git: <library-repo-path>
+      subdir: lib1
+      ref: v1
+    lib2:
+      git: <library-repo-path>
+      subdir: lib2
+      ref: v2

test/Prelude.purs

@@ -17,6 +17,7 @@ import Node.Path (dirname)
 import Node.Path as Path
 import Node.Platform as Platform
 import Node.Process as Process
+import Record (merge)
 import Registry.PackageName as PackageName
 import Registry.Version as Version
 import Spago.Cmd (ExecResult, StdinConfig(..))
@@ -175,19 +176,30 @@ checkOutputs
      }
   -> Either ExecResult ExecResult
   -> Aff Unit
-checkOutputs checkers execResult = do
+checkOutputs args = checkOutputs' $ args `merge` { sanitize: String.trim }
+
+checkOutputs'
+  :: { stdoutFile :: Maybe FilePath
+     , stderrFile :: Maybe FilePath
+     , result :: (Either ExecResult ExecResult) -> Boolean
+     , sanitize :: String -> String
+     }
+  -> Either ExecResult ExecResult
+  -> Aff Unit
+checkOutputs' checkers execResult = do
   let
     checkOrOverwrite = case _ of
       Nothing -> mempty
-      Just fixtureFileExpected -> \actual -> do
+      Just fixtureFileExpected -> \actual' -> do
+        let actual = checkers.sanitize actual'
         overwriteSpecFile <- liftEffect $ map isJust $ Process.lookupEnv "SPAGO_TEST_ACCEPT"
         if overwriteSpecFile then do
           Console.log $ "Overwriting fixture at path: " <> fixtureFileExpected
           let parentDir = dirname fixtureFileExpected
           unlessM (FS.exists parentDir) $ FS.mkdirp parentDir
           FS.writeTextFile fixtureFileExpected (actual <> "\n")
         else do
-          expected <- String.trim <$> FS.readTextFile fixtureFileExpected
+          expected <- checkers.sanitize <$> FS.readTextFile fixtureFileExpected
           actual `shouldEqualStr` expected
   check
     { stdout: checkOrOverwrite checkers.stdoutFile