packages feed

pantry 0.11.3 → 0.11.4

raw patch · 5 files changed

+160/−75 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Pantry: CyclicSnapshot :: ![RawSnapshotLocation] -> !RawSnapshotLocation -> PantryException

Files

ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for pantry
 
+## v0.11.4
+
+* If snapshot locations are cyclic, loading a snapshot throws an exception
+  rather than going round in circles.
+
 ## v0.11.3
 
 * Depend on package `ram` (rather than `memory`).
app/test-pretty-exceptions/Main.hs view
@@ -148,6 +148,10 @@   , [ InvalidSnapshot rawSnapshotLocation someExceptionExample
     | rawSnapshotLocation <- rawSnapshotLocationExamples
     ]
+  , [ CyclicSnapshot
+        [cyclicRawSnapshotLocationExample]
+        cyclicRawSnapshotLocationExample
+    ]
   , [ InvalidGlobalHintsLocation pathAbsDirExample rawPathExample ]
   , [ InvalidFilePathGlobalHints rawPathExample ]
   , [ MismatchedPackageMetadata rawPackageLocationImmutable rawPackageMetadata treeKey packageIdentifierExample
@@ -337,6 +341,9 @@     | snapNameExample <- snapNameExamples
     ]
   ]
+
+cyclicRawSnapshotLocationExample :: RawSnapshotLocation
+cyclicRawSnapshotLocationExample = RSLFilePath resolvedPathFileExample
 
 rawPackageMetadataExamples :: [RawPackageMetadata]
 rawPackageMetadataExamples =
int/Pantry/Types.hs view
@@ -56,6 +56,7 @@   , PHpack (..)
   -- , PackageTarball (..)
   , RawPackageLocation (..)
+  , sameRSL
   , PackageLocation (..)
   , toRawPL
   , RawPackageLocationImmutable (..)
@@ -202,7 +203,8 @@                    , mkNarrativeList, parens, string, style
                    )
 import           RIO.PrettyPrint.Types ( Style (..) )
-import           Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc )
+import           Text.PrettyPrint.Leijen.Extended
+                   ( Pretty (..), StyleDoc, noAnnotate )
 
 #if MIN_VERSION_aeson(2, 0, 0)
 import qualified Data.Aeson.KeyMap as HM
@@ -1107,6 +1109,7 @@   | InvalidOverrideCompiler !WantedCompiler !WantedCompiler
   | InvalidFilePathSnapshot !Text
   | InvalidSnapshot !RawSnapshotLocation !SomeException
+  | CyclicSnapshot ![RawSnapshotLocation] !RawSnapshotLocation
   | InvalidGlobalHintsLocation !(Path Abs Dir) !Text
   | InvalidFilePathGlobalHints !Text
   | MismatchedPackageMetadata
@@ -1301,6 +1304,17 @@     <> display loc
     <> ":\n"
     <> displayShow err
+  display (CyclicSnapshot knownLocs loc) =
+    "Error: [S-789]\n"
+    <> "Cycle detected while reading snapshot. Snapshot locations "
+    <> "encountered:\n"
+    <> fold
+         ( intersperse
+             "\n"
+             (map (\knownLoc -> "- " <> display knownLoc) allLocs)
+         )
+   where
+    allLocs = reverse $ loc : knownLocs
   display (InvalidGlobalHintsLocation dir t) =
     "Error: [S-926]\n"
     <> "Invalid global hints location "
@@ -1718,6 +1732,21 @@          ]
     <> blankLine
     <> string (displayException err)
+  pretty (CyclicSnapshot knownLocs loc) =
+    "[S-789]"
+    <> line
+    <> fillSep
+         [ flow "Cycle detected while reading snapshot. Snapshot locations"
+         , "encountered:"
+         ]
+    <> line
+    <> bulletedList (map (\l -> styleLoc l $ pretty l) allLocs)
+   where
+    allLocs = reverse $ loc : knownLocs
+
+    styleLoc knownLoc =
+      if sameRSL knownLoc loc then style Error . noAnnotate else id
+
   pretty (InvalidGlobalHintsLocation dir t) =
     "[S-926]"
     <> line
@@ -3210,6 +3239,16 @@   toJSON (RSLFilePath resolved) =
     object ["filepath" .= resolvedRelative resolved]
   toJSON (RSLSynonym syn) = toJSON syn
+
+-- | Same as '==' but ignores any 'BlobKey' for URLs and the local path for
+-- resolved file paths.
+sameRSL :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
+sameRSL (RSLCompiler wc1) (RSLCompiler wc2) = wc1 == wc2
+sameRSL (RSLUrl url1 _) (RSLUrl url2 _) = url1 == url2
+sameRSL (RSLFilePath rfp1) (RSLFilePath rfp2) =
+  resolvedAbsolute rfp1 == resolvedAbsolute rfp2
+sameRSL (RSLSynonym s1) (RSLSynonym s2) = s1 == s2
+sameRSL _ _ = False
 
 -- | Where to load a snapshot from.
 --
