Merge pull request #119 from input-output-hk/nm/remove-force-version

neilmayhew · web-flow · commit 94644ae59ed0 · 2026-02-19T22:02:48.000-07:00
Remove version-forcing and use `0.cabal` whenever it exists
diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs
@@ -242,15 +242,13 @@ makeMetadataFile outputDir packageVersions = traced "writing metadata" $ do
     PreparedPackageVersion
       { pkgId = PackageIdentifier{pkgName, pkgVersion}
       , pkgTimestamp
-      , pkgVersionForce
       , pkgVersionSource
       } =
       Aeson.object
         ( [ "pkg-name" Aeson..= pkgName
           , "pkg-version" Aeson..= pkgVersion
           , "url" Aeson..= packageVersionSourceToUri pkgVersionSource
           ]
-            ++ ["forced-version" Aeson..= True | pkgVersionForce]
             ++ (case pkgTimestamp of Nothing -> []; Just t -> ["timestamp" Aeson..= t])
         )
 
diff --git a/app/Foliage/CmdImportIndex.hs b/app/Foliage/CmdImportIndex.hs
@@ -66,7 +66,6 @@ importIndex f (Tar.Next e es) m =
                       , packageVersionTimestamp = Just time
                       , packageVersionRevisions = []
                       , packageVersionDeprecations = []
-                      , packageVersionForce = False
                       }
               -- Existing package, new revision
               go (Just sm) = do
diff --git a/app/Foliage/CmdRewriteVersion.hs b/app/Foliage/CmdRewriteVersion.hs
@@ -0,0 +1,35 @@
+module Foliage.CmdRewriteVersion (cmdRewriteVersion) where
+
+import Data.Maybe (fromMaybe)
+import Distribution.Compat.Lens (Lens', (&), (.~), (^.))
+import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty (prettyShow)
+import Distribution.Simple.PackageDescription (readGenericPackageDescription)
+import Distribution.Types.Lens (GenericPackageDescription, package, packageDescription, pkgVersion)
+import Distribution.Types.Version (Version)
+import Distribution.Utils.Path (makeSymbolicPath)
+import Distribution.Verbosity (normal)
+
+cmdRewriteVersion
+  :: String
+  -- ^ new version
+  -> FilePath
+  -- ^ path to @.cabal@ file
+  -> IO ()
+cmdRewriteVersion versionStr cabalPath = do
+  let
+    version = fromMaybe (error $ "invalid package version: " <> versionStr) $ simpleParsec versionStr
+    gpdVersion :: Lens' GenericPackageDescription Version
+    gpdVersion = packageDescription . package . pkgVersion
+  gpd <- readGenericPackageDescription normal Nothing (makeSymbolicPath cabalPath)
+  putStrLn . unwords $
+    [ "Rewriting the version from"
+    , prettyShow (gpd ^. gpdVersion)
+    , "to"
+    , prettyShow version
+    , "in"
+    , cabalPath
+    ]
+  writeGenericPackageDescription cabalPath $
+    gpd & gpdVersion .~ version
diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs
@@ -10,7 +10,6 @@ module Foliage.Meta (
   packageVersionSource,
   packageVersionRevisions,
   packageVersionDeprecations,
-  packageVersionForce,
   PackageVersionSpec (PackageVersionSpec),
   readPackageVersionSpec,
   writePackageVersionSpec,
@@ -132,8 +131,6 @@ data PackageVersionSpec = PackageVersionSpec
   -- ^ revisions
   , packageVersionDeprecations :: [DeprecationSpec]
   -- ^ deprecations
-  , packageVersionForce :: Bool
-  -- ^ force version
   }
   deriving (Show, Eq, Generic)
   deriving anyclass (Binary, Hashable, NFData)
@@ -149,8 +146,6 @@ sourceMetaCodec =
       .= packageVersionRevisions
     <*> Toml.list deprecationMetaCodec "deprecations"
       .= packageVersionDeprecations
-    <*> withDefault False (Toml.bool "force-version")
-      .= packageVersionForce
 
 readPackageVersionSpec :: FilePath -> IO PackageVersionSpec
 readPackageVersionSpec = Toml.decodeFile sourceMetaCodec
diff --git a/app/Foliage/Options.hs b/app/Foliage/Options.hs
@@ -26,6 +26,7 @@ data Command
   = CreateKeys FilePath
   | Build BuildOptions
   | ImportIndex ImportIndexOptions
+  | RewriteVersion String FilePath
 
 parseCommand :: IO Command
 parseCommand =
@@ -40,10 +41,12 @@ parseCommand =
 
 optionsParser :: Parser Command
 optionsParser =
-  hsubparser $
-    command "create-keys" (info createKeysCommand (progDesc "Create TUF keys"))
-      <> command "build" (info buildCommand (progDesc "Build repository"))
-      <> command "import-index" (info importIndexCommand (progDesc "Import from Hackage index"))
+  hsubparser . mconcat $
+    [ command "create-keys" (info createKeysCommand (progDesc "Create TUF keys"))
+    , command "build" (info buildCommand (progDesc "Build repository"))
+    , command "import-index" (info importIndexCommand (progDesc "Import from Hackage index"))
+    , command "rewrite-version" (info rewriteVersionCommand (progDesc "Rewrite the version in a Cabal file"))
+    ]
 
 data SignOptions
   = SignOptsSignWithKeys FilePath
@@ -192,6 +195,12 @@ importIndexCommand =
             )
       )
 
