Spago publish verifies that the publish location matches one of the current repo's remotes (#1259)

Author: fsoikin

CHANGELOG.md

@@ -17,6 +17,7 @@ Other improvements:
 - Added support for `--package-set` options for `spago upgrade`.
 - `spago repl` now writes a `.purs-repl` file, unless already there, containing `import Prelude`.
 - Added typo suggestions upon failing to find a package by name.
+- `spago publish` now checks that the publish location matches one of the remotes in the current Git repository.
 
 ## [0.21.0] - 2023-05-04
 

src/Spago/Command/Publish.purs

@@ -38,6 +38,7 @@ import Spago.Command.Fetch as Fetch
 import Spago.Config (Package(..), Workspace, WorkspacePackage)
 import Spago.Config as Config
 import Spago.Db (Db)
+import Spago.FS as FS
 import Spago.Git (Git)
 import Spago.Git as Git
 import Spago.Json as Json
@@ -190,6 +191,12 @@ publish _args = do
           , "submit a transfer operation."
           ]
 
+        unlessM (locationIsInGitRemotes location) $ addError $ toDoc
+          [ "The location specified in the manifest file"
+          , "(" <> Json.stringifyJson Location.codec location <> ")"
+          , " is not one of the remotes in the git repository."
+          ]
+
         -- Check that all the dependencies come from the registry
         let
           { fail, success: _ } =
@@ -251,9 +258,9 @@ publish _args = do
 
           -- These are "soft" git tag checks. We notify the user of errors
           -- they need to fix. But these commands must not have the user
-          -- 1) create/push a git tag that is known to be unpublishable, 
+          -- 1) create/push a git tag that is known to be unpublishable,
           --    thereby forcing them to create another git tag later with the fix.
-          -- 2) input any login credentials as there are other errors to fix 
+          -- 2) input any login credentials as there are other errors to fix
           --    before doing that.
           -- The "hard" git tag checks will occur only if these succeed.
           Git.getStatus Nothing >>= case _ of
@@ -353,7 +360,7 @@ publish _args = do
             }
         )
 
-      -- As above: there's a pending failure exit and its' easier to just abort here
+      -- As above: there's a pending failure exit and it's easier to just abort here
       when (not builtAgain) $
         Effect.liftEffect Process.exit
 
@@ -452,5 +459,19 @@ waitForJobFinish jobId = go Nothing
           true -> logSuccess $ "Registry finished processing the package. Your package was published successfully!"
           false -> die $ "Registry finished processing the package, but it failed. Please fix it and try again."
 
+locationIsInGitRemotes :: ∀ a. Location -> Spago (PublishEnv a) Boolean
+locationIsInGitRemotes location = do
+  isGitRepo <- FS.exists ".git"
+  if not isGitRepo then
+    pure false
+  else
+    Git.getRemotes Nothing >>= case _ of
+      Left err ->
+        die $ toDoc err
+      Right remotes ->
+        pure $ remotes # Array.any \r -> case location of
+          Location.Git { url } -> r.url == url
+          Location.GitHub { owner, repo } -> r.owner == owner && r.repo == repo
+
 baseApi :: String
 baseApi = "https://registry.purescript.org"

src/Spago/Git.purs

@@ -4,10 +4,12 @@ module Spago.Git
   , fetchRepo
   , getGit
   , getRef
-  , listTags
+  , getRemotes
   , getStatus
-  , pushTag
   , isIgnored
+  , listTags
+  , parseRemote
+  , pushTag
   , tagCheckedOut
   ) where
 
@@ -16,11 +18,15 @@ import Spago.Prelude
 import Control.Monad.Except (ExceptT(..))
 import Control.Monad.Except as Except
 import Data.Array as Array
+import Data.Array.NonEmpty as NEA
+import Data.Maybe (fromJust)
 import Data.String (Pattern(..))
 import Data.String as String
+import Data.String.Regex as Regex
 import Node.ChildProcess.Types (Exit(..))
 import Node.Path as Path
 import Node.Process as Process