pantry.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack
 
 name:           pantry
-version:        0.11.3
+version:        0.11.4
 synopsis:       Content addressable Haskell package management
 description:    Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme>
 category:       Development
@@ -13,7 +13,7 @@ bug-reports:    https://github.com/commercialhaskell/pantry/issues
 author:         Michael Snoyman
 maintainer:     michael@snoyman.com
-copyright:      2018-2022 FP Complete
+copyright:      2018-2026 FP Complete
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
src/Pantry.hs view
@@ -292,10 +292,10 @@                    , parsePackageNameThrowing, parseRawPackageLocationImmutables
                    , parseRawSnapshotLocation, parseSnapName, parseTreeM
                    , parseVersion, parseVersionThrowing, parseWantedCompiler
-                   , pirForHash, renderTree, resolvePaths, snapshotLocation
-                   , toCabalStringMap, toRawPL, toRawPLI, toRawPM, toRawSL
-                   , toRawSnapshotLayer, unCabalStringMap, unSafeFilePath
-                   , versionString, warnMissingCabalFile
+                   , pirForHash, renderTree, resolvePaths, sameRSL
+                   , snapshotLocation, toCabalStringMap, toRawPL, toRawPLI
+                   , toRawPM, toRawSL, toRawSnapshotLayer, unCabalStringMap
+                   , unSafeFilePath, versionString, warnMissingCabalFile
                    )
 import           Path
                    ( Abs, Dir, File, Path, (</>), filename, parent, parseAbsDir
@@ -1286,43 +1286,52 @@             f x
             loop
 
--- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'.
---
--- @since 0.1.0.0
+-- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. Throws an
+-- exception is a cycle is detected.
 loadSnapshotRaw ::
      (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
-  => RawSnapshotLocation
+  => [RawSnapshotLocation]
+     -- ^ Raw snapshot locations already encountered, most recent first.
+  -> RawSnapshotLocation
   -> RIO env RawSnapshot
-loadSnapshotRaw loc = do
-  eres <- loadRawSnapshotLayer loc
-  case eres of
-    Left wc ->
-      pure RawSnapshot
-        { rsCompiler = wc
-        , rsPackages = mempty
-        , rsDrop = mempty
-        }
-    Right (rsl, _) -> do
-      snap0 <- loadSnapshotRaw $ rslParent rsl
-      (packages, unused) <-
-        addPackagesToSnapshot
-          (display loc)
-          (rslLocations rsl)
-          AddPackagesConfig
-            { apcDrop = rslDropPackages rsl
-            , apcFlags = rslFlags rsl
-            , apcHiddens = rslHidden rsl
-            , apcGhcOptions = rslGhcOptions rsl
+loadSnapshotRaw knownLocs loc
+  | elemBy sameRSL loc knownLocs = throwM (CyclicSnapshot knownLocs loc)
+  | otherwise = do
+      eres <- loadRawSnapshotLayer loc
+      case eres of
+        Left wc ->
+          pure RawSnapshot
+            { rsCompiler = wc
+            , rsPackages = mempty
+            , rsDrop = mempty
             }
-          (rsPackages snap0)
-      warnUnusedAddPackagesConfig (display loc) unused
-      pure RawSnapshot
-        { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl)
-        , rsPackages = packages
-        , rsDrop = apcDrop unused
-        }
+        Right (rsl, _) -> do
+          snap0 <- loadSnapshotRaw (loc : knownLocs) (rslParent rsl)
+          (packages, unused) <-
+            addPackagesToSnapshot
+              (display loc)
+              (rslLocations rsl)
+              AddPackagesConfig
+                { apcDrop = rslDropPackages rsl
+                , apcFlags = rslFlags rsl
+                , apcHiddens = rslHidden rsl
+                , apcGhcOptions = rslGhcOptions rsl
+                }
+              (rsPackages snap0)
+          warnUnusedAddPackagesConfig (display loc) unused
+          pure RawSnapshot
+            { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl)
+            , rsPackages = packages
+            , rsDrop = apcDrop unused
+            }
 
--- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'.
+-- | Helper function, like 'Data.List.elem' but with a provided equality
+-- function.
+elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool
+elemBy eq x = any (eq x)
+
+-- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. Throws an
+-- exception if a cycle is detected.
 --
 -- @since 0.1.0.0
 loadSnapshot ::
@@ -1339,7 +1348,7 @@         , rsDrop = mempty
         }
     Right rsl -> do