+rewriteVersionCommand :: Parser Command
+rewriteVersionCommand =
+  RewriteVersion
+    <$> strArgument (metavar "VERSION" <> help "New version")
+    <*> strArgument (metavar "FILE" <> help "Cabal file")
+
 toUppercase :: [Char] -> String
 toUppercase s =
   maybe "" (uncurry (:) . first Char.toUpper) (uncons s)
diff --git a/app/Foliage/PreparePackageVersion.hs b/app/Foliage/PreparePackageVersion.hs
@@ -7,7 +7,6 @@ module Foliage.PreparePackageVersion (
     pkgId,
     pkgTimestamp,
     pkgVersionSource,
-    pkgVersionForce,
     pkgVersionIsDeprecated,
     pkgVersionDeprecationChanges,
     pkgDesc,
@@ -45,7 +44,6 @@ data PreparedPackageVersion = PreparedPackageVersion
   { pkgId :: PackageId
   , pkgTimestamp :: Maybe UTCTime
   , pkgVersionSource :: PackageVersionSource
-  , pkgVersionForce :: Bool
   , pkgVersionIsDeprecated :: Bool
   , pkgVersionDeprecationChanges :: [(UTCTime, Bool)]
   , pkgDesc :: GenericPackageDescription
@@ -208,7 +206,6 @@ preparePackageVersion inputDir metaFile = do
       { pkgId
       , pkgTimestamp = packageVersionTimestamp pkgSpec
       , pkgVersionSource = packageVersionSource pkgSpec
-      , pkgVersionForce = packageVersionForce pkgSpec
       , pkgVersionDeprecationChanges
       , pkgVersionIsDeprecated
       , pkgDesc
diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs
@@ -5,7 +5,7 @@
 
 module Foliage.PrepareSource where
 
-import Control.Monad (unless, when)
+import Control.Monad (when)
 import Data.ByteString qualified as BS
 import Data.Foldable (for_)
 import Development.Shake
@@ -44,7 +44,7 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
   run :: PrepareSourceRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath)
   run (PrepareSourceRule pkgId pkgMeta) _old mode = do
     let PackageIdentifier{pkgName, pkgVersion} = pkgId
-    let PackageVersionSpec{packageVersionSource, packageVersionForce} = pkgMeta
+    let PackageVersionSpec{packageVersionSource} = pkgMeta
     let srcDir = cacheDir </> unPackageName pkgName </> prettyShow pkgVersion
 
     case mode of
@@ -81,12 +81,10 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
             let patch = patchesDir </> patchfile
             cmd_ Shell (Cwd srcDir) (FileStdin patch) "patch -p1"
 
-        when packageVersionForce $ do
-          let revisionZero = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "revisions" </> "0" <.> "cabal"
-          hasRevisionZero <- doesFileExist revisionZero
-          unless hasRevisionZero $
-            error $
-              "force-version requires a modified Cabal file in " ++ revisionZero
+        let revisionZero = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "revisions" </> "0" <.> "cabal"
+        hasRevisionZero <- doesFileExist revisionZero
+
+        when hasRevisionZero $ do
           let cabalFilePath = srcDir </> unPackageName pkgName <.> "cabal"
           putInfo $ "Copying revision 0 of cabal file to " ++ cabalFilePath
           copyFileChanged revisionZero cabalFilePath
diff --git a/app/Foliage/UpdateCabalFile.hs b/app/Foliage/UpdateCabalFile.hs
diff --git a/app/Main.hs b/app/Main.hs
@@ -5,6 +5,7 @@ module Main where
 import Foliage.CmdBuild
 import Foliage.CmdCreateKeys
 import Foliage.CmdImportIndex
+import Foliage.CmdRewriteVersion
 import Foliage.Options
 import Main.Utf8 (withUtf8)
 
@@ -15,3 +16,4 @@ main = withUtf8 $ do
     CreateKeys path -> cmdCreateKeys path
     Build buildOpts -> cmdBuild buildOpts
     ImportIndex importIndexOpts -> cmdImportIndex importIndexOpts
+    RewriteVersion version file -> cmdRewriteVersion version file
diff --git a/foliage.cabal b/foliage.cabal
@@ -26,6 +26,7 @@ executable foliage
         Foliage.CmdBuild
         Foliage.CmdCreateKeys
         Foliage.CmdImportIndex
+        Foliage.CmdRewriteVersion
         Foliage.FetchURL
         Foliage.HackageSecurity
         Foliage.Meta
@@ -37,7 +38,6 @@ executable foliage
         Foliage.PrepareSdist
         Foliage.Shake
         Foliage.Time
-        Foliage.UpdateCabalFile
         Foliage.Utils.Aeson
         Foliage.Utils.GitHub
         Network.URI.Orphans
diff --git a/tests/Tests.hs b/tests/Tests.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 
-import Codec.Archive.Tar.Entry (entryTime)
+import Codec.Archive.Tar.Entry (GenEntry (entryContent, entryTime), GenEntryContent (NormalFile))
+import Data.ByteString.Lazy qualified as BL
 import Foliage.Tests.Tar
 import Foliage.Tests.Utils
 import System.Directory
@@ -20,7 +21,7 @@ main = do
             step "Building repository"
             callCommand "foliage build"
 
-            step "Running checks"
+            step "Running top-level checks"
             doesDirectoryExist "_keys" @? "_keys does not exist"
             doesFileExist "_repo/01-index.tar" @? "01-index.tar does not exist"
             doesFileExist "_repo/01-index.tar.gz" @? "01-index.tar.gz does not exist"
@@ -29,21 +30,31 @@ main = do
             doesFileExist "_repo/snapshot.json" @? "snapshot.json does not exist"
             doesFileExist "_repo/timestamp.json" @? "timestamp.json does not exist"
 
+            step "Running package checks"
+            upstream <- BL.readFile "tarballs/pkg-a/pkg-a.cabal"
+            revised <- BL.readFile "_sources/pkg-a/2.3.4.5/revisions/0.cabal"
+            revised /= upstream @? "revisions/0.cabal is the same as upstream"
+            rev0 <- BL.readFile "_repo/package/pkg-a-2.3.4.5/revision/0.cabal"
+            rev0 @?= revised
+            built <- BL.readFile "_repo/package/pkg-a-2.3.4.5/pkg-a.cabal"
+            built @?= revised
+
+            step "Running tarball checks"
             withTarball "_repo/01-index.tar" $ \TarballAccessFn{lookupEntry} -> do
               lookupEntry "pkg-a/2.3.4.5/pkg-a.cabal" >>= \case
                 Nothing ->
                   assertFailure "entry for pkg-a-2.3.4.5 is missing"
                 Just entry -> do
                   entryTime entry @?= 1648534790
+                  entryContent entry @?= NormalFile revised (BL.length revised)
       , ---
         testCaseSteps "accepts --no-signatures" $ \step ->
           inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do
             step "Building repository"
             callCommand "foliage build --no-signatures"
 
             step "Running checks"
-            doesExist <- doesDirectoryExist "_keys"
-            doesExist @?= False
+            not <$> doesDirectoryExist "_keys" @? "_keys exists"
       , ---
         testCaseSteps "accepts --write-metadata" $ \step ->
           inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do
diff --git a/tests/fixtures/simple/_sources/pkg-a/2.3.4.5/revisions/0.cabal b/tests/fixtures/simple/_sources/pkg-a/2.3.4.5/revisions/0.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            pkg-a
+version:         2.3.4.5
+license:         NONE
+author:          andrea.bedini@tweag.io
+maintainer:      Andrea Bedini
+build-type:      Simple
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base ^>=4.17.2.0
+    hs-source-dirs:   src
+    default-language: Haskell2010
+    -- A comment to distinguish this revision from the original in the tarball

Original file line number	Diff line number	Diff line change
`@@ -66,7 +66,6 @@ importIndex f (Tar.Next e es) m =`
`66`	`66`	`, packageVersionTimestamp = Just time`
`67`	`67`	`, packageVersionRevisions = []`
`68`	`68`	`, packageVersionDeprecations = []`
`69`		`- , packageVersionForce = False`
`70`	`69`	`}`
`71`	`70`	`-- Existing package, new revision`
`72`	`71`	`go (Just sm) = do`