Stricter path types for stricter path-related logic (purescript#1296)

Author: fsoikin

.github/workflows/build.yml

@@ -45,7 +45,10 @@ jobs:
         env:
           cache-name: cache-node-modules
         with:
-          path: ~/.npm
+          path: |
+            ~/.npm
+            $APPDATA/npm
+            node_modules
           key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/package.json') }}
           restore-keys: |
             ${{ runner.os }}-build-${{ env.cache-name }}-

CHANGELOG.md

@@ -42,6 +42,7 @@ Other improvements:
   help catch typos in field names.
 - When the `publish.location` field is missing, `spago publish` will attempt to
   figure out the location from Git remotes and write it back to `spago.yaml`.
+- Internally Spago uses stricter-typed file paths.
 
 ## [0.21.0] - 2023-05-04
 

CONTRIBUTING.md

@@ -111,3 +111,50 @@ Learn by doing and get your hands dirty!
 [f-f]: https://github.com/f-f
 [discord]: https://purescript.org/chat
 [spago-issues]: https://github.com/purescript/spago/issues
+
+## Working with file paths
+
+File paths are very important in Spago. A very big chunk of Spago does is
+shuffling files around and manipulating their paths. Representing them as plain
+strings is not enough.
+
+Spago has three different kinds of paths, represented as distinct types:
+
+- `RootPath` can generally be the root of anything, but in practice it usually
+  points to the root directory of the current workspace. It is constructed in
+  `Main.purs` close to the entry point and is available in all `ReaderT`
+  environments as `rootPath :: RootPath`
+- `LocalPath` is path of a particular file or directory within the workspace. It
+  doesn't have to be literally _within_ the workspace directory - e.g. a custom
+  dependency that lives somewhere on the local file system, - but it's still
+  _relative_ to the workspace. A `LocalPath` is explicitly broken into two
+  parts: a `RootPath` and the "local" part relative to the root. This is useful
+  for printing out workspace-relative paths in user-facing output, while still
+  retaining the full path for actual file operations. A `LocalPath` can be
+  constructed by appending to a `RootPath`. Once so constructed, the `LocalPath`
+  always retains the same root, no matter what subsequent manipulations are done
+  to it. Therefore, if you have a `LocalPath` value, its root is probably
+  pointing to the current workspace directory.
+- `GlobalPath` is for things that are not related to the current workspace.
+  Examples include paths to executables, such as `node` and `purs`, and global
+  directories, such as `registryPath` and `globalCachePath`.
+
+Paths can be appended by using the `</>` operator. It is overloaded for all
+three path types and allows to append string segments to them. When appending to
+a `RootPath`, the result comes out as `LocalPath`. You cannot produce a new
+`RootPath` by appending.
+
+Most code that deals with the workspace operates in `LocalPath` values. Most
+code that deals with external and global things operates in `GlobalPath` values.
+Lower-level primitives, such as in the `Spago.FS` module, are polymorphic and
+can take all three path types as parameters.
+
+For example:
+
+```haskell
+rootPath <- Path.mkRootPath =<< Paths.cwd
+config <- readConfig (rootPath </> "spago.yaml")
+let srcDir = rootPath </> "src"
+compileResult <- callCompiler [ srcDir </> "Main.purs", srcDir </> "Lib.purs" ]
+FS.writeFile (rootPath </> "result.json") (serialize compileResult)
+```

bin/src/Flags.purs

@@ -336,15 +336,15 @@ depsOnly =
         <> O.help "Build depedencies only"
     )
 
-publicKeyPath :: Parser FilePath
+publicKeyPath :: Parser RawFilePath
 publicKeyPath =
   O.strOption
     ( O.short 'i'
         <> O.metavar "PUBLIC_KEY_PATH"
         <> O.help "Select the path of the public key to use for authenticating operations of the package"
     )
 