+import Partial.Unsafe (unsafePartial)
 import Registry.Version as Version
 import Spago.Cmd as Cmd
 import Spago.FS as FS
@@ -29,6 +35,8 @@ type Git = { cmd :: String, version :: String }
 
 type GitEnv a = { git :: Git, logOptions :: LogOptions, offline :: OnlineStatus | a }
 
+type Remote = { name :: String, url :: String, owner :: String, repo :: String }
+
 runGit_ :: forall a. Array String -> Maybe FilePath -> ExceptT String (Spago (GitEnv a)) Unit
 runGit_ args cwd = void $ runGit args cwd
 
@@ -112,6 +120,22 @@ getRef cwd = do
       ]
     Right r -> pure $ Right r.stdout
 
+getRemotes :: forall a. Maybe FilePath -> Spago (GitEnv a) (Either Docc (Array Remote))
+getRemotes = \cwd -> do
+  let opts = Cmd.defaultExecOptions { pipeStdout = false, pipeStderr = false, cwd = cwd }
+  { git } <- ask
+  Cmd.exec git.cmd [ "remote", "--verbose" ] opts <#> case _ of
+    Left r -> Left $ toDoc
+      [ "Could not run `git remote --verbose` to verify correct repository path. Error:"
+      , r.stderr
+      ]
+    Right { stdout: "" } ->
+      pure []
+    Right r ->
+      r.stdout # String.split (Pattern "\n") # Array.mapMaybe parseRemote # case _ of
+        [] -> Left $ toDoc "Could not parse any remotes from the output of `git remote --verbose`."
+        remotes -> Right $ Array.nub remotes
+
 tagCheckedOut :: forall a. Maybe FilePath -> Spago (GitEnv a) (Either Docc String)
 tagCheckedOut cwd = do
   let opts = Cmd.defaultExecOptions { pipeStdout = false, pipeStderr = false, cwd = cwd }
@@ -177,3 +201,16 @@ getGit = do
     Left r -> do
       logDebug $ Cmd.printExecResult r
       die [ "Failed to find git. Have you installed it, and is it in your PATH?" ]
+
+parseRemote :: String -> Maybe Remote
+parseRemote = \line ->
+  case String.split (Pattern "\t") line of
+    [ name, secondPart ]
+      | [ url, _ ] <- String.split (Pattern " ") secondPart
+      , Just [ _, _, Just owner, Just repo ] <- NEA.toArray <$> Regex.match gitUrlRegex url ->
+          Just { name, url, owner, repo }
+    _ ->
+      Nothing
+  where
+  gitUrlRegex = unsafePartial $ fromJust $ hush $
+    Regex.regex "^(.+@.+:|https?:\\/\\/.+\\/)(.*)\\/(.+)\\.git$" mempty

test-fixtures/publish-invalid-location.txt

@@ -0,0 +1,18 @@
+Reading Spago workspace configuration...
+
+✅ Selecting package to build: aaa
+
+Downloading dependencies...
+Building...
+           Src   Lib   All
+Warnings     0     0     0
+Errors       0     0     0
+
+✅ Build succeeded.
+
+Your package "aaa" is not ready for publishing yet, encountered 1 error:
+
+
+❌ The location specified in the manifest file
+({"githubOwner":"purescript","githubRepo":"aaa"})
+ is not one of the remotes in the git repository.

test/Spago/Errors.purs

@@ -4,12 +4,10 @@ import Test.Prelude
 
 import Data.Array as Array
 import Data.Foldable (traverse_)
-import Data.String (joinWith)
 import Data.String as String
 import Spago.FS as FS
 import Test.Spec (Spec)
 import Test.Spec as Spec
-import Test.Spec.Assertions.String (shouldContain)
 
 spec :: Spec Unit
 spec = Spec.around withTempDir do

test/Spago/Publish.purs

@@ -41,6 +41,15 @@ spec = Spec.around withTempDir do
         Just Platform.Win32 -> fixture "publish-main-win.txt"
         _ -> fixture "publish-main.txt"
 
