Merge pull request #3 from jasagredo/js/fix-local-noindex-windows

Fix local+noindex repos on Windows

cabal-install/cabal-install.cabal

@@ -230,6 +230,7 @@ library
         echo       >= 0.1.3    && < 0.2,
         edit-distance >= 0.2.2 && < 0.3,
         exceptions >= 0.10.4   && < 0.11,
+        file-uri   >= 0.1      && < 0.2,
         filepath   >= 1.4.0.0  && < 1.6,
         HTTP       >= 4000.1.5 && < 4000.5,
         mtl        >= 2.0      && < 2.4,

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

@@ -110,6 +110,7 @@ import Distribution.Utils.NubList
   )
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
 import qualified Data.Map as M
 import Distribution.Client.Errors
 import Distribution.Client.HttpUtils
@@ -207,6 +208,10 @@ import Distribution.Simple.Utils
   , warn
   )
 import Distribution.Solver.Types.ConstraintSource
+import Distribution.System
+  ( OS (Windows)
+  , buildOS
+  )
 import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath)
 import Distribution.Verbosity
   ( normal
@@ -215,6 +220,7 @@ import Network.URI
   ( URI (..)
   , URIAuth (..)
   , parseURI
+  , uriToString
   )
 import System.Directory
   ( XdgDirectory (XdgCache, XdgConfig, XdgState)
@@ -234,6 +240,11 @@ import System.FilePath
 import System.IO.Error
   ( isDoesNotExistError
   )
+import System.URI.File
+  ( FileURI (..)
+  , ParseSyntax (..)
+  , parseFileURI
+  )
 import Text.PrettyPrint
   ( ($+$)
   )
@@ -1049,12 +1060,12 @@ readConfigFile initial file =
         else ioError ioe
 
 createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig
-createDefaultConfigFile verbosity extraLines filePath = do
+createDefaultConfigFile verbosity extraLines filepath = do
   commentConf <- commentSavedConfig
   initialConf <- initialSavedConfig
   extraConf <- parseExtraLines verbosity extraLines
-  notice verbosity $ "Writing default configuration to " ++ filePath
-  writeConfigFile filePath commentConf (initialConf `mappend` extraConf)
+  notice verbosity $ "Writing default configuration to " ++ filepath
+  writeConfigFile filepath commentConf (initialConf `mappend` extraConf)
   return initialConf
 
 writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
@@ -1692,8 +1703,18 @@ postProcessRepo lineno reponameStr repo0 = do
     -- TODO: check that there are no authority, query or fragment
     -- Note: the trailing colon is important
     "file+noindex:" -> do
-      let uri = remoteRepoURI repo0
-      return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")
+      -- defer to file-uri package which is more accurate when parsing Windows
+      -- paths
+      let uri' = BS8.pack $ "file:" ++ uriToString id ((remoteRepoURI repo0) { uriScheme = "" }) []
+      case parseFileURI (if buildOS == Windows then ExtendedWindows else ExtendedPosix) uri' of
+        Left{} -> fail $ "Invalid path in URI: " <> show (remoteRepoURI repo0)
+        Right uri'' ->
+            return
+          $ Left
+          $ LocalRepo
+              reponame
+              (BS8.unpack $ filePath uri'')
+              (uriFragment (remoteRepoURI repo0) == "#shared-cache")
     _ -> do
       let repo = repo0{remoteRepoName = reponame}
 

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

@@ -69,7 +69,7 @@ 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
+import qualified System.FilePath as FilePath
 
 -- ------------------------------------------------------------
 
@@ -192,9 +192,9 @@ withRepoContext'
   ignoreExpiry
   extraPaths = \callback -> do
     for_ localNoIndexRepos $ \local ->
-      unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
+      unless (FilePath.isAbsolute (localRepoPath local)) $
         warn verbosity $
-          "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"
+          "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path (" ++ show (localRepoPath local) ++ ")  is not absolute; this is fragile, and not recommended"
 
     transportRef <- newMVar Nothing
     let httpLib =

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

@@ -142,7 +142,7 @@ import Distribution.Compat.Directory (listDirectory)
 import Distribution.Compat.Time (getFileAge, getModTime)
 import Distribution.Utils.Generic (fstOf3)
 import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredDecodeFileOrFail, structuredEncodeFile)
-import System.Directory (doesDirectoryExist, doesFileExist)
+import System.Directory (doesDirectoryExist, doesFileExist, makeAbsolute)
 import System.FilePath
   ( normalise
   , splitDirectories
@@ -900,7 +900,9 @@ withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo nam
             entries
         case tarballPackageDescription of
           Just ce -> return (Just ce)
-          Nothing -> dieWithException verbosity $ CannotReadCabalFile expectFilename tarFile
+          Nothing -> do
+            tarFile' <- makeAbsolute tarFile
+            dieWithException verbosity $ CannotReadCabalFile expectFilename tarFile'
 
   let (prefs, gpds) =
         partitionEithers $
@@ -975,7 +977,8 @@ withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo nam
                     -- Here we show the _failure_ to parse the `.cabal` file as
                     -- a warning. This will impact which versions/packages are
                     -- available in your index, so users should know!
-                    warn verbosity $ "In " <> tarFile <> ": " <> displayException exception
+                    tarFile' <- makeAbsolute tarFile
+                    warn verbosity $ "In " <> tarFile' <> ": " <> displayException exception
                     pure Nothing
                   Right genericPackageDescription ->
                     pure $ Just $ CacheGPD genericPackageDescription bytes

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

@@ -46,24 +46,6 @@ 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 \\.
   . (if buildOS == Windows then resub "([A-Z]):\\\\" "\\\\" else id)
   . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv)))

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

@@ -608,11 +608,15 @@ withRepoNoUpdate repo_dir m = do
     withReaderT (\env' -> env' { testHaveRepo = True }) m
     -- TODO: Arguably should undo everything when we're done...
   where
-    repoUri env ="file+noindex://" ++ (if isWindows
-                                        then map (\x -> case x of
-                                            '\\' -> '/'
-                                            _ -> x)
-                                        else id) (testRepoDir env)
+    repoUri env ="file+noindex://"
+      ++ (if isWindows
+           -- Windows paths need a preceeding slash to be compliant with file
+           -- URI RFCs (8089 and 3986). In particular to be an instance of
+           -- @path-absolute@.
+           then ('/' :) . map (\x -> case x of
+                                       '\\' -> '/'
+                                       _ -> x)
+           else id) (testRepoDir env)
 
 -- | Given a directory (relative to the 'testCurrentDir') containing
 -- a series of directories representing packages, generate an

doc/config.rst

@@ -198,7 +198,9 @@ repository.
 
 ``cabal`` will construct the index automatically from the
 ``package-name-version.tar.gz`` files in the directory, and will use optional
-corresponding ``package-name-version.cabal`` files as new revisions.
+corresponding ``package-name-version.cabal`` files as new revisions. Note that
+Windows should use three slashes too, as in
+``file+noindex:///C:/absolute/path/to/directory``.
 
 For example, if ``/absolute/path/to/directory`` looks like
 ::