-      snap0 <- loadSnapshotRaw $ rslParent rsl
+      snap0 <- loadSnapshotRaw [toRawSL loc] $ rslParent rsl
       (packages, unused) <-
         addPackagesToSnapshot
           (display loc)
@@ -1404,7 +1413,7 @@ 
 -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing
 -- any incomplete package locations. Debug output will include the raw snapshot
--- layer.
+-- layer. Throws an exception if a cycle is detected.
 --
 -- @since 0.1.0.0
 loadAndCompleteSnapshotRaw ::
@@ -1430,40 +1439,65 @@   -> Map RawPackageLocationImmutable PackageLocationImmutable
      -- ^ Cached locations from lock file
   -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
-loadAndCompleteSnapshotRaw' debugRSL rawLoc cacheSL cachePL = do
-  eres <- case Map.lookup rawLoc cacheSL of
-    Just loc -> right (, CompletedSL rawLoc loc) <$> loadSnapshotLayer loc
-    Nothing -> loadRawSnapshotLayer rawLoc
-  case eres of
-    Left wc ->
-      let snapshot = Snapshot
-            { snapshotCompiler = wc
-            , snapshotPackages = mempty
-            , snapshotDrop = mempty
-            }
-      in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], [])
-    Right (rsl, sloc) -> do
-      (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw' debugRSL (rslParent rsl) cacheSL cachePL
-      when debugRSL $ logDebug $ fromString $ show rsl
-      (packages, completed, unused) <-
-        addAndCompletePackagesToSnapshot
-          rawLoc
-          cachePL
-          (rslLocations rsl)
-          AddPackagesConfig
-            { apcDrop = rslDropPackages rsl
-            , apcFlags = rslFlags rsl
-            , apcHiddens = rslHidden rsl
-            , apcGhcOptions = rslGhcOptions rsl
-            }
-          (snapshotPackages snap0)
-      warnUnusedAddPackagesConfig (display rawLoc) unused
-      let snapshot = Snapshot
-            { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl)
-            , snapshotPackages = packages
-            , snapshotDrop = apcDrop unused
-            }
-      pure (snapshot, sloc : slocs,completed0 ++ completed)
+loadAndCompleteSnapshotRaw' = loadAndCompleteSnapshotRaw'' []
+
+
+-- | As for 'loadAndCompleteSnapshotRaw' but allows toggling of the debug output
+-- of the raw snapshot layer. Throws an exception if a cycle is detected.
+loadAndCompleteSnapshotRaw'' ::
+     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+  => [RawSnapshotLocation]
+     -- ^ Raw snapshot locations already encountered, most recent first.
+  -> Bool -- ^ Debug output includes the raw snapshot layer
+  -> RawSnapshotLocation
+  -> Map RawSnapshotLocation SnapshotLocation
+     -- ^ Cached snapshot locations from lock file
+  -> Map RawPackageLocationImmutable PackageLocationImmutable
+     -- ^ Cached locations from lock file
+  -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
+loadAndCompleteSnapshotRaw'' knownRawLocs debugRSL rawLoc cacheSL cachePL
+  | elemBy sameRSL rawLoc knownRawLocs =
+      throwM (CyclicSnapshot knownRawLocs rawLoc)
+  | otherwise = do
+      eres <- case Map.lookup rawLoc cacheSL of
+        Just loc -> right (, CompletedSL rawLoc loc) <$> loadSnapshotLayer loc
+        Nothing -> loadRawSnapshotLayer rawLoc
+      case eres of
+        Left wc ->
+          let snapshot = Snapshot
+                { snapshotCompiler = wc
+                , snapshotPackages = mempty
+                , snapshotDrop = mempty
+                }
+          in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], [])
+        Right (rsl, sloc) -> do
+          (snap0, slocs, completed0) <-
+            loadAndCompleteSnapshotRaw''
+              (rawLoc : knownRawLocs)
+              debugRSL
+              (rslParent rsl)
+              cacheSL
+              cachePL
+          when debugRSL $ logDebug $ fromString $ show rsl
+          (packages, completed, unused) <-
+            addAndCompletePackagesToSnapshot
+              rawLoc
+              cachePL
+              (rslLocations rsl)
+              AddPackagesConfig
+                { apcDrop = rslDropPackages rsl
+                , apcFlags = rslFlags rsl
+                , apcHiddens = rslHidden rsl
+                , apcGhcOptions = rslGhcOptions rsl
+                }
+              (snapshotPackages snap0)
+          warnUnusedAddPackagesConfig (display rawLoc) unused
+          let snapshot = Snapshot
+                { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl)
+                , snapshotPackages = packages
+                , snapshotDrop = apcDrop unused
+                }
+          pure (snapshot, sloc : slocs,completed0 ++ completed)
 
 data SingleOrNot a
   = Single !a