-privateKeyPath :: Parser FilePath
+privateKeyPath :: Parser RawFilePath
 privateKeyPath =
   O.strOption
     ( O.short 'i'

bin/src/Main.purs

@@ -15,7 +15,6 @@ import Data.Set as Set
 import Effect.Aff as Aff
 import Effect.Aff.AVar as AVar
 import Effect.Now as Now
-import Node.Process as Process
 import Options.Applicative (CommandFields, Mod, Parser, ParserPrefs(..))
 import Options.Applicative as O
 import Options.Applicative.Types (Backtracking(..))
@@ -52,6 +51,7 @@ import Spago.Generated.BuildInfo as BuildInfo
 import Spago.Git as Git
 import Spago.Json as Json
 import Spago.Log (LogVerbosity(..))
+import Spago.Path as Path
 import Spago.Paths as Paths
 import Spago.Purs as Purs
 import Spago.Registry as Registry
@@ -163,7 +163,7 @@ type BundleArgs =
   { minify :: Boolean
   , sourceMaps :: Boolean
   , module :: Maybe String
-  , outfile :: Maybe FilePath
+  , outfile :: Maybe String
   , platform :: Maybe String
   , selectedPackage :: Maybe String
   , pursArgs :: List String
@@ -536,7 +536,8 @@ main = do
     \c -> Aff.launchAff_ case c of
       Cmd'SpagoCmd (SpagoCmd globalArgs@{ offline, migrateConfig } command) -> do
         logOptions <- mkLogOptions startingTime globalArgs
-        runSpago { logOptions } case command of
+        rootPath <- Path.mkRoot =<< Paths.cwd
+        runSpago { logOptions, rootPath } case command of
           Sources args -> do
             { env } <- mkFetchEnv
               { packages: mempty
@@ -551,11 +552,9 @@ main = do
             void $ runSpago env (Sources.run { json: args.json })
           Init args@{ useSolver } -> do
             -- Fetch the registry here so we can select the right package set later
-            env <- mkRegistryEnv offline
-
+            env <- mkRegistryEnv offline <#> Record.union { rootPath }
             setVersion <- parseSetVersion args.setVersion
             void $ runSpago env $ Init.run { mode: args.mode, setVersion, useSolver }
-
           Fetch args -> do
             { env, fetchOpts } <- mkFetchEnv (Record.merge { isRepl: false, migrateConfig, offline } args)
             void $ runSpago env (Fetch.run fetchOpts)
@@ -600,7 +599,7 @@ main = do
             void $ runSpago publishEnv (Publish.publish {})
 
           Repl args@{ selectedPackage } -> do
-            packages <- FS.exists "spago.yaml" >>= case _ of
+            packages <- FS.exists (rootPath </> "spago.yaml") >>= case _ of
               true -> do
                 -- if we have a config then we assume it's a workspace, and we can run a repl in the project
                 pure mempty -- TODO newPackages
@@ -609,9 +608,10 @@ main = do
                 logWarn "No configuration found, creating a temporary project to run a repl in..."
                 tmpDir <- mkTemp
                 FS.mkdirp tmpDir
-                logDebug $ "Creating repl project in temp dir: " <> tmpDir
-                liftEffect $ Process.chdir tmpDir
-                env <- mkRegistryEnv offline
+                logDebug $ "Creating repl project in temp dir: " <> Path.quote tmpDir
+                Paths.chdir tmpDir
+                tmpRootPath <- Path.mkRoot tmpDir
+                env <- mkRegistryEnv offline <#> Record.union { rootPath: tmpRootPath }
                 void $ runSpago env $ Init.run
                   { setVersion: Nothing
                   , mode: Init.InitWorkspace { packageName: Just "repl" }
@@ -661,12 +661,12 @@ main = do
               testEnv <- runSpago env (mkTestEnv args buildEnv)
               runSpago testEnv Test.run
           LsPaths args -> do
-            runSpago { logOptions } $ Ls.listPaths args
+            runSpago { logOptions, rootPath } $ Ls.listPaths args
           LsPackages args@{ pure } -> do
             let fetchArgs = { packages: mempty, selectedPackage: Nothing, pure, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }
             { env: env@{ workspace }, fetchOpts } <- mkFetchEnv fetchArgs
             dependencies <- runSpago env (Fetch.run fetchOpts)
-            let lsEnv = { workspace, dependencies, logOptions }
+            let lsEnv = { workspace, dependencies, logOptions, rootPath }
             runSpago lsEnv (Ls.listPackageSet args)
           LsDeps { selectedPackage, json, transitive, pure } -> do
             let fetchArgs = { packages: mempty, selectedPackage, pure, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }
@@ -691,12 +691,12 @@ main = do
             { env, fetchOpts } <- mkFetchEnv { packages: mempty, selectedPackage: Nothing, pure: false, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }
             dependencies <- runSpago env (Fetch.run fetchOpts)
             purs <- Purs.getPurs
-            runSpago { dependencies, logOptions, purs, workspace: env.workspace } (Graph.graphModules args)
+            runSpago { dependencies, logOptions, rootPath, purs, workspace: env.workspace } (Graph.graphModules args)
           GraphPackages args -> do
             { env, fetchOpts } <- mkFetchEnv { packages: mempty, selectedPackage: Nothing, pure: false, ensureRanges: false, testDeps: false, isRepl: false, migrateConfig, offline }
             dependencies <- runSpago env (Fetch.run fetchOpts)
             purs <- Purs.getPurs
-            runSpago { dependencies, logOptions, purs, workspace: env.workspace } (Graph.graphPackages args)
+            runSpago { dependencies, logOptions, rootPath, purs, workspace: env.workspace } (Graph.graphPackages args)
 
       Cmd'VersionCmd v -> when v do
         output (OutputLines [ BuildInfo.packages."spago-bin" ])
@@ -721,7 +721,7 @@ main = do
 
 mkBundleEnv :: forall a. BundleArgs -> Spago (Fetch.FetchEnv a) (Bundle.BundleEnv ())
 mkBundleEnv bundleArgs = do
-  { workspace, logOptions } <- ask
+  { workspace, logOptions, rootPath } <- ask
   logDebug $ "Bundle args: " <> show bundleArgs
 
   selected <- case workspace.selected of
@@ -770,18 +770,19 @@ mkBundleEnv bundleArgs = do
       , sourceMaps: bundleArgs.sourceMaps
       , extraArgs
       }
+    argsOutput = bundleArgs.output <#> (rootPath </> _)
     newWorkspace = workspace
       { buildOptions
-          { output = bundleArgs.output <|> workspace.buildOptions.output
+          { output = argsOutput <|> workspace.buildOptions.output
           }
       }
   esbuild <- Esbuild.getEsbuild
-  let bundleEnv = { esbuild, logOptions, workspace: newWorkspace, selected, bundleOptions }
+  let bundleEnv = { esbuild, logOptions, rootPath, workspace: newWorkspace, selected, bundleOptions }
   pure bundleEnv
 
 mkRunEnv :: forall a b. RunArgs -> Build.BuildEnv b -> Spago (Fetch.FetchEnv a) (Run.RunEnv ())
 mkRunEnv runArgs { dependencies, purs } = do
-  { workspace, logOptions } <- ask
+  { workspace, logOptions, rootPath } <- ask
   logDebug $ "Run args: " <> show runArgs
 
   node <- Run.getNode
@@ -816,17 +817,18 @@ mkRunEnv runArgs { dependencies, purs } = do
     runOptions =
       { moduleName
       , execArgs
-      , executeDir: Paths.cwd
+      , executeDir: Path.toGlobal rootPath
       , successMessage: Nothing
       , failureMessage: "Running failed."
       }
-  let newWorkspace = workspace { buildOptions { output = runArgs.output <|> workspace.buildOptions.output } }
-  let runEnv = { logOptions, workspace: newWorkspace, selected, node, runOptions, dependencies, purs }
+  let argsOutput = runArgs.output <#> (rootPath </> _)
+  let newWorkspace = workspace { buildOptions { output = argsOutput <|> workspace.buildOptions.output } }
+  let runEnv = { logOptions, rootPath, workspace: newWorkspace, selected, node, runOptions, dependencies, purs }
   pure runEnv
 
 mkTestEnv :: forall a b. TestArgs -> Build.BuildEnv b -> Spago (Fetch.FetchEnv a) (Test.TestEnv ())
 mkTestEnv testArgs { dependencies, purs } = do
-  { workspace, logOptions } <- ask
+  { workspace, logOptions, rootPath } <- ask
   logDebug $ "Test args: " <> show testArgs
 
   node <- Run.getNode
@@ -860,8 +862,9 @@ mkTestEnv testArgs { dependencies, purs } = do
 
   logDebug $ "Selected packages to test: " <> Json.stringifyJson (CJ.Common.nonEmptyArray PackageName.codec) (map _.selected.package.name selectedPackages)
 
-  let newWorkspace = workspace { buildOptions { output = testArgs.output <|> workspace.buildOptions.output } }
-  let testEnv = { logOptions, workspace: newWorkspace, selectedPackages, node, dependencies, purs }
+  let argsOutput = testArgs.output <#> (rootPath </> _)
+  let newWorkspace = workspace { buildOptions { output = argsOutput <|> workspace.buildOptions.output } }
+  let testEnv = { logOptions, rootPath, workspace: newWorkspace, selectedPackages, node, dependencies, purs }
   pure testEnv
 
 mkBuildEnv
@@ -876,12 +879,13 @@ mkBuildEnv
   -> Fetch.PackageTransitiveDeps
   -> Spago (Fetch.FetchEnv ()) (Build.BuildEnv ())
 mkBuildEnv buildArgs dependencies = do
-  { logOptions, workspace, git } <- ask
+  { logOptions, rootPath, workspace, git } <- ask
   purs <- Purs.getPurs
   let
+    argsOutput = buildArgs.output <#> (rootPath </> _)
     newWorkspace = workspace
       { buildOptions
-          { output = buildArgs.output <|> workspace.buildOptions.output
+          { output = argsOutput <|> workspace.buildOptions.output
           , statVerbosity = buildArgs.statVerbosity <|> workspace.buildOptions.statVerbosity
           }
       -- Override the backend args from the config if they are passed in through a flag
@@ -895,6 +899,7 @@ mkBuildEnv buildArgs dependencies = do
 
   pure
     { logOptions
+    , rootPath
     , purs
     , git
     , dependencies
@@ -925,7 +930,7 @@ mkPublishEnv dependencies = do
 
 mkReplEnv :: forall a. ReplArgs -> Fetch.PackageTransitiveDeps -> PackageMap -> Spago (Fetch.FetchEnv a) (Repl.ReplEnv ())
 mkReplEnv replArgs dependencies supportPackage = do
-  { workspace, logOptions } <- ask
+  { workspace, logOptions, rootPath } <- ask
   logDebug $ "Repl args: " <> show replArgs
 
   purs <- Purs.getPurs
@@ -941,16 +946,17 @@ mkReplEnv replArgs dependencies supportPackage = do
     , supportPackage
     , depsOnly: false
     , logOptions
+    , rootPath
     , pursArgs: Array.fromFoldable replArgs.pursArgs
     , selected
     }
 
-mkFetchEnv :: forall a b. { offline :: OnlineStatus, migrateConfig :: Boolean, isRepl :: Boolean | FetchArgsRow b } -> Spago (LogEnv a) { env :: Fetch.FetchEnv (), fetchOpts :: Fetch.FetchOpts }
+mkFetchEnv :: forall a b. { offline :: OnlineStatus, migrateConfig :: Boolean, isRepl :: Boolean | FetchArgsRow b } -> Spago (SpagoBaseEnv a) { env :: Fetch.FetchEnv (), fetchOpts :: Fetch.FetchOpts }
 mkFetchEnv args@{ migrateConfig, offline } = do
   let
-    parsePackageName p = case PackageName.parse p of
-      Right pkg -> Right pkg
-      Left err -> Left ("- Could not parse package " <> show p <> ": " <> err)
+    parsePackageName p =
+      PackageName.parse p
+        # lmap \err -> "- Could not parse package " <> show p <> ": " <> err
   let { right: packageNames, left: failedPackageNames } = partitionMap parsePackageName (Array.fromFoldable args.packages)
   unless (Array.null failedPackageNames) do
     die $ [ toDoc "Failed to parse some package name: " ] <> map (indent <<< toDoc) failedPackageNames
@@ -960,25 +966,28 @@ mkFetchEnv args@{ migrateConfig, offline } = do
     Left _err -> die $ "Failed to parse selected package name, was: " <> show args.selectedPackage
 
   env <- mkRegistryEnv offline
-  workspace <- runSpago env (Config.readWorkspace { maybeSelectedPackage, pureBuild: args.pure, migrateConfig })
+  { rootPath } <- ask
+  workspace <-
+    runSpago (Record.union env { rootPath })
+      (Config.readWorkspace { maybeSelectedPackage, pureBuild: args.pure, migrateConfig })
   let fetchOpts = { packages: packageNames, ensureRanges: args.ensureRanges, isTest: args.testDeps, isRepl: args.isRepl }
-  pure { fetchOpts, env: Record.union { workspace } env }
+  pure { fetchOpts, env: Record.union { workspace, rootPath } env }
 
-mkRegistryEnv :: forall a. OnlineStatus -> Spago (LogEnv a) (Registry.RegistryEnv ())
+mkRegistryEnv :: forall a. OnlineStatus -> Spago (SpagoBaseEnv a) (Registry.RegistryEnv ())
 mkRegistryEnv offline = do
-  logDebug $ "CWD: " <> Paths.cwd
+  { logOptions, rootPath } <- ask
 
   -- Take care of the caches
   FS.mkdirp Paths.globalCachePath
-  FS.mkdirp Paths.localCachePath
-  FS.mkdirp Paths.localCachePackagesPath
-  logDebug $ "Global cache: " <> show Paths.globalCachePath
-  logDebug $ "Local cache: " <> show Paths.localCachePath
+  FS.mkdirp $ rootPath </> Paths.localCachePath
+  FS.mkdirp $ rootPath </> Paths.localCachePackagesPath
+  logDebug $ "Workspace root path: " <> Path.quote rootPath
+  logDebug $ "Global cache: " <> Path.quote Paths.globalCachePath
+  logDebug $ "Local cache: " <> Paths.localCachePath
 
   -- Make sure we have git and purs
   git <- Git.getGit
   purs <- Purs.getPurs
-  { logOptions } <- ask
   db <- liftEffect $ Db.connect
     { database: Paths.databasePath
     , logger: \str -> Reader.runReaderT (logDebug $ "DB: " <> str) { logOptions }
@@ -997,7 +1006,7 @@ mkRegistryEnv offline = do
 
 mkLsEnv :: forall a. Fetch.PackageTransitiveDeps -> Spago (Fetch.FetchEnv a) Ls.LsEnv
 mkLsEnv dependencies = do
-  { logOptions, workspace } <- ask
+  { logOptions, workspace, rootPath } <- ask
   selected <- case workspace.selected of
     Just s -> pure s
     Nothing ->
@@ -1013,15 +1022,16 @@ mkLsEnv dependencies = do
               [ toDoc "No package was selected. Please select (with -p) one of the following packages:"
               , indent (toDoc $ map _.package.name workspacePackages)
               ]
-  pure { logOptions, workspace, dependencies, selected }
+  pure { logOptions, workspace, dependencies, selected, rootPath }
 
 mkDocsEnv :: ∀ a. DocsArgs -> Fetch.PackageTransitiveDeps -> Spago (Fetch.FetchEnv a) (Docs.DocsEnv ())
 mkDocsEnv args dependencies = do
-  { logOptions, workspace } <- ask
+  { logOptions, rootPath, workspace } <- ask
   purs <- Purs.getPurs
   pure
     { purs
     , logOptions
+    , rootPath
     , workspace
     , dependencies
     , depsOnly: args.depsOnly