diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,12 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.14.1 + +- Keep `arch-hs-sync check --depcheck` suggestions on Hackage's non-deprecated preferred versions while still reading exact deprecated cabal files for current reverse dependency checks + +- Treat `Cabal-syntax` as part of GHC libraries + ## 0.14 - Teach `arch-hs-sync check` to report all newer non-deprecated Hackage versions diff --git a/arch-hs.cabal b/arch-hs.cabal --- a/arch-hs.cabal +++ b/arch-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: arch-hs -version: 0.14 +version: 0.14.1 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing diff --git a/data/NAME_PRESET.json b/data/NAME_PRESET.json --- a/data/NAME_PRESET.json +++ b/data/NAME_PRESET.json @@ -10,7 +10,6 @@ "cabal-install": "cabal-install", "cabal-fmt": "cabal-fmt", "cabal-plan": "cabal-plan", - "haskell-cabal-syntax": "Cabal-syntax", "cbor-tool": "cbor-tool", "cgrep": "cgrep", "clash-ghc": "clash-ghc", diff --git a/rdepcheck/Check.hs b/rdepcheck/Check.hs --- a/rdepcheck/Check.hs +++ b/rdepcheck/Check.hs @@ -13,7 +13,7 @@ check :: Members [ ExtraEnv, - HackageEnv, + RawHackageEnv, KnownGHCVersion, FlagAssignmentsEnv, Trace, diff --git a/rdepcheck/Main.hs b/rdepcheck/Main.hs --- a/rdepcheck/Main.hs +++ b/rdepcheck/Main.hs @@ -29,7 +29,7 @@ printInfo "You assigned flags:" putDoc $ prettyFlagAssignments optFlags <> line - hackage <- loadHackageDBFromOptions optHackage + hackage <- loadRawHackageDBFromOptions optHackage extra <- loadExtraDBFromOptions optExtraDB printInfo "Start running..." @@ -48,10 +48,10 @@ exitFailure runCheck :: - HackageDB -> + RawHackageDB -> ExtraDB -> FlagAssignments -> - Sem '[HackageEnv, ExtraEnv, FlagAssignmentsEnv, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> + Sem '[RawHackageEnv, ExtraEnv, FlagAssignmentsEnv, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) runCheck extra flags manager = runFinal diff --git a/src/Distribution/ArchHs/Exception.hs b/src/Distribution/ArchHs/Exception.hs --- a/src/Distribution/ArchHs/Exception.hs +++ b/src/Distribution/ArchHs/Exception.hs @@ -39,6 +39,7 @@ | NetworkException ClientError | HackageUploadFailed Int String | VersionNoParse String + | CabalNoParse PackageName Version instance Show MyException where show (PkgNotFound name) = "Unable to find \"" <> unPackageName (toHackageName name) <> "\"" @@ -51,6 +52,7 @@ <> show status <> if null message then "" else " " <> message show (VersionNoParse v) = "String \"" <> v <> "\" can not be parsed to Cabal version" + show (CabalNoParse name version) = "Unable to parse \"" <> unPackageName name <> "\" " <> prettyShow version <> " cabal file" -- | Catch 'CE.IOException' and print it. printHandledIOException :: IO () -> IO () diff --git a/src/Distribution/ArchHs/Hackage.hs b/src/Distribution/ArchHs/Hackage.hs --- a/src/Distribution/ArchHs/Hackage.hs +++ b/src/Distribution/ArchHs/Hackage.hs @@ -9,15 +9,19 @@ module Distribution.ArchHs.Hackage ( lookupHackagePath, loadHackageDB, + loadRawHackageDB, + loadHackageDBs, insertDB, parseCabalFile, getLatestCabal, getNewerVersions, getCabal, + getCabalIncludingDeprecated, getPackageFlag, traverseHackage, getLatestSHA256, HackageDB, + RawHackageDB, ) where @@ -33,9 +37,13 @@ import Distribution.ArchHs.Utils (getPkgName, getPkgVersion) import Distribution.Hackage.DB (HackageDB, VersionData (VersionData, cabalFile), readTarball, tarballHashes) import Distribution.Hackage.DB.Path (cabalStateDir) +import qualified Distribution.Hackage.DB.Parsed as Parsed +import qualified Distribution.Hackage.DB.Unparsed as Unparsed import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, listDirectory) +type RawHackageDB = Unparsed.HackageDB + -- | Look up hackage tarball path from Cabal's package index cache. -- Preferred to the newest @01-index.tar@, whereas fallback to the newest @00-index.tar@. lookupHackagePath :: IO FilePath @@ -80,6 +88,16 @@ loadHackageDB :: FilePath -> IO HackageDB loadHackageDB = readTarball Nothing +-- | Read the Hackage index tarball without applying preferred-version ranges. +loadRawHackageDB :: FilePath -> IO RawHackageDB +loadRawHackageDB = Unparsed.readTarball Nothing + +-- | Read Hackage once and expose both preferred and raw views. +loadHackageDBs :: FilePath -> IO (HackageDB, RawHackageDB) +loadHackageDBs path = do + raw <- loadRawHackageDB path + pure (Parsed.parseDB raw, raw) + -- | Insert a 'GenericPackageDescription' into 'HackageDB'. insertDB :: GenericPackageDescription -> HackageDB -> HackageDB insertDB cabal = Map.insert name packageData @@ -132,6 +150,23 @@ case Map.lookup name db of (Just m) -> case Map.lookup version m of Just vdata -> return $ vdata & cabalFile + Nothing -> throw $ VersionNotFound name version + Nothing -> throw $ PkgNotFound name + +-- | Get a specific cabal file without applying preferred-version ranges. +-- +-- Upgrade candidates should use 'getCabal' so deprecated Hackage versions stay +-- hidden. Reverse dependency checks need this exact lookup because [extra] can +-- temporarily contain a version that Hackage later deprecated. +getCabalIncludingDeprecated :: Members [RawHackageEnv, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription +getCabalIncludingDeprecated name version = do + db <- ask @RawHackageDB + case Map.lookup name db of + Just packageData -> case Map.lookup version (Unparsed.versions packageData) of + Just vdata -> + case parseGenericPackageDescriptionMaybe (Unparsed.cabalFile vdata) of + Just cabal -> pure cabal + Nothing -> throw $ CabalNoParse name version Nothing -> throw $ VersionNotFound name version Nothing -> throw $ PkgNotFound name diff --git a/src/Distribution/ArchHs/Local.hs b/src/Distribution/ArchHs/Local.hs --- a/src/Distribution/ArchHs/Local.hs +++ b/src/Distribution/ArchHs/Local.hs @@ -48,6 +48,7 @@ "binary", "bytestring", "Cabal", + "Cabal-syntax", "containers", "deepseq", "directory", diff --git a/src/Distribution/ArchHs/Options.hs b/src/Distribution/ArchHs/Options.hs --- a/src/Distribution/ArchHs/Options.hs +++ b/src/Distribution/ArchHs/Options.hs @@ -145,29 +145,38 @@ ----------------------------------------------------------------------------- -- | Parsed options for loading 'HackageDB' -newtype HackageDBOptions = HackageDBOptions - { loadHackageDBFromOptions :: IO HackageDB +data HackageDBOptions = HackageDBOptions + { loadHackageDBFromOptions :: IO HackageDB, + loadRawHackageDBFromOptions :: IO RawHackageDB, + loadHackageDBsFromOptions :: IO (HackageDB, RawHackageDB) } -- | CLI options parser that reads a string option @hackage@. hackageDBOptionsParser :: Parser HackageDBOptions hackageDBOptionsParser = - HackageDBOptions - <$> fmap - ( \s -> - do - hackagePath <- if null s then lookupHackagePath else pure s - printInfo $ "Loading hackage from" <+> pretty hackagePath - loadHackageDB hackagePath - ) - ( strOption $ - long "hackage" - <> metavar "PATH" - <> short 'h' - <> help "Path to hackage index tarball" - <> showDefault - <> value "" + mkHackageDBOptions + <$> strOption + ( long "hackage" + <> metavar "PATH" + <> short 'h' + <> help "Path to hackage index tarball" + <> showDefault + <> value "" ) + where + resolvePath s = if null s then lookupHackagePath else pure s + + withHackagePath s load = do + hackagePath <- resolvePath s + printInfo $ "Loading hackage from" <+> pretty hackagePath + load hackagePath + + mkHackageDBOptions s = + HackageDBOptions + { loadHackageDBFromOptions = withHackagePath s loadHackageDB, + loadRawHackageDBFromOptions = withHackagePath s loadRawHackageDB, + loadHackageDBsFromOptions = withHackagePath s loadHackageDBs + } ----------------------------------------------------------------------------- diff --git a/src/Distribution/ArchHs/RDepCheck.hs b/src/Distribution/ArchHs/RDepCheck.hs --- a/src/Distribution/ArchHs/RDepCheck.hs +++ b/src/Distribution/ArchHs/RDepCheck.hs @@ -56,7 +56,7 @@ reverseDependencyRanges :: Members [ ExtraEnv, - HackageEnv, + RawHackageEnv, KnownGHCVersion, FlagAssignmentsEnv, Trace, @@ -75,7 +75,7 @@ reverseDependencyRangesWithSkips :: Members [ ExtraEnv, - HackageEnv, + RawHackageEnv, KnownGHCVersion, FlagAssignmentsEnv, Trace, @@ -112,7 +112,7 @@ forM reverseDeps $ \(PkgDesc {..}, src) -> do eCabal <- try @MyException $ - getCabal (toHackageName _name) =<< case simpleParsec _version of + getCabalIncludingDeprecated (toHackageName _name) =<< case simpleParsec _version of Just v -> pure v _ -> throw $ VersionNoParse _version case eCabal of diff --git a/src/Distribution/ArchHs/Types.hs b/src/Distribution/ArchHs/Types.hs --- a/src/Distribution/ArchHs/Types.hs +++ b/src/Distribution/ArchHs/Types.hs @@ -23,6 +23,7 @@ ArchLinuxVersion, ExtraDB, HackageEnv, + RawHackageEnv, ExtraEnv, FlagAssignmentsEnv, KnownGHCVersion, @@ -44,7 +45,8 @@ import Data.Map.Strict (Map) import Distribution.ArchHs.Internal.Prelude -import Distribution.Hackage.DB (HackageDB) +import qualified Distribution.Hackage.DB as Hackage +import qualified Distribution.Hackage.DB.Unparsed as RawHackage import Lens.Micro.TH (makeLenses) -- | A list of 'PackageName' @@ -103,7 +105,13 @@ type ExtraDB = Map ArchLinuxName PkgDesc -- | Reader effect of 'HackageDB' -type HackageEnv = Reader HackageDB +type HackageEnv = Reader Hackage.HackageDB + +-- | Reader effect of the unfiltered Hackage database. +-- +-- This keeps exact package versions available even when Hackage's +-- preferred-version range marks them as deprecated. +type RawHackageEnv = Reader RawHackage.HackageDB -- | Reader effect of 'ExtraDB' type ExtraEnv = Reader ExtraDB diff --git a/sync/Check.hs b/sync/Check.hs --- a/sync/Check.hs +++ b/sync/Check.hs @@ -28,6 +28,7 @@ check :: Members [ HackageEnv, + RawHackageEnv, ExtraEnv, KnownGHCVersion, FlagAssignmentsEnv, @@ -73,6 +74,7 @@ Members [ ExtraEnv, HackageEnv, + RawHackageEnv, KnownGHCVersion, FlagAssignmentsEnv, Trace, diff --git a/sync/Main.hs b/sync/Main.hs --- a/sync/Main.hs +++ b/sync/Main.hs @@ -29,17 +29,19 @@ runCheck :: ExtraDB -> HackageDB -> + RawHackageDB -> Bool -> Bool -> Bool -> IO (Either MyException ()) -runCheck extra hackage includeGHC runDepCheck verbose = +runCheck extra hackage rawHackage includeGHC runDepCheck verbose = ( runFinal . embedToFinal @IO . errorToIOFinal . evalState (Map.empty :: Map.Map PackageName [VersionRange]) . ignoreTrace . runReader (Map.empty :: FlagAssignments) + . runReader rawHackage . runReader hackage . runReader extra ) @@ -93,8 +95,13 @@ runSubmit extra hackage manager token optOutput optUpload & printAppResult Check CommonOptions {..} CheckOptions {..} -> do extra <- loadExtraDBFromOptions optExtraDB - hackage <- loadHackageDBFromOptions optHackage - runCheck extra hackage optShowGHCLibs optDepCheck optVerbose & printAppResult + (hackage, rawHackage) <- + if optDepCheck + then loadHackageDBsFromOptions optHackage + else do + hackage <- loadHackageDBFromOptions optHackage + pure (hackage, Map.empty) + runCheck extra hackage rawHackage optShowGHCLibs optDepCheck optVerbose & printAppResult List ExtraDBOptions {..} ListOptions {..} -> do extra <- loadExtraDBFromOptions putStrLn $ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,16 +4,22 @@ module Main (main) where import Control.Monad (forM_) +import qualified Data.ByteString.Char8 as B8 import Data.List (isPrefixOf, sortOn) import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe, mapMaybe) import Diff (inRange) import Distribution.ArchHs.Exception import Distribution.ArchHs.ExtraDB (defaultExtraDBPath, loadExtraDB) +import Distribution.ArchHs.Hackage (getCabalIncludingDeprecated, getNewerVersions) import Distribution.ArchHs.Name (isGHCLibs, isHaskellPackage, toHackageName) import Distribution.ArchHs.Types +import qualified Distribution.Hackage.DB.Parsed as Hackage +import qualified Distribution.Hackage.DB.Unparsed as RawHackage +import Distribution.Package (packageName, packageVersion) +import Distribution.PackageDescription (GenericPackageDescription, packageDescription) import Distribution.Parsec (simpleParsec) -import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName) import Distribution.Types.Version (Version) import Distribution.Types.VersionRange (VersionRange, anyVersion) import Polysemy (run) @@ -74,6 +80,22 @@ result -> expectationFailure $ "expected VersionNoParse, got: " <> show result + describe "Hackage preferred-version handling" $ do + it "does not report masked versions as newer candidates" $ do + let (preferred, _, name, version100, version101) = maskedHackageDBs + assertGetNewerVersions preferred name version100 [] + assertGetNewerVersions preferred name version101 [] + + it "can still load an exact masked cabal from the raw Hackage DB" $ do + let (_, raw, name, _, version101) = maskedHackageDBs + case runGetCabalIncludingDeprecated raw name version101 of + Right cabal -> do + let desc = packageDescription cabal + packageName desc `shouldBe` name + packageVersion desc `shouldBe` version101 + Left err -> + expectationFailure $ "expected masked cabal lookup to succeed, got: " <> show err + loadLiveExtraDB :: IO ExtraDB loadLiveExtraDB = do exists <- doesFileExist defaultExtraDBPath @@ -143,6 +165,60 @@ . runError @MyException . runReader extra $ inRange (name, range) + +maskedHackageDBs :: (Hackage.HackageDB, RawHackage.HackageDB, PackageName, Version, Version) +maskedHackageDBs = + (Hackage.parseDB raw, raw, name, version100, version101) + where + name = mkPackageName "masked" + version100 = parseVersion "1.0.0" + version101 = parseVersion "1.0.1" + raw = + Map.singleton + name + ( RawHackage.PackageData + (B8.pack "masked <1.0.1 || >1.0.1") + ( Map.fromList + [ (version100, RawHackage.VersionData (cabalFile "1.0.0") (B8.pack "{}")), + (version101, RawHackage.VersionData (cabalFile "1.0.1") (B8.pack "{}")) + ] + ) + ) + + cabalFile version = + B8.pack $ + unlines + [ "cabal-version: 1.12", + "name: masked", + "version: " <> version, + "build-type: Simple" + ] + +parseVersion :: String -> Version +parseVersion raw = + case simpleParsec raw of + Just version -> version + Nothing -> error $ "test fixture version does not parse: " <> raw + +runGetNewerVersions :: Hackage.HackageDB -> PackageName -> Version -> Either MyException [Version] +runGetNewerVersions hackage name version = + run + . runError @MyException + . runReader hackage + $ getNewerVersions name version + +assertGetNewerVersions :: Hackage.HackageDB -> PackageName -> Version -> [Version] -> Expectation +assertGetNewerVersions hackage name version expected = + case runGetNewerVersions hackage name version of + Right actual -> actual `shouldBe` expected + Left err -> expectationFailure $ "expected newer versions, got: " <> show err + +runGetCabalIncludingDeprecated :: RawHackage.HackageDB -> PackageName -> Version -> Either MyException GenericPackageDescription +runGetCabalIncludingDeprecated hackage name version = + run + . runError @MyException + . runReader hackage + $ getCabalIncludingDeprecated name version skip :: String -> IO a skip reason = pendingWith reason >> error "unreachable"