diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for pantry +## v0.4.0.0 + +* Add a deprecation warning when using a repo/archive without a cabal file, see [Stack #5210](https://github.com/commercialhaskell/stack/issues/5210) +* Do not include repo/archive dependencies which do not include cabal files in lock files +* Remove some no longer used functions + ## v0.3.0.0 * Upgrade to Cabal 3.0 diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.32.0. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 66b17dc690d946f2a8ece380f0bd2b576e16f19d1f63e5a163eb2d6c7c81f1fa +-- hash: 9e29bee888e549f8360e383c2731ae492d94e7f64fca959461665c70cbece9c8 name: pantry -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Content addressable Haskell package management description: Please see the README on Github at category: Development diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -104,9 +104,10 @@ , AddPackagesConfig (..) -- * Completion functions + , CompletePackageLocation (..) , completePackageLocation - , completeSnapshotLayer , completeSnapshotLocation + , warnMissingCabalFile -- * Parsers , parseWantedCompiler @@ -820,7 +821,8 @@ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env Package -loadPackageRaw rpli = +loadPackageRaw rpli = do + logInfo $ "In loadPackageRaw: " <> display rpli case getRawTreeKey rpli of Just treeKey' -> do mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' @@ -893,15 +895,28 @@ Just treeId -> fmap Just (withStorage (loadPackageById rlpi (entityKey treeId))) +-- | Complete package location, plus whether the package has a cabal file. This +-- is relevant to reproducibility, see +-- +-- +-- @since 0.4.0.0 +data CompletePackageLocation = CompletePackageLocation + { cplComplete :: !PackageLocationImmutable + , cplHasCabalFile :: !Bool + } + -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. -- -- @since 0.1.0.0 completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable - -> RIO env PackageLocationImmutable + -> RIO env CompletePackageLocation completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = - pure $ PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk + pure CompletePackageLocation + { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk + , cplHasCabalFile = True + } completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do logDebug $ "Completing package location information from " <> display pir0 (pir, cfKey) <- @@ -916,7 +931,10 @@ logDebug $ "Added in cabal file hash: " <> display pir pure (pir, BlobKey sha size) treeKey' <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' + pure CompletePackageLocation + { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' + , cplHasCabalFile = True + } completePackageLocation pl@(RPLIArchive archive rpm) = do mpackage <- case rpmTreeKey rpm of @@ -925,7 +943,13 @@ case (,,) <$> raHash archive <*> raSize archive <*> mpackage of Just (sha256, fileSize, package) -> do let RawArchive loc _ _ subdir = archive - pure $ PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) + pure CompletePackageLocation + { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } Nothing -> byThirdParty (isJust mpackage) where byThirdParty warnAboutMissingSizeSha = do @@ -933,7 +957,14 @@ when warnAboutMissingSizeSha (warnWith sha size) -- (getArchive checks archive and package metadata) let RawArchive loc _ _ subdir = archive - pure $ PLIArchive (Archive loc sha size subdir) (packagePM package) + logDebug $ fromString $ show (pl, sha, size, package) + pure CompletePackageLocation + { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } warnWith sha size = logWarn (mconcat @@ -947,20 +978,29 @@ ]) completePackageLocation pl@(RPLIRepo repo rpm) = do unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo - PLIRepo repo <$> completePM pl rpm + completePM repo pl rpm where isSHA1 t = T.length t == 40 && T.all isHexDigit t completePM :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable + => Repo + -> RawPackageLocationImmutable -> RawPackageMetadata - -> RIO env PackageMetadata -completePM plOrig rpm@(RawPackageMetadata mn mv mtk) - | Just n <- mn, Just v <- mv, Just tk <- mtk = - pure $ PackageMetadata (PackageIdentifier n v) tk + -> RIO env CompletePackageLocation +completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) + | Just n <- mn, Just v <- mv, Just tk <- mtk = do + let pm = PackageMetadata (PackageIdentifier n v) tk + pure CompletePackageLocation + { cplComplete = PLIRepo repo pm + -- This next bit is a hack: we don't know for certain that this is the case. + -- However, for the use case where complete package metadata has been supplied, + -- we'll assume there's a cabal file for purposes of generating a deprecation warning. + , cplHasCabalFile = True + } | otherwise = do - pm <- packagePM <$> loadPackageRaw plOrig + package <- loadPackageRaw plOrig + let pm = packagePM package let isSame x (Just y) = x == y isSame _ _ = True @@ -969,7 +1009,13 @@ isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && isSame (pmTreeKey pm) (rpmTreeKey rpm) if allSame - then pure pm + then pure CompletePackageLocation + { cplComplete = PLIRepo repo pm + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } else throwIO $ CompletePackageMetadataMismatch plOrig pm packagePM :: Package -> PackageMetadata @@ -992,27 +1038,6 @@ bs <- loadFromURL url Nothing pure $ SLUrl url (bsToBlobKey bs) --- | Fill in optional fields in a 'SnapshotLayer' for more reproducible builds. --- --- @since 0.1.0.0 -completeSnapshotLayer - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLayer - -> RIO env SnapshotLayer -completeSnapshotLayer rsnapshot = do - parent' <- completeSnapshotLocation $ rslParent rsnapshot - pls <- traverseConcurrently completePackageLocation $ rslLocations rsnapshot - pure SnapshotLayer - { slParent = parent' - , slLocations = pls - , slCompiler= rslCompiler rsnapshot - , slDropPackages = rslDropPackages rsnapshot - , slFlags = rslFlags rsnapshot - , slHidden = rslHidden rsnapshot - , slGhcOptions = rslGhcOptions rsnapshot - , slPublishTime = rslPublishTime rsnapshot - } - traverseConcurrently_ :: (Foldable f, HasPantryConfig env) => (a -> RIO env ()) -- ^ action to perform @@ -1042,47 +1067,6 @@ f x loop -traverseConcurrently - :: (HasPantryConfig env, Traversable t) - => (a -> RIO env b) -- ^ action to perform - -> t a -- ^ input values - -> RIO env (t b) -traverseConcurrently f t0 = do - cnt <- view $ pantryConfigL.to pcConnectionCount - traverseConcurrentlyWith cnt f t0 - --- | Like 'traverse', but does things on --- up to N separate threads at once. -traverseConcurrentlyWith - :: (MonadUnliftIO m, Traversable t) - => Int -- ^ concurrent workers - -> (a -> m b) -- ^ action to perform - -> t a -- ^ input values - -> m (t b) -traverseConcurrentlyWith count f t0 = do - (queue, t1) <- atomically $ do - queueDList <- newTVar id - t1 <- for t0 $ \x -> do - res <- newEmptyTMVar - modifyTVar queueDList (. ((x, res):)) - pure $ atomically $ takeTMVar res - dlist <- readTVar queueDList - queue <- newTVar $ dlist [] - pure (queue, t1) - - replicateConcurrently_ count $ - fix $ \loop -> join $ atomically $ do - toProcess <- readTVar queue - case toProcess of - [] -> pure (pure ()) - ((x, res):rest) -> do - writeTVar queue rest - pure $ do - y <- f x - atomically $ putTMVar res y - loop - sequence t1 - -- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. -- -- @since 0.1.0.0 @@ -1202,6 +1186,7 @@ in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) Right (rsl, sloc) -> do (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cacheSL cachePL + logDebug $ fromString $ show rsl (packages, completed, unused) <- addAndCompletePackagesToSnapshot rawLoc @@ -1337,12 +1322,14 @@ cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Map RawPackageLocationImmutable PackageLocationImmutable -> RawPackageLocationImmutable - -> RIO env PackageLocationImmutable + -> RIO env (Maybe PackageLocationImmutable) cachedSnapshotCompletePackageLocation cachePackages rpli = do let xs = Map.lookup rpli cachePackages case xs of - Nothing -> completePackageLocation rpli - Just x -> pure x + Nothing -> do + cpl <- completePackageLocation rpli + pure $ if cplHasCabalFile cpl then Just (cplComplete cpl) else Nothing + Just x -> pure $ Just x -- | Add more packages to a snapshot completing their locations if needed -- @@ -1372,18 +1359,23 @@ -> RawPackageLocationImmutable -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) addPackage (ps, completed) rawLoc = do - complLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc - let PackageIdentifier name _ = packageLocationIdent complLoc - p = (name, SnapshotPackage - { spLocation = complLoc - , spFlags = Map.findWithDefault mempty name flags - , spHidden = Map.findWithDefault False name hiddens - , spGhcOptions = Map.findWithDefault [] name options - }) - completed' = if toRawPLI complLoc == rawLoc - then completed - else CompletedPLI rawLoc complLoc:completed - pure (p:ps, completed') + mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc + case mcomplLoc of + Nothing -> do + warnMissingCabalFile rawLoc + pure (ps, completed) + Just complLoc -> do + let PackageIdentifier name _ = packageLocationIdent complLoc + p = (name, SnapshotPackage + { spLocation = complLoc + , spFlags = Map.findWithDefault mempty name flags + , spHidden = Map.findWithDefault False name hiddens + , spGhcOptions = Map.findWithDefault [] name options + }) + completed' = if toRawPLI complLoc == rawLoc + then completed + else CompletedPLI rawLoc complLoc:completed + pure (p:ps, completed') (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs --- a/src/Pantry/Archive.hs +++ b/src/Pantry/Archive.hs @@ -136,9 +136,9 @@ _ -> do case loc of ALUrl url -> do - logWarn $ "Using archive from " <> display url <> " without a specified cryptographic hash" - logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size - logWarn "For security and reproducibility, please add a hash and file size to your configuration" + -- Only debug level, let lock files solve this + logDebug $ "Using archive from " <> display url <> " without a specified cryptographic hash" + logDebug $ "Cached hash is " <> display sha <> ", file size " <> display size ALFilePath _ -> pure () fmap (sha, size,) <$> loadFromCache tid Just sha' @@ -146,15 +146,14 @@ case msize of Nothing -> do case loc of - ALUrl url -> do - logWarn $ "Archive from " <> display url <> " does not specify a size" - logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size + -- Only debug level, let lock files solve this + ALUrl url -> logDebug $ "Archive from " <> display url <> " does not specify a size" ALFilePath _ -> pure () fmap (sha, size,) <$> loadFromCache tid Just size' | size == size' -> fmap (sha, size,) <$> loadFromCache tid | otherwise -> do - + -- This is an actual warning, since we have a concrete mismatch logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" logWarn "Please verify that your configuration provides the correct size" loop rest diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs --- a/src/Pantry/Types.hs +++ b/src/Pantry/Types.hs @@ -108,6 +108,7 @@ , SnapshotCacheHash (..) , getGlobalHintsFile , bsToBlobKey + , warnMissingCabalFile ) where import RIO @@ -2298,3 +2299,15 @@ bsToBlobKey :: ByteString -> BlobKey bsToBlobKey bs = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + +-- | Warn if the package uses 'PCHpack'. +-- +-- @since 0.4.0.0 +warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () +warnMissingCabalFile loc = + logWarn $ + "DEPRECATED: The package at " <> display loc <> + " does not include a cabal file.\n" <> + "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" <> + "This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" <> + "Support for this workflow will be removed in the future.\n" diff --git a/test/Pantry/CasaSpec.hs b/test/Pantry/CasaSpec.hs --- a/test/Pantry/CasaSpec.hs +++ b/test/Pantry/CasaSpec.hs @@ -17,7 +17,7 @@ "completePackageLocation: unliftio_0_2_12" (shouldReturn (runPantryAppClean - (completePackageLocation (argsRlpi unliftio_0_2_12))) + (cplComplete <$> completePackageLocation (argsRlpi unliftio_0_2_12))) ( PLIHackage (PackageIdentifier { pkgName = "unliftio"