Add revision information to plan.json

fgaz · fgaz · commit 538a5aac30e5 · 2025-06-08T16:24:20.000+02:00
Closes #6186
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
@@ -66,6 +66,8 @@ import Distribution.Verbosity
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
+import Control.Monad ((<=<))
+
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Lazy as BS
 import qualified Data.Map as Map
@@ -259,13 +261,24 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
               J.object
                 [ "type" J..= J.String "remote-repo"
                 , "uri" J..= J.String (show (remoteRepoURI repoRemote))
+                , -- The x-revision field is a feature of remote repos,
+                  -- so we only output it for remote/secure repos, in the "repo" object.
+                  "pkg-revision" J..= J.Number (elaboratedPackageToRevision elab)
                 ]
             RepoSecure{..} ->
               J.object
                 [ "type" J..= J.String "secure-repo"
                 , "uri" J..= J.String (show (remoteRepoURI repoRemote))
+                , "pkg-revision" J..= J.Number (elaboratedPackageToRevision elab)
                 ]
 
+        elaboratedPackageToRevision :: ElaboratedConfiguredPackage -> Double
+        elaboratedPackageToRevision =
+          fromMaybe 0
+            . (readMaybe <=< lookup "x-revision")
+            . PD.customFieldsPD
+            . elabPkgDescription
+
         sourceRepoToJ :: SourceRepoMaybe -> J.Value
         sourceRepoToJ SourceRepositoryPackage{..} =
           J.object $
diff --git a/cabal-testsuite/PackageTests/PlanJson/cabal.test.hs b/cabal-testsuite/PackageTests/PlanJson/cabal.test.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Distribution.Types.PackageName (PackageName, mkPackageName)
+import Test.Cabal.Prelude
+import Test.Cabal.DecodeShowBuildInfo
+import Test.Cabal.Plan
+import Data.Maybe (mapMaybe)
+
+getRevisionFor :: PackageName -> InstallItem -> Maybe Revision
+getRevisionFor pkgName (AConfiguredGlobal configuredGlobal)
+  | configuredGlobalPackageName configuredGlobal == pkgName =
+      Just $ pkgRevision $ repo $ configuredGlobalPkgSrc configuredGlobal
+getRevisionFor _ _ = Nothing
+
+main = cabalTest $ do
+  withRemoteRepo "repo" $ do
+    cabal "build" ["--dry-run", "all"]
+    withPlan $ do
+      Just plan <- testPlan `fmap` getTestEnv
+      let [fooRev] = mapMaybe (getRevisionFor $ mkPackageName "foo") $ planInstallPlan plan
+      let [barRev] = mapMaybe (getRevisionFor $ mkPackageName "bar") $ planInstallPlan plan
+      assertEqual "revision of package foo" fooRev $ Revision 0
+      assertEqual "revision of package bar" barRev $ Revision 1337
diff --git a/cabal-testsuite/PackageTests/PlanJson/pkg.cabal b/cabal-testsuite/PackageTests/PlanJson/pkg.cabal
@@ -0,0 +1,8 @@
+name: pkg
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.2
+
+executable my-exe
+  main-is: Main.hs
+  build-depends: base, foo, bar
diff --git a/cabal-testsuite/PackageTests/PlanJson/repo/bar-1.0/bar.cabal b/cabal-testsuite/PackageTests/PlanJson/repo/bar-1.0/bar.cabal
@@ -0,0 +1,6 @@
+name: bar
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.2
+
+library
diff --git a/cabal-testsuite/PackageTests/PlanJson/repo/foo-1.0/foo.cabal b/cabal-testsuite/PackageTests/PlanJson/repo/foo-1.0/foo.cabal
@@ -0,0 +1,6 @@
+name: foo
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.2
+
+library
diff --git a/cabal-testsuite/src/Test/Cabal/Plan.hs b/cabal-testsuite/src/Test/Cabal/Plan.hs
@@ -1,9 +1,16 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 -- | Utilities for understanding @plan.json@.
 module Test.Cabal.Plan (
-    Plan,
+    Plan(..),
     DistDirOrBinFile(..),
+    InstallItem(..),
+    ConfiguredGlobal(..),
+    Revision(..),
+    PkgSrc(..),
+    Repo(..),
     planDistDir,
     buildInfoFile,
 ) where
@@ -16,6 +23,7 @@ import qualified Data.Text as Text
 import Data.Aeson
 import Data.Aeson.Types
 import Control.Monad
