Merge pull request commercialhaskell#3541 from commercialhaskell/3520-revision-matching

snoyberg · web-flow · commit 64794699803f · 2017-11-03T12:34:38.000+02:00
Better errors for 00-index, and ignore-revision-mismatch commercialhaskell#3520
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -111,6 +111,8 @@ Other enhancements:
   to GHC. See:
   [#3454](https://github.com/commercialhaskell/stack/issues/3454)
 * Add hpack `package.yaml` to build Stack itself
+* Add `ignore-revision-mismatch` setting. See:
+  [#3520](https://github.com/commercialhaskell/stack/issues/3520).
 
 Bug fixes:
 
diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md
@@ -840,7 +840,25 @@ save-hackage-creds: true
 ```
 
 Since 1.5.0
-  
+
+### ignore-revision-mismatch
+
+Cabal files in packages can be specified via exact revisions to deal
+with Hackage revision metadata. The default behavior of Stack (since
+1.6.0) is to fail if an exact match is not found. In some cases
+(specifically, when using a legacy `00-index.tar.gz` file), users may
+wish to allow a mismatch. In such cases, you can change
+`ignore-revision-mismatch` from `false` to `true`.
+
+```yaml
+ignore-revision-mismatch: false
+```
+
+For more information, see
+[the Github issue #3520 discussion](https://github.com/commercialhaskell/stack/issues/3520).
+
+Since 1.6.0
+
 # urls
 
 Customize the URLs where `stack` looks for snapshot build plans.
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -373,6 +373,7 @@ configFromConfigMonoid
          configDefaultTemplate = getFirst configMonoidDefaultTemplate
          configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs
          configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds
+         configIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch
 
      configAllowDifferentUser <-
         case getFirst configMonoidAllowDifferentUser of
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
@@ -72,6 +72,7 @@ data FetchException
     | CouldNotParsePackageSelectors [String]
     | UnknownPackageNames (Set PackageName)
     | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String
+        Bool -- Do we use any 00-index.tar.gz indices? Just used for more informative error messages
     deriving Typeable
 instance Exception FetchException
 
@@ -97,10 +98,11 @@ instance Show FetchException where
     show (UnknownPackageNames names) =
         "The following packages were not found in your indices: " ++
         intercalate ", " (map packageNameString $ Set.toList names)
-    show (UnknownPackageIdentifiers idents suggestions) =
+    show (UnknownPackageIdentifiers idents suggestions uses00Index) =
         "The following package identifiers were not found in your indices: " ++
         intercalate ", " (map packageIdentifierRevisionString $ HashSet.toList idents) ++
-        (if null suggestions then "" else "\n" ++ suggestions)
+        (if null suggestions then "" else "\n" ++ suggestions) ++
+        (if uses00Index then "\n\nYou seem to be using a legacy 00-index.tar.gz tarball.\nConsider changing your configuration to use a 01-index.tar.gz file.\nAlternatively, you can set the ignore-revision-mismatch setting to true.\nFor more information, see: https://github.com/commercialhaskell/stack/issues/3520" else "")
 
 -- | Fetch packages into the cache without unpacking
 fetchPackages :: HasConfig env => Set PackageIdentifier -> RIO env ()
@@ -202,12 +204,21 @@ resolvePackages mSnapshotDef idents0 names0 = do
             go >>= either throwM return
         Right x -> return x
   where
-    go = r <$> resolvePackagesAllowMissing mSnapshotDef idents0 names0
-    r (missingNames, missingIdents, idents)
+    go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0
+    r uses00Index (missingNames, missingIdents, idents)
       | not $ Set.null missingNames  = Left $ UnknownPackageNames       missingNames
-      | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents ""
+      | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index
       | otherwise                    = Right idents
 
+-- | Does the configuration use a 00-index.tar.gz file for indices?
+-- See <https://github.com/commercialhaskell/stack/issues/3520>
+getUses00Index :: HasConfig env => RIO env Bool
+getUses00Index =
+    any is00 <$> view packageIndicesL
+  where
+    is00 :: PackageIndex -> Bool
+    is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index
+
 -- | Turn package identifiers and package names into a list of
 -- @ResolvedPackage@s. Returns any unresolved names and
 -- identifier. These are considered unresolved even if the only
@@ -256,23 +267,30 @@ resolvePackagesAllowMissing mSnapshotDef idents0 names0 = do
       (missingNames, idents1) = partitionEithers $ map
           (\name -> maybe (Left name) Right (getNamed name))
           (Set.toList names0)
+  config <- view configL
   let (missingIdents, resolved) =
         partitionEithers
-          $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage pir cache))
+          $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage config pir cache))
           $ idents0 <> idents1
   return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved)
 
-lookupResolvedPackage :: PackageIdentifierRevision -> PackageCache PackageIndex -> Maybe ResolvedPackage
-lookupResolvedPackage (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do
+lookupResolvedPackage :: Config -> PackageIdentifierRevision -> PackageCache PackageIndex -> Maybe ResolvedPackage
+lookupResolvedPackage config (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do
   (index, mdownload, files) <- HashMap.lookup name cache >>= HashMap.lookup version
+  let moffsetSize =
+        case cfi of
+          CFILatest -> Just $ snd $ NE.last files
+          CFIHash _msize hash' -> -- TODO check size?
+              lookup hash'
+            $ concatMap (\(hashes, x) -> map (, x) hashes)
+            $ NE.toList files
+          CFIRevision rev -> fmap snd $ listToMaybe $ drop (fromIntegral rev) $ NE.toList files
   offsetSize <-
-    case cfi of
-      CFILatest -> Just $ snd $ NE.last files
-      CFIHash _msize hash' -> -- TODO check size?
-          lookup hash'
-        $ concatMap (\(hashes, x) -> map (, x) hashes)
-        $ NE.toList files
-      CFIRevision rev -> fmap snd $ listToMaybe $ drop (fromIntegral rev) $ NE.toList files
+    case moffsetSize of
+      Just x -> Just x
+      Nothing
+        | configIgnoreRevisionMismatch config -> Just $ snd $ NE.last files
+        | otherwise -> Nothing
   Just ResolvedPackage
     { rpIdent = ident
     , rpDownload = mdownload
@@ -365,9 +383,10 @@ withCabalLoader inner = do
                                 _ <- getPackageCaches
                                 return ()
                             return (False, doLookup ident)
-                        else return (toUpdate,
-                                     throwIO $ UnknownPackageIdentifiers
-                                       (HashSet.singleton ident) (T.unpack suggestions))
+                        else do
+                          uses00Index <- unliftIO u getUses00Index
+                          return (toUpdate, throwIO $ UnknownPackageIdentifiers
+                                       (HashSet.singleton ident) (T.unpack suggestions) uses00Index)
     inner doLookup
 
 lookupPackageIdentifierExact
@@ -376,7 +395,8 @@ lookupPackageIdentifierExact
   -> PackageCache PackageIndex
   -> m (Maybe ByteString)
 lookupPackageIdentifierExact identRev cache = do
-  forM (lookupResolvedPackage identRev cache) $ \rp -> do
+  config <- view configL
+  forM (lookupResolvedPackage config identRev cache) $ \rp -> do
     [bs] <- withCabalFiles (indexName (rpIndex rp)) [(rp, ())] $ \_ _ bs -> return bs
     return bs
 
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -358,6 +358,10 @@ data Config =
          ,configSaveHackageCreds    :: !Bool
          -- ^ Should we save Hackage credentials to a file?
          ,configRunner              :: !Runner
+         ,configIgnoreRevisionMismatch :: !Bool
+         -- ^ Ignore a revision mismatch when loading up cabal files,
+         -- and fall back to the latest revision. See:
+         -- <https://github.com/commercialhaskell/stack/issues/3520>
          }
 
 data HpackExecutable
@@ -758,6 +762,8 @@ data ConfigMonoid =
     -- ^ See 'configDumpLogs'
     , configMonoidSaveHackageCreds   :: !(First Bool)
     -- ^ See 'configSaveHackageCreds'
+    , configMonoidIgnoreRevisionMismatch :: !(First Bool)
+    -- ^ See 'configIgnoreRevisionMismatch'
     }
   deriving (Show, Generic)
 
@@ -850,6 +856,7 @@ parseConfigMonoidObject rootDir obj = do
     configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName
     configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName
     configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName
+    configMonoidIgnoreRevisionMismatch <- First <$> obj ..:? configMonoidIgnoreRevisionMismatchName
 
     return ConfigMonoid {..}
   where
@@ -989,6 +996,9 @@ configMonoidDumpLogsName = "dump-logs"
 configMonoidSaveHackageCredsName :: Text
 configMonoidSaveHackageCredsName = "save-hackage-creds"
 
+configMonoidIgnoreRevisionMismatchName :: Text
+configMonoidIgnoreRevisionMismatchName = "ignore-revision-mismatch"
+
 data ConfigException
   = ParseConfigFileException (Path Abs File) ParseException
   | ParseCustomSnapshotException Text ParseException
diff --git a/test/integration/tests/3520-revision-matching/Main.hs b/test/integration/tests/3520-revision-matching/Main.hs
@@ -0,0 +1,13 @@
+import StackTest
+import Control.Monad
+import Data.List
+import System.Directory
+
+main :: IO ()
+main = do
+  copyFile "bad-stack.yaml" "stack.yaml"
+  stackErrStderr ["build", "--dry-run"] $ \msg ->
+    unless ("legacy 00-index.tar.gz" `isInfixOf` msg) $
+      error "Expected a warning about 00-index usage"
+  copyFile "good-stack.yaml" "stack.yaml"
+  stack ["build", "--dry-run"]
diff --git a/test/integration/tests/3520-revision-matching/files/.gitignore b/test/integration/tests/3520-revision-matching/files/.gitignore
@@ -0,0 +1,2 @@
+stack.yaml
+*.cabal
diff --git a/test/integration/tests/3520-revision-matching/files/bad-stack.yaml b/test/integration/tests/3520-revision-matching/files/bad-stack.yaml
@@ -0,0 +1,6 @@
+resolver: lts-9.10
+
+package-indices:
+- name: Hackage00
+  download-prefix: https://hackage.haskell.org/package
+  http: https://hackage.haskell.org/00-index.tar.gz
diff --git a/test/integration/tests/3520-revision-matching/files/good-stack.yaml b/test/integration/tests/3520-revision-matching/files/good-stack.yaml
@@ -0,0 +1,8 @@
+resolver: lts-9.10
+
+package-indices:
+- name: Hackage00
+  download-prefix: https://hackage.haskell.org/package
+  http: https://hackage.haskell.org/00-index.tar.gz
+
+ignore-revision-mismatch: true
diff --git a/test/integration/tests/3520-revision-matching/files/package.yaml b/test/integration/tests/3520-revision-matching/files/package.yaml
@@ -0,0 +1,9 @@
+name: issue3520
+version: 0.1.0.0
+
+dependencies:
+- base
+- mtl
+
+library:
+  source-dirs: src
diff --git a/test/integration/tests/3520-revision-matching/files/src/Foo.hs b/test/integration/tests/3520-revision-matching/files/src/Foo.hs
@@ -0,0 +1 @@
+module Foo where
