Improve sanitisation of paths and project names (#1374)

Author: f-f

src/Spago/Command/Init.purs

@@ -6,6 +6,7 @@ module Spago.Command.Init
   , InitOptions
   , defaultConfig
   , defaultConfig'
+  , folderToPackageName
   , pursReplFile
   , run
   , srcMainTemplate
@@ -14,8 +15,10 @@ module Spago.Command.Init
 
 import Spago.Prelude
 
+import Data.Array (mapMaybe)
 import Data.Map as Map
 import Data.String as String
+import Data.String.Utils as StringUtils
 import Registry.PackageName as PackageName
 import Registry.Version as Version
 import Spago.Config (Dependencies(..), SetAddress(..), Config)
@@ -106,19 +109,30 @@ run opts = do
   getPackageName :: Spago (InitEnv a) PackageName
   getPackageName = do
     { rootPath } <- ask
+    -- When the user explicitly provides a name, validate it directly and show the actual error.
+    -- When deriving from directory name, use folderToPackageName which sanitizes and gives a generic error.
     let
-      candidateName = case opts.mode of
-        InitWorkspace { packageName: Nothing } -> String.take 150 $ Path.basename rootPath
-        InitWorkspace { packageName: Just n } -> n
-        InitSubpackage { packageName: n } -> n
-    logDebug [ Path.quote rootPath, "\"" <> candidateName <> "\"" ]
-    pname <- case PackageName.parse (PackageName.stripPureScriptPrefix candidateName) of
-      Left err -> die
-        [ toDoc "Could not figure out a name for the new package. Error:"
-        , Log.break
-        , Log.indent2 $ toDoc err
-        ]
-      Right p -> pure p
+      explicitName = case opts.mode of
+        InitWorkspace { packageName: Just n } -> Just n
+        InitSubpackage { packageName: n } -> Just n
+        InitWorkspace { packageName: Nothing } -> Nothing
+    pname <- case explicitName of
+      Just n -> case PackageName.parse (PackageName.stripPureScriptPrefix n) of
+        Left err -> die
+          [ toDoc "Could not figure out a name for the new package. Error:"
+          , Log.break
+          , Log.indent2 $ toDoc err
+          ]
+        Right p -> pure p
+      Nothing -> do
+        let candidateName = String.take 150 $ Path.basename rootPath
+        case folderToPackageName candidateName of
+          Nothing -> die
+            [ "Could not derive a valid package name from directory " <> Path.quote rootPath <> "."
+            , "Please use --name to specify a package name."
+            ]
+          Just p -> pure p
+    logDebug [ Path.quote rootPath, PackageName.print pname ]
     logDebug [ "Got packageName and setVersion:", PackageName.print pname, unsafeStringify opts.setVersion ]
     pure pname
 
@@ -299,3 +313,59 @@ foundExistingDirectory dir = "Found existing directory " <> Path.quote dir <> ",
 
 foundExistingFile :: LocalPath -> String
 foundExistingFile file = "Found existing file " <> Path.quote file <> ", not overwriting it"
+
+-- SANITIZATION -----------------------------------------------------------------
+
+-- | Convert a folder name to a valid package name.
+-- | We try to convert as much Unicode as possible to ASCII (through NFD normalisation),
+-- | and otherwise strip out and/or replace non-alpanumeric chars with dashes.
+-- | After all this work that is still not enough to guarantee a successful PackageName
+-- | parse, so this is still a Maybe.
+folderToPackageName :: String -> Maybe PackageName
+folderToPackageName input =
+  input
+    # String.toLower
+    -- NFD normalization decomposes accented chars (é → e + combining accent)
+    -- so the base ASCII letter is preserved when we filter non-ASCII later
+    # StringUtils.normalize' StringUtils.NFD
+    # String.toCodePointArray
+    # mapMaybe sanitizeCodePoint
+    # String.fromCodePointArray
+    # collapseConsecutiveDashes
+    # stripLeadingTrailingDashes
+    # PackageName.stripPureScriptPrefix
+    # PackageName.parse
+    # hush
+  where
+  dash = String.codePointFromChar '-'
+
+  -- Transform each codepoint:
+  -- - ASCII lowercase (a-z) and digits (0-9): keep as-is
+  -- - Apostrophes and quotes: remove (shouldn't create word boundaries)
+  -- - Other ASCII: convert to dash (word boundaries)
+  -- - Non-ASCII (combining marks from NFD, etc.): remove
+  sanitizeCodePoint cp
+    | isAsciiLower cp || isAsciiDigit cp = Just cp
+    | isRemovable cp = Nothing
+    | isAscii cp = Just dash
+    | otherwise = Nothing
+
+  isAsciiLower cp = cp >= String.codePointFromChar 'a' && cp <= String.codePointFromChar 'z'
+  isAsciiDigit cp = cp >= String.codePointFromChar '0' && cp <= String.codePointFromChar '9'
+  isAscii cp = cp <= String.codePointFromChar '\x7F'
+  -- ASCII apostrophe and quote shouldn't create word boundaries (Tim's → tims, not tim-s)
+  isRemovable cp = cp == String.codePointFromChar '\'' || cp == String.codePointFromChar '"'
+
+  -- Collapse consecutive dashes into one
+  collapseConsecutiveDashes str =
+    case String.indexOf (String.Pattern "--") str of
+      Nothing -> str
+      Just _ -> collapseConsecutiveDashes $ String.replaceAll (String.Pattern "--") (String.Replacement "-") str
+
+  -- Remove all leading and trailing dashes
+  stripLeadingTrailingDashes str =
+    case String.stripPrefix (String.Pattern "-") str of
+      Just stripped -> stripLeadingTrailingDashes stripped
+      Nothing -> case String.stripSuffix (String.Pattern "-") str of
+        Just stripped -> stripLeadingTrailingDashes stripped
+        Nothing -> str

src/Spago/Command/Run.purs

@@ -1,6 +1,7 @@
 module Spago.Command.Run
   ( getNode
   , run
+  , encodeFileUrlPath
   , RunEnv
   , Node
   , RunOptions
@@ -12,6 +13,9 @@ import Codec.JSON.DecodeError as CJ.DecodeError
 import Data.Array as Array
 import Data.Array.NonEmpty as NEA
 import Data.Map as Map
+import Data.String as String
+import Data.String.CodeUnits as SCU
+import JSURI (encodeURIComponent)
 import Node.FS.Perms as Perms
 import Registry.Version as Version
 import Spago.Cmd as Cmd
@@ -46,6 +50,26 @@ type RunOptions =
 
 type Node = { cmd :: GlobalPath, version :: Version }
 
+-- | Encode a file path for use in a file:// URL.
+-- | Encodes special characters (spaces, apostrophes, etc.) but preserves
+-- | Windows drive letters (e.g., "C:") since encoding the colon breaks URLs.
+encodeFileUrlPath :: String -> String
+encodeFileUrlPath str =
+  String.split (String.Pattern "/") str
+    # map encodeSegment
+    # String.joinWith "/"
+  where
+  encodeSegment seg
+    | isWindowsDrive seg = seg
+    | otherwise = fromMaybe seg (encodeURIComponent seg)
+
+  -- Windows drive letter: single ASCII letter followed by colon (e.g., "C:", "D:")
+  isWindowsDrive seg = case SCU.toCharArray seg of
+    [ letter, ':' ] -> isAsciiLetter letter
+    _ -> false
+
+  isAsciiLetter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
+
 nodeVersion :: forall a. Spago (LogEnv a) Version
 nodeVersion =
   Cmd.exec (Path.global "node") [ "--version" ] Cmd.defaultExecOptions { pipeStdout = false, pipeStderr = false } >>= case _ of
@@ -86,7 +110,7 @@ run = do
         nodeContents =
           Array.fold
             [ "import { main } from 'file://"
-            , Path.toRaw (withForwardSlashes absOutput)
+            , encodeFileUrlPath $ Path.toRaw (withForwardSlashes absOutput)
             , "/"
             , opts.moduleName
             , "/"

test-fixtures/init-invalid-dirname.txt

@@ -0,0 +1,2 @@
+✘ Could not derive a valid package name from directory "...".
+Please use --name to specify a package name.

test/Spago/Publish.purs

@@ -85,6 +85,9 @@ spec = Spec.around withTempDir do
       spago [ "build" ] >>= shouldBeSuccess
       doTheGitThing
       spago [ "fetch" ] >>= shouldBeSuccess
+      -- Refresh the registry cache timestamp because Windows CI is slow enough
+      -- that it can go stale (>15min) between earlier tests and this one
+      spago [ "registry", "package-sets" ] >>= shouldBeSuccess
       spago [ "publish", "-p", "root", "--offline" ] >>= shouldBeFailureErr (fixture "publish/1307-publish-dependencies/expected-stderr.txt")
 
     Spec.it "#1110 installs versions of packages that are returned by the registry solver, but not present in cache" \{ spago, fixture, testCwd } -> do

test/Spago/Run.purs

@@ -2,9 +2,13 @@ module Test.Spago.Run where
 
 import Test.Prelude
 
+import Data.String as String
 import Spago.FS as FS
+import Spago.Path as Path
+import Spago.Paths as Paths
 import Test.Spec (Spec)
 import Test.Spec as Spec
+import Test.Spec.Assertions.String (shouldContain)
 
 spec :: Spec Unit
 spec = Spec.around withTempDir do
@@ -44,3 +48,47 @@ spec = Spec.around withTempDir do
       spago [ "install", "node-process", "arrays" ] >>= shouldBeSuccess
       spago [ "build" ] >>= shouldBeSuccess
       spago [ "run", "bye" , "world" ] >>= shouldBeSuccessOutput (fixture "run-args-output2.txt")
+
+    Spec.it "works with special characters in path (apostrophe, spaces, brackets)" \{ spago, fixture, testCwd } -> do
+      -- Test apostrophe - "Tim's Test" should become package "tims-test"
+      let dir1 = testCwd </> "Tim's Test"
+      FS.mkdirp dir1
+      Paths.chdir dir1
+      spago [ "init" ] >>= shouldBeSuccess
+      config1 <- FS.readTextFile (dir1 </> "spago.yaml")
+      config1 `shouldContain` "name: tims-test"
+      spago [ "build" ] >>= shouldBeSuccess
+      spago [ "run" ] >>= shouldBeSuccessOutput (fixture "run-output.txt")
+
+      -- Test spaces - "My Project Dir" should become "my-project-dir"
+      let dir2 = testCwd </> "My Project Dir"
+      FS.mkdirp dir2
+      Paths.chdir dir2
+      spago [ "init" ] >>= shouldBeSuccess
+      config2 <- FS.readTextFile (dir2 </> "spago.yaml")
+      config2 `shouldContain` "name: my-project-dir"
+      spago [ "build" ] >>= shouldBeSuccess
+      spago [ "run" ] >>= shouldBeSuccessOutput (fixture "run-output.txt")
+
+      -- Test multiple special characters - "Test #1 (dev)" should become "test-1-dev"
+      let dir3 = testCwd </> "Test #1 (dev)"
+      FS.mkdirp dir3
+      Paths.chdir dir3
+      spago [ "init" ] >>= shouldBeSuccess
+      config3 <- FS.readTextFile (dir3 </> "spago.yaml")
+      config3 `shouldContain` "name: test-1-dev"
+      spago [ "build" ] >>= shouldBeSuccess
+      spago [ "run" ] >>= shouldBeSuccessOutput (fixture "run-output.txt")
+
+    Spec.it "init fails gracefully when directory name has no valid characters" \{ spago, fixture, testCwd } -> do
+      let dir = testCwd </> "###"
+      FS.mkdirp dir
+      Paths.chdir dir
+      spago [ "init" ] >>= checkOutputs'
+        { stdoutFile: Nothing
+        , stderrFile: Just (fixture "init-invalid-dirname.txt")
+        , result: isLeft
+        , sanitize:
+            String.trim
+              >>> String.replaceAll (String.Pattern $ Path.toRaw dir) (String.Replacement "...")
+        }

test/Spago/Unit.purs

@@ -5,17 +5,21 @@ 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.Init as Init
 import Test.Spago.Unit.NodeVersion as NodeVersion
 import Test.Spago.Unit.Path as Path
 import Test.Spago.Unit.Printer as Printer
+import Test.Spago.Unit.Run as Run
 import Test.Spec (Spec)
 import Test.Spec as Spec
 
 spec :: Spec Unit
 spec = Spec.describe "unit" do
   FindFlags.spec
   CheckInjectivity.spec
+  Init.spec
   Printer.spec
   Git.spec
   Path.spec
   NodeVersion.spec
+  Run.spec

test/Spago/Unit/Init.purs

@@ -0,0 +1,81 @@
+module Test.Spago.Unit.Init where
+
+import Test.Prelude
+
+import Registry.PackageName as PackageName
+import Spago.Command.Init (folderToPackageName)
+import Test.Spec (Spec)
+import Test.Spec as Spec
+import Test.Spec.Assertions (shouldSatisfy)
+
+spec :: Spec Unit
+spec = Spec.describe "Init" do
+
+  Spec.describe "folderToPackageName" do
+
+    Spec.it "converts to lowercase" do
+      folderToPackageName "MyProject" `shouldEqualPkg` "myproject"
+      folderToPackageName "ALLCAPS" `shouldEqualPkg` "allcaps"
+
+    Spec.it "replaces spaces with dashes" do
+      folderToPackageName "my project" `shouldEqualPkg` "my-project"
+      folderToPackageName "My Project Dir" `shouldEqualPkg` "my-project-dir"
+
+    Spec.it "removes apostrophes (straight and curly)" do
+      folderToPackageName "Tim's Test" `shouldEqualPkg` "tims-test"
+      folderToPackageName "Tim's Test" `shouldEqualPkg` "tims-test"
+      folderToPackageName "it's" `shouldEqualPkg` "its"
+
+    Spec.it "removes double quotes" do
+      folderToPackageName "my\"project" `shouldEqualPkg` "myproject"
+      folderToPackageName "\"test\"" `shouldEqualPkg` "test"
+
+    Spec.it "replaces special characters with dashes" do
+      folderToPackageName "test#1" `shouldEqualPkg` "test-1"
+      folderToPackageName "test(dev)" `shouldEqualPkg` "test-dev"
+      folderToPackageName "test@home" `shouldEqualPkg` "test-home"
+      folderToPackageName "test_underscore" `shouldEqualPkg` "test-underscore"
+
+    Spec.it "collapses consecutive dashes" do
+      folderToPackageName "test--project" `shouldEqualPkg` "test-project"
+      folderToPackageName "a   b" `shouldEqualPkg` "a-b"
+      folderToPackageName "Test #1 (dev)" `shouldEqualPkg` "test-1-dev"
+
+    Spec.it "strips leading dashes" do
+      folderToPackageName "-test" `shouldEqualPkg` "test"
+      folderToPackageName "---test" `shouldEqualPkg` "test"
+      folderToPackageName "#test" `shouldEqualPkg` "test"
+
+    Spec.it "strips trailing dashes" do
+      folderToPackageName "test-" `shouldEqualPkg` "test"
+      folderToPackageName "test---" `shouldEqualPkg` "test"
+      folderToPackageName "test#" `shouldEqualPkg` "test"
+
+    Spec.it "handles digits" do
+      folderToPackageName "project123" `shouldEqualPkg` "project123"
+      folderToPackageName "123project" `shouldEqualPkg` "123project"
+
+    Spec.it "returns Nothing for invalid inputs" do
+      -- All special characters results in empty string
+      shouldBeNothing $ folderToPackageName "..."
+      shouldBeNothing $ folderToPackageName "###"
+      shouldBeNothing $ folderToPackageName "'''"
+
+    Spec.it "converts accented characters to ASCII" do
+      -- NFD normalization decomposes accents, keeping the base letter
+      folderToPackageName "café" `shouldEqualPkg` "cafe"
+      folderToPackageName "naïve" `shouldEqualPkg` "naive"
+      folderToPackageName "über" `shouldEqualPkg` "uber"
+      folderToPackageName "señor" `shouldEqualPkg` "senor"
+      folderToPackageName "Ångström" `shouldEqualPkg` "angstrom"
+
+    Spec.it "strips purescript- prefix" do
+      folderToPackageName "purescript-foo" `shouldEqualPkg` "foo"
+      folderToPackageName "Purescript-Bar" `shouldEqualPkg` "bar"
+
+  where
+  shouldEqualPkg actual expected =
+    (PackageName.print <$> actual) `shouldEqual` Just expected
+
+  shouldBeNothing actual =
+    (PackageName.print <$> actual) `shouldSatisfy` isNothing

test/Spago/Unit/Run.purs

@@ -0,0 +1,41 @@
+module Test.Spago.Unit.Run where
+
+import Test.Prelude
+
+import Spago.Command.Run (encodeFileUrlPath)
+import Test.Spec (Spec)
+import Test.Spec as Spec
+
+spec :: Spec Unit
+spec = Spec.describe "Run" do
+
+  Spec.describe "encodeFileUrlPath" do
+
+    Spec.it "encodes spaces" do
+      encodeFileUrlPath "/path/with spaces/file" `shouldEqual` "/path/with%20spaces/file"
+
+    Spec.it "encodes apostrophes" do
+      encodeFileUrlPath "/Volumes/Tim's Docs/project" `shouldEqual` "/Volumes/Tim%27s%20Docs/project"
+
+    Spec.it "encodes hash symbols" do
+      encodeFileUrlPath "/path/test#1/file" `shouldEqual` "/path/test%231/file"
+
+    Spec.it "encodes brackets" do
+      encodeFileUrlPath "/path/test[dev]/file" `shouldEqual` "/path/test%5Bdev%5D/file"
+
+    Spec.it "preserves Windows drive letters" do
+      encodeFileUrlPath "C:/Users/test" `shouldEqual` "C:/Users/test"
+      encodeFileUrlPath "D:/a/spago/output" `shouldEqual` "D:/a/spago/output"
+
+    Spec.it "preserves Windows drive letters with special chars in path" do
+      encodeFileUrlPath "C:/Users/Tim's Folder/project" `shouldEqual` "C:/Users/Tim%27s%20Folder/project"
+
+    Spec.it "handles lowercase drive letters" do
+      encodeFileUrlPath "c:/users/test" `shouldEqual` "c:/users/test"
+
+    Spec.it "encodes colon in non-drive-letter segments" do
+      -- A colon not at the start as a drive letter should be encoded
+      encodeFileUrlPath "/path/file:name/test" `shouldEqual` "/path/file%3Aname/test"
+
+    Spec.it "leaves normal paths unchanged" do
+      encodeFileUrlPath "/home/user/project/output" `shouldEqual` "/home/user/project/output"