WIP fix local+noindex on Windows

haskell · Jan 8, 2025 · 71b3427 · 71b3427
1 parent 1c7243f
commit 71b3427
Show file tree

Hide file tree

Showing 7 changed files with 43 additions and 12 deletions.
diff --git a/Cabal-syntax/src/Distribution/Utils/Path.hs b/Cabal-syntax/src/Distribution/Utils/Path.hs
@@ -67,6 +67,9 @@ module Distribution.Utils.Path
 
     -- ** Module names
   , moduleNameSymbolicPath
+
+    -- * Windows
+  , posixizePath
   ) where
 
 import Distribution.Compat.Prelude
@@ -531,3 +534,17 @@ 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.
+posixizePath :: FilePath -> FilePath
+posixizePath = map (\x -> case x of
+                       '\\' -> '/'
+                       _ -> x
+                   )
diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
@@ -227,7 +227,8 @@ import System.Directory
   , renameFile
   )
 import System.FilePath
-  ( takeDirectory
+  ( normalise
+  , takeDirectory
   , (<.>)
   , (</>)
   )
@@ -1693,7 +1694,13 @@ 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}
 

diff --git a/cabal-install/src/Distribution/Client/GlobalFlags.hs b/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"
 

diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/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

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -2040,7 +2040,13 @@ remoteRepoSectionDescr =
     localToRemote :: LocalRepo -> RemoteRepo
     localToRemote (LocalRepo name path sharedCache) =
       (emptyRemoteRepo name)
-        { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")
+        { remoteRepoURI =
+            URI
+             "file+noindex:"
+             Nothing
+             ((if isWindows then joinDrive "//./" . posixizePath else id) path)
+             ""
+             (if sharedCache then "#shared-cache" else "")
         }
 
 -------------------------------

diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs
@@ -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 "//./" . posixizePath
                                         else id) (testRepoDir env)
 
 -- | Given a directory (relative to the 'testCurrentDir') containing

diff --git a/doc/config.rst b/doc/config.rst
@@ -200,6 +200,10 @@ repository.
 ``package-name-version.tar.gz`` files in the directory, and will use optional
 corresponding ``package-name-version.cabal`` files as new revisions.
 
+.. note::
+   On Windows systems, the path has to be prefixed by ``//./`` as in
+   ``url: file+noindex:////./C:/absolute/path/to/directory``.
+
 For example, if ``/absolute/path/to/directory`` looks like
 ::