+import GHC.Generics (Generic)
 
 -- TODO: index this
 data Plan = Plan { planInstallPlan :: [InstallItem] }
@@ -32,15 +40,33 @@ data ConfiguredInplace = ConfiguredInplace
     { configuredInplaceDistDir       :: FilePath
     , configuredInplaceBuildInfo     :: Maybe FilePath
     , configuredInplacePackageName   :: PackageName
-    , configuredInplaceComponentName :: Maybe ComponentName }
+    , configuredInplaceComponentName :: Maybe ComponentName
+    , configuredInplacePkgSrc        :: PkgSrc }
   deriving Show
 
 data ConfiguredGlobal = ConfiguredGlobal
     { configuredGlobalBinFile       :: Maybe FilePath
     , configuredGlobalPackageName   :: PackageName
-    , configuredGlobalComponentName :: Maybe ComponentName }
+    , configuredGlobalComponentName :: Maybe ComponentName
+    , configuredGlobalPkgSrc        :: PkgSrc }
   deriving Show
 
+newtype Revision = Revision Int
+  deriving (Show, Eq, FromJSON)
+
+-- | A stripped-down 'Distribution.Client.Types.PackageLocation.PackageLocation'
+data PkgSrc
+    = RepoTar { repo :: Repo }
+    | PkgSrcOther
+  deriving (Show, Generic)
+
+-- | A stripped-down 'Distribution.Client.Types.Repo.Repo', plus revision information
+data Repo
+    = LocalRepoNoIndex
+    | RemoteRepo { pkgRevision :: Revision }
+    | SecureRepo { pkgRevision :: Revision }
+  deriving (Show, Generic)
+
 instance FromJSON Plan where
     parseJSON (Object v) = fmap Plan (v .: "install-plan")
     parseJSON invalid = typeMismatch "Plan" invalid
@@ -66,15 +92,17 @@ instance FromJSON ConfiguredInplace where
         build_info <- v .:? "build-info"
         pkg_name <- v .: "pkg-name"
         component_name <- v .:? "component-name"
-        return (ConfiguredInplace dist_dir build_info pkg_name component_name)
+        pkg_src <- v .: "pkg-src"
+        return (ConfiguredInplace dist_dir build_info pkg_name component_name pkg_src)
     parseJSON invalid = typeMismatch "ConfiguredInplace" invalid
 
 instance FromJSON ConfiguredGlobal where
     parseJSON (Object v) = do
         bin_file <- v .:? "bin-file"
         pkg_name <- v .: "pkg-name"
         component_name <- v .:? "component-name"
-        return (ConfiguredGlobal bin_file pkg_name component_name)
+        pkg_src <- v .: "pkg-src"
+        return (ConfiguredGlobal bin_file pkg_name component_name pkg_src)
     parseJSON invalid = typeMismatch "ConfiguredGlobal" invalid
 
 instance FromJSON PackageName where
@@ -89,6 +117,21 @@ instance FromJSON ComponentName where
       where s = Text.unpack t
     parseJSON invalid = typeMismatch "ComponentName" invalid
 
+instance FromJSON PkgSrc where
+    parseJSON (Object v) = do
+        t <- v .: "type"
+        case t :: String of
+            "repo-tar" -> RepoTar <$> v .: "repo"
+            _ -> return PkgSrcOther
+    parseJSON invalid = typeMismatch "PkgSrc" invalid
+
+instance FromJSON Repo where
+  parseJSON = genericParseJSON defaultOptions
+    { constructorTagModifier = camelTo2 '-'
+    , fieldLabelModifier = camelTo2 '-'
+    , sumEncoding = TaggedObject "type" ""
+    }
+
 data DistDirOrBinFile = DistDir FilePath | BinFile FilePath
 
 planDistDir :: Plan -> PackageName -> ComponentName -> DistDirOrBinFile
diff --git a/changelog.d/pr-10980 b/changelog.d/pr-10980
@@ -0,0 +1,9 @@
+synopsis: Added revision information to `plan.json`
+packages: cabal-install
+prs: #10980
+issues: #6186
+
+description: {
+  The contents of `x-revision` `.cabal` fields are now available in `plan.json`.
+  They are located under `pkg-src.repo.pkg-revision`, have type `Number`, and are only available for `repo-tar` repositories of type `remote-repo` or `secure-repo`.
+}
