Merge pull request haskell#10728 from jasagredo/js/local-noindex

Fix file+noindex URI usage on Windows

Author: mergify[bot]

Cabal-syntax/src/Distribution/Utils/Path.hs

@@ -67,6 +67,9 @@ module Distribution.Utils.Path
 
     -- ** Module names
   , moduleNameSymbolicPath
+
+    -- * Windows
+  , asPosixPath
   ) where
 
 import Distribution.Compat.Prelude
@@ -86,6 +89,8 @@ import qualified Distribution.Compat.CharParsing as P
 
 import qualified System.Directory as Directory
 import qualified System.FilePath as FilePath
+import qualified System.FilePath.Posix as Posix
+import qualified System.FilePath.Windows as Windows
 
 import Data.Kind
   ( Type
@@ -531,3 +536,38 @@ data Response
 --
 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 data PkgConf
+
+-------------------------------------------------------------------------------
+
+-- * Windows utils
+
+-------------------------------------------------------------------------------
+
+-- | Sometimes we need to represent a Windows path (that might have been
+-- normalized) as a POSIX path, for example in URIs, as that is what
+-- @network-uri@ understands. Furthermore they need to use the @\\\\.\\@ DOS
+-- device syntax or otherwise the filepath will be unusable.
+--
+-- >>> import Network.URI
+-- >>> uriPath <$> parseURI "file+noindex://C:/foo.txt"
+-- Just "/foo.txt"
+-- >>> parseURI "file+noindex://C:\foo.txt"
+-- Nothing
+-- >>> uriPath <$> parseURI "file+noindex:///C:/foo.txt"
+-- Just "/C:/foo.txt"
+-- >>> uriPath <$> parseURI "file+noindex:////./C:/foo.txt"
+-- Just "//./C:/foo.txt"
+--
+-- Out of the ones above, only the last one can be used from anywhere in the
+-- system, after normalization into @"\\\\.\\C:/foo.txt"@ (see filepath#247 for
+-- why there is a forward slash there):
+--
+-- >>> import Network.URI
+-- >>> import qualified System.FilePath.Windows as Windows
+-- >>> Windows.normalise . uriPath <$> parseURI "file+noindex:////./C:/foo.txt"
+-- Just "\\\\.\\C:/foo.txt"
+asPosixPath :: FilePath -> FilePath
+asPosixPath p =
+  -- We don't use 'isPathSeparator' because @Windows.isPathSeparator
+  -- Posix.pathSeparator == True@.
+  [if x == Windows.pathSeparator then Posix.pathSeparator else x | x <- p]

Makefile

@@ -125,7 +125,7 @@ ghcid-cli: ## Run ghcid for the cabal-install executable.
 
 .PHONY: doctest
 doctest: ## Run doctests.
-	cd Cabal-syntax && $(DOCTEST)
+	cd Cabal-syntax && $(DOCTEST) --build-depends=network-uri
 	cd Cabal-described && $(DOCTEST)
 	cd Cabal && $(DOCTEST)
 	cd cabal-install-solver && $(DOCTEST)

cabal-install/src/Distribution/Client/Config.hs

@@ -227,7 +227,8 @@ import System.Directory
   , renameFile
   )
 import System.FilePath
