Improve sanitisation of paths and project names

f-f · f-f · commit 93fa35fddefb · 2026-01-25T22:08:56.000+02:00
diff --git a/src/Spago/Command/Init.purs b/src/Spago/Command/Init.purs
@@ -6,6 +6,7 @@ module Spago.Command.Init
   , InitOptions
   , defaultConfig
   , defaultConfig'
+  , folderToPackageName
   , pursReplFile
   , run
   , srcMainTemplate
@@ -14,14 +15,15 @@ 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)
 import Spago.Config as Config
 import Spago.FS as FS
-import Spago.Log as Log
 import Spago.Path as Path
 import Spago.Registry (RegistryEnv)
 import Spago.Registry as Registry
@@ -111,14 +113,13 @@ run opts = do
         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
+    pname <- 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."
         ]
-      Right p -> pure p
+      Just p -> pure p
+    logDebug [ Path.quote rootPath, "\"" <> candidateName <> "\" -> \"" <> PackageName.print pname <> "\"" ]
     logDebug [ "Got packageName and setVersion:", PackageName.print pname, unsafeStringify opts.setVersion ]
     pure pname
 
@@ -299,3 +300,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
diff --git a/src/Spago/Command/Run.purs b/src/Spago/Command/Run.purs
@@ -12,6 +12,8 @@ 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 JSURI (encodeURIComponent)
 import Node.FS.Perms as Perms
 import Registry.Version as Version
 import Spago.Cmd as Cmd
@@ -83,10 +85,17 @@ run = do
 
         nodeArgs = [ Path.toRaw runJsPath ] <> opts.execArgs
 
+        -- Encode each path segment for use in file:// URL
+        -- Splits on /, encodes each segment, rejoins with /
+        encodeFileUrlPath str =
+          String.split (String.Pattern "/") str
+            # map (\seg -> fromMaybe seg (encodeURIComponent seg))
+            # String.joinWith "/"
+
         nodeContents =
           Array.fold
             [ "import { main } from 'file://"
-            , Path.toRaw (withForwardSlashes absOutput)
+            , encodeFileUrlPath $ Path.toRaw (withForwardSlashes absOutput)
             , "/"
             , opts.moduleName
             , "/"
diff --git a/test-fixtures/init-invalid-dirname.txt b/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.
diff --git a/test/Spago/Run.purs b/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 "...")
+        }
diff --git a/test/Spago/Unit.purs b/test/Spago/Unit.purs
@@ -5,6 +5,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.Init as Init
 import Test.Spago.Unit.NodeVersion as NodeVersion
 import Test.Spago.Unit.Path as Path
 import Test.Spago.Unit.Printer as Printer
@@ -15,6 +16,7 @@ spec :: Spec Unit
 spec = Spec.describe "unit" do
   FindFlags.spec
   CheckInjectivity.spec
+  Init.spec
   Printer.spec
   Git.spec
   Path.spec
diff --git a/test/Spago/Unit/Init.purs b/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

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,2 @@`
	`1`	`+✘ Could not derive a valid package name from directory "...".`
	`2`	`+Please use --name to specify a package name.`