+    Spec.it "fails if the publish repo location is not among git remotes" \{ spago, fixture } -> do
+      FS.copyFile { src: fixture "spago-publish.yaml", dst: "spago.yaml" }
+      FS.mkdirp "src"
+      FS.copyFile { src: fixture "publish.purs", dst: "src/Main.purs" }
+      spago [ "build" ] >>= shouldBeSuccess
+      doTheGitThing
+      git [ "remote", "set-url", "origin", "[email protected]:purescript/bbb.git" ] >>= shouldBeSuccess
+      spago [ "publish", "--offline" ] >>= shouldBeFailureErr (fixture "publish-invalid-location.txt")
+
     Spec.it "can get a package ready to publish" \{ spago, fixture } -> do
       FS.copyFile { src: fixture "spago-publish.yaml", dst: "spago.yaml" }
       FS.mkdirp "src"
@@ -61,7 +70,8 @@ doTheGitThing = do
   git [ "add", "." ] >>= shouldBeSuccess
   git [ "commit", "-m", "first" ] >>= shouldBeSuccess
   git [ "tag", "v0.0.1" ] >>= shouldBeSuccess
-  where
-  git :: Array String -> Aff (Either ExecResult ExecResult)
-  git args = Cmd.exec "git" args
-    $ Cmd.defaultExecOptions { pipeStdout = false, pipeStderr = false, pipeStdin = StdinNewPipe }
+  git [ "remote", "add", "origin", "[email protected]:purescript/aaa.git" ] >>= shouldBeSuccess
+
+git :: Array String -> Aff (Either ExecResult ExecResult)
+git args = Cmd.exec "git" args
+  $ Cmd.defaultExecOptions { pipeStdout = false, pipeStderr = false, pipeStdin = StdinNewPipe }

test/Spago/Unit.purs

@@ -4,6 +4,7 @@ import Prelude
 
 import Test.Spago.Unit.CheckInjectivity as CheckInjectivity
 import Test.Spago.Unit.FindFlags as FindFlags
+import Test.Spago.Unit.Git as Git
 import Test.Spago.Unit.Printer as Printer
 import Test.Spec (Spec)
 import Test.Spec as Spec
@@ -13,3 +14,4 @@ spec = Spec.describe "unit" do
   FindFlags.spec
   CheckInjectivity.spec
   Printer.spec
+  Git.spec

test/Spago/Unit/Git.purs

@@ -0,0 +1,28 @@
+module Test.Spago.Unit.Git where
+
+import Prelude
+
+import Spago.Git (parseRemote)
+import Test.Prelude (Maybe(..), shouldEqual)
+import Test.Spec (Spec)
+import Test.Spec as Spec
+
+spec :: Spec Unit
+spec = do
+  Spec.describe "Git" do
+    Spec.describe "parseRemote" do
+
+      Spec.it "parses a remote with a git protocol" do
+        parseRemote "origin\t[email protected]:foo/bar.git (fetch)"
+          `shouldEqual` Just { name: "origin", url: "[email protected]:foo/bar.git", owner: "foo", repo: "bar" }
+
+      Spec.it "parses a remote with an https protocol" do
+        parseRemote "origin\thttps://github.com/foo/bar.git (push)"
+          `shouldEqual` Just { name: "origin", url: "https://github.com/foo/bar.git", owner: "foo", repo: "bar" }
+
+      Spec.it "rejects malformed remotes" do
+        parseRemote "origin\t[email protected]:foo/bar.git" `shouldEqual` Nothing
+        parseRemote "origin\t[email protected]:foo/bar (push)" `shouldEqual` Nothing
+        parseRemote "origin [email protected]:foo/bar.git (fetch)" `shouldEqual` Nothing
+        parseRemote "origin\t[email protected]:foo.git (push)" `shouldEqual` Nothing
+        parseRemote "origin\thttps://foo.com/bar.git (push)" `shouldEqual` Nothing