-  ( takeDirectory
+  ( normalise
+  , takeDirectory
   , (<.>)
   , (</>)
   )
@@ -1693,7 +1694,14 @@ postProcessRepo lineno reponameStr repo0 = do
     -- Note: the trailing colon is important
     "file+noindex:" -> do
       let uri = remoteRepoURI repo0
-      return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")
+      return $
+        Left $
+          LocalRepo
+            reponame
+            -- Normalization of Windows paths that use @//./@ does not fully
+            -- normalize the path (see filepath#247), but it is still usable.
+            (normalise (uriPath uri))
+            (uriFragment uri == "#shared-cache")
     _ -> do
       let repo = repo0{remoteRepoName = reponame}
 

cabal-install/src/Distribution/Client/GlobalFlags.hs

@@ -57,7 +57,8 @@ import Network.URI
   , uriScheme
   )
 import System.FilePath
-  ( (</>)
+  ( isAbsolute
+  , (</>)
   )
 
 import qualified Distribution.Client.Security.DNS as Sec.DNS
@@ -69,8 +70,6 @@ import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote
 import qualified Hackage.Security.Util.Path as Sec
 import qualified Hackage.Security.Util.Pretty as Sec
 
-import qualified System.FilePath.Posix as FilePath.Posix
-
 -- ------------------------------------------------------------
 
 -- * Global flags
@@ -192,7 +191,7 @@ withRepoContext'
   ignoreExpiry
   extraPaths = \callback -> do
     for_ localNoIndexRepos $ \local ->
-      unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
+      unless (isAbsolute (localRepoPath local)) $
         warn verbosity $
           "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"
 

cabal-install/src/Distribution/Client/IndexUtils.hs

@@ -466,7 +466,7 @@ readRepoIndex verbosity repoCtxt repo idxState =
             RepoSecure{..} -> warn verbosity $ exceptionMessageCabalInstall $ MissingPackageList repoRemote
             RepoLocalNoIndex local _ ->
               warn verbosity $
-                "Error during construction of local+noindex "
+                "Error during construction of file+noindex "
                   ++ unRepoName (localRepoName local)
                   ++ " repository index: "
                   ++ show e
@@ -526,7 +526,7 @@ whenCacheOutOfDate index action = do
     then action
     else
       if localNoIndex index
-        then return () -- TODO: don't update cache for local+noindex repositories
+        then return () -- TODO: don't update cache for file+noindex repositories
         else do
           indexTime <- getModTime $ indexFile index
           cacheTime <- getModTime $ cacheFile index

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -175,7 +175,7 @@ import Distribution.Simple.Command
   , option
   , reqArg'
   )
-import Distribution.System (Arch, OS)
+import Distribution.System (Arch, OS (Windows), buildOS)
 import Distribution.Types.PackageVersionConstraint
   ( PackageVersionConstraint
   )
@@ -187,7 +187,7 @@ import Distribution.Utils.Path hiding
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Network.URI (URI (..), parseURI)
+import Network.URI (URI (..), nullURIAuth, parseURI)
 import System.Directory (createDirectoryIfMissing, makeAbsolute)
 import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, (</>))
 import Text.PrettyPrint
@@ -2040,9 +2040,30 @@ remoteRepoSectionDescr =
     localToRemote :: LocalRepo -> RemoteRepo
     localToRemote (LocalRepo name path sharedCache) =
       (emptyRemoteRepo name)
-        { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")
+        { remoteRepoURI =
+            normaliseFileNoIndexURI buildOS $
+              URI
+                "file+noindex:"
+                (Just nullURIAuth)
+                path
+                ""
+                (if sharedCache then "#shared-cache" else "")
         }
 
+-- | When on Windows, we need to convert the path to be POSIX-style.
+--
+-- >>> normaliseFileNoIndexURI Windows (URI "file+noindex:" (Just nullURIAuth) "\\\\.\\C:\\dev\\foo" "" "")
+-- file+noindex:////./C:/dev/foo
+--
+-- See haddocks of 'asPosixPath' for some examples of why this is needed for
+-- @network-uri@.
+normaliseFileNoIndexURI :: OS -> URI -> URI
+normaliseFileNoIndexURI os uri@(URI scheme auth path query fragment)
+  | "file+noindex:" <- scheme
+  , Windows <- os =
+      URI scheme auth (asPosixPath path) query fragment
+  | otherwise = uri
+
 -------------------------------
 -- Local field utils
 --

cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

@@ -33,6 +33,7 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
 import Distribution.Simple.Program.Db
 import Distribution.Simple.Program.Types
 import Distribution.Simple.Utils (toUTF8BS)
+import Distribution.System (OS (Windows), buildOS)
 import Distribution.Types.PackageVersionConstraint
 import Distribution.Version
 
@@ -1016,7 +1017,10 @@ instance Arbitrary LocalRepo where
   arbitrary =
     LocalRepo
       <$> arbitrary
-      <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths
+      <*> elements
+        ( (if buildOS == Windows then map (normalise . ("//./C:" ++)) else id)
+            ["/tmp/foo", "/tmp/bar"]
+        ) -- TODO: generate valid absolute paths
       <*> arbitrary
 
 instance Arbitrary PreSolver where

cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs

@@ -46,25 +46,7 @@ normalizeOutput nenv =
   . resub (posixRegexEscape "tmp/src-" ++ "[0-9]+") "<TMPDIR>"
   . resub (posixRegexEscape (normalizerTmpDir nenv) ++ sameDir) "<ROOT>/"
   . resub (posixRegexEscape (normalizerCanonicalTmpDir nenv) ++ sameDir) "<ROOT>/"
-  . (if buildOS == Windows
-        then
-          -- OK. Here's the deal. In `./Prelude.hs`, `withRepoNoUpdate` sets
-          -- `repoUri` to the tmpdir but with backslashes replaced with
-          -- slashes. This is because Windows treats backslashes and forward
-          -- slashes largely the same in paths, and backslashes aren't allowed
-          -- in a URL like `file+noindex://...`.
-          --
-          -- But that breaks the regexes above, which expect the paths to have
-          -- backslashes.
-          --
-          -- Honestly this whole `normalizeOutput` thing is super janky and
-          -- worth rewriting from the ground up. To you, poor soul in the
-          -- future, here is one more hack upon a great pile. Hey, at least all
-          -- the `PackageTests` function as a test suite for this thing...
-            resub (posixRegexEscape (backslashToSlash $ normalizerTmpDir nenv) ++ sameDir) "<ROOT>/"
-          . resub (posixRegexEscape (backslashToSlash $ normalizerCanonicalTmpDir nenv) ++ sameDir) "<ROOT>/"
-        else id)
-      -- Munge away C: prefix on filenames (Windows). We convert C:\\ to \\.
+    -- Munge away C:\ prefix on filenames (Windows). We convert C:\ to \.
   . (if buildOS == Windows then resub "([A-Z]):\\\\" "\\\\" else id)
   . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv)))
     -- Look for 0.1/installed-0d6uzW7Ubh1Fb4TB5oeQ3G
@@ -96,6 +78,14 @@ normalizeOutput nenv =
         else id)
   . normalizeBuildInfoJson
   . maybe id normalizePathCmdOutput (normalizerCabalInstallVersion nenv)
+    -- Munge away \\.\C:/ prefix on paths (Windows). We convert @\\.\C:/@ to
+    -- @\@. We need to do this before the step above as that one would convert
+    -- @\\.\@ to @\.\@.
+    --
+    -- These paths might come up in file+noindex URIs due to @filepath@
+    -- normalizing @//./C:/foo.txt@ paths to @\\.\C:/foo.txt@, see
+    -- (filepath#247).
+  . (if buildOS == Windows then resub "\\\\\\\\\\.\\\\([A-Z]):/" "\\\\" else id)
   -- hackage-security locks occur non-deterministically
   . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" ""
   . resub "installed: [0-9]+(\\.[0-9]+)*" "installed: <VERSION>"

cabal-testsuite/src/Test/Cabal/Prelude.hs

@@ -48,7 +48,7 @@ import Distribution.PackageDescription
 import Test.Utils.TempTestDir (withTestDir)
 import Distribution.Verbosity (normal)
 import Distribution.Utils.Path
-  ( makeSymbolicPath, relativeSymbolicPath, interpretSymbolicPathCWD )
+  ( asPosixPath, makeSymbolicPath, relativeSymbolicPath, interpretSymbolicPathCWD )
 
 import Distribution.Compat.Stack
 
@@ -613,9 +613,7 @@ withRepoNoUpdate repo_dir m = do
     -- TODO: Arguably should undo everything when we're done...
   where
     repoUri env ="file+noindex://" ++ (if isWindows
-                                        then map (\x -> case x of
-                                            '\\' -> '/'
-                                            _ -> x)
+                                        then joinDrive "//./" . asPosixPath
                                         else id) (testRepoDir env)
 
 -- | Given a directory (relative to the 'testCurrentDir') containing

changelog.d/pr-10728

@@ -0,0 +1,14 @@
+synopsis: Fix `file+noindex` URI usage on Windows
+packages: cabal-install
+prs: #10728
+issues: #10703
+significance:
+
+description: {
+
+- `file+noindex` repositories in Windows systems must use the format `file+noindex:////./C:/path/to/repo`.
+  This syntax comes from https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats#dos-device-paths,
+  and is the only syntax for DOS paths fully supported by the `network-uri` package, which Cabal uses to
+  interpret URIs in repository stanzas.
+
+}