summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/local.mk6
-rw-r--r--gnu/packages/patches/ganeti-lens-compat.patch40
-rw-r--r--gnu/packages/patches/ganeti-procps-compat.patch45
-rw-r--r--gnu/packages/patches/ganeti-relax-dependencies.patch28
-rw-r--r--gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch90
-rw-r--r--gnu/packages/patches/ganeti-template-haskell-2.17.patch69
-rw-r--r--gnu/packages/patches/ganeti-template-haskell-2.18.patch179
-rw-r--r--gnu/packages/virtualization.scm8
8 files changed, 464 insertions, 1 deletions
diff --git a/gnu/local.mk b/gnu/local.mk
index 2b20606ca1..8a3c93c1c1 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -1178,9 +1178,15 @@ dist_patch_DATA = \
%D%/packages/patches/gajim-honour-GAJIM_PLUGIN_PATH.patch \
%D%/packages/patches/ganeti-disable-version-symlinks.patch \
%D%/packages/patches/ganeti-haskell-pythondir.patch \
+ %D%/packages/patches/ganeti-lens-compat.patch \
%D%/packages/patches/ganeti-pyyaml-compat.patch \
+ %D%/packages/patches/ganeti-procps-compat.patch \
+ %D%/packages/patches/ganeti-reorder-arbitrary-definitions.patch \
+ %D%/packages/patches/ganeti-relax-dependencies.patch \
%D%/packages/patches/ganeti-shepherd-master-failover.patch \
%D%/packages/patches/ganeti-shepherd-support.patch \
+ %D%/packages/patches/ganeti-template-haskell-2.17.patch \
+ %D%/packages/patches/ganeti-template-haskell-2.18.patch \
%D%/packages/patches/gawk-shell.patch \
%D%/packages/patches/gcc-arm-bug-71399.patch \
%D%/packages/patches/gcc-arm-link-spec-fix.patch \
diff --git a/gnu/packages/patches/ganeti-lens-compat.patch b/gnu/packages/patches/ganeti-lens-compat.patch
new file mode 100644
index 0000000000..1b9108d78f
--- /dev/null
+++ b/gnu/packages/patches/ganeti-lens-compat.patch
@@ -0,0 +1,40 @@
+Fix building against Lens 5 by commenting out type signatures(!).
+
+Taken from upstream:
+
+ https://github.com/ganeti/ganeti/commit/5e30bad1bba63c9f6c782003ef2560f107a0ba24
+
+diff --git a/src/Ganeti/Network.hs b/src/Ganeti/Network.hs
+index 1cb6aa1ec..696c1cd1b 100644
+--- a/src/Ganeti/Network.hs
++++ b/src/Ganeti/Network.hs
+@@ -87,11 +87,11 @@ data PoolPart = PoolInstances | PoolExt
+ addressPoolIso :: Iso' AddressPool BA.BitArray
+ addressPoolIso = iso apReservations AddressPool
+
+-poolLens :: PoolPart -> Lens' Network (Maybe AddressPool)
++--poolLens :: PoolPart -> Lens' Network (Maybe AddressPool)
+ poolLens PoolInstances = networkReservationsL
+ poolLens PoolExt = networkExtReservationsL
+
+-poolArrayLens :: PoolPart -> Lens' Network (Maybe BA.BitArray)
++--poolArrayLens :: PoolPart -> Lens' Network (Maybe BA.BitArray)
+ poolArrayLens part = poolLens part . mapping addressPoolIso
+
+ netIpv4NumHosts :: Network -> Integer
+diff --git a/src/Ganeti/Utils/MultiMap.hs b/src/Ganeti/Utils/MultiMap.hs
+index d54da3ab0..279e9335a 100644
+--- a/src/Ganeti/Utils/MultiMap.hs
++++ b/src/Ganeti/Utils/MultiMap.hs
+@@ -91,7 +91,7 @@ multiMap :: (Ord k, Ord v) => M.Map k (S.Set v) -> MultiMap k v
+ multiMap = MultiMap . M.filter (not . S.null)
+
+ -- | A 'Lens' that allows to access a set under a given key in a multi-map.
+-multiMapL :: (Ord k, Ord v) => k -> Lens' (MultiMap k v) (S.Set v)
++--multiMapL :: (Ord k, Ord v) => k -> Lens' (MultiMap k v) (S.Set v)
+ multiMapL k f = fmap MultiMap
+ . at k (fmap (mfilter (not . S.null) . Just)
+ . f . fromMaybe S.empty)
+--
+2.41.0
+
diff --git a/gnu/packages/patches/ganeti-procps-compat.patch b/gnu/packages/patches/ganeti-procps-compat.patch
new file mode 100644
index 0000000000..a2145274cb
--- /dev/null
+++ b/gnu/packages/patches/ganeti-procps-compat.patch
@@ -0,0 +1,45 @@
+Fix compatibility with procps 4.
+
+Negative UIDs are no longer allowed. Use a very high one instead.
+
+Taken from upstream:
+
+ https://github.com/ganeti/ganeti/commit/9cd67e6a81c66ed326d68ea8c3241d14eea6550b
+
+diff --git a/test/py/ganeti.uidpool_unittest.py b/test/py/ganeti.uidpool_unittest.py
+index b2f5bc5cf2..2d9227cbf5 100755
+--- a/test/py/ganeti.uidpool_unittest.py
++++ b/test/py/ganeti.uidpool_unittest.py
+@@ -106,23 +106,24 @@ def testRequestUnusedUid(self):
+
+ # Check with a single, known unused user-id
+ #
+- # We use "-1" here, which is not a valid user-id, so it's
+- # guaranteed that it's unused.
+- uid = uidpool.RequestUnusedUid(set([-1]))
+- self.assertEqualValues(uid.GetUid(), -1)
++ # We use 2^30+42 here, which is a valid UID, but unlikely to be used on
++ # most systems (even as a subuid).
++ free_uid = 2**30 + 42
++ uid = uidpool.RequestUnusedUid(set([free_uid]))
++ self.assertEqualValues(uid.GetUid(), free_uid)
+
+ # Check uid-pool exhaustion
+ #
+- # uid "-1" is locked now, so RequestUnusedUid is expected to fail
++ # free_uid is locked now, so RequestUnusedUid is expected to fail
+ self.assertRaises(errors.LockError,
+ uidpool.RequestUnusedUid,
+- set([-1]))
++ set([free_uid]))
+
+ # Check unlocking
+ uid.Unlock()
+ # After unlocking, "-1" should be available again
+- uid = uidpool.RequestUnusedUid(set([-1]))
+- self.assertEqualValues(uid.GetUid(), -1)
++ uid = uidpool.RequestUnusedUid(set([free_uid]))
++ self.assertEqualValues(uid.GetUid(), free_uid)
+
+
+ if __name__ == "__main__":
diff --git a/gnu/packages/patches/ganeti-relax-dependencies.patch b/gnu/packages/patches/ganeti-relax-dependencies.patch
new file mode 100644
index 0000000000..521b410b9e
--- /dev/null
+++ b/gnu/packages/patches/ganeti-relax-dependencies.patch
@@ -0,0 +1,28 @@
+Relax version constraints to work with Stackage LTS 19.
+
+Taken from upstream:
+
+ https://github.com/ganeti/ganeti/commit/4f8d61ea0101721eae1c6f43be8430d819e5e611
+
+diff --git a/cabal/ganeti.template.cabal b/cabal/ganeti.template.cabal
+index bb4ff8053..98491dd9f 100644
+--- a/cabal/ganeti.template.cabal
++++ b/cabal/ganeti.template.cabal
+@@ -63,14 +63,14 @@ library
+ , unix >= 2.5.1.0
+ , utf8-string >= 0.3.7
+
+- , attoparsec >= 0.10.1.1 && < 0.14
+- , base64-bytestring >= 1.0.0.1 && < 1.2
++ , attoparsec >= 0.10.1.1 && < 0.15
++ , base64-bytestring >= 1.0.0.1 && < 1.3
+ , case-insensitive >= 0.4.0.1 && < 1.3
+ , curl >= 1.3.7 && < 1.4
+ , hinotify >= 0.3.2 && < 0.5
+ , hslogger >= 1.1.4 && < 1.4
+ , json >= 0.5 && < 1.0
+- , lens >= 3.10 && < 5.0
++ , lens >= 3.10 && < 6.0
+ , lifted-base >= 0.2.0.3 && < 0.3
+ , monad-control >= 0.3.1.3 && < 1.1
+ , parallel >= 3.2.0.2 && < 3.3
diff --git a/gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch b/gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch
new file mode 100644
index 0000000000..ba34c0bdd6
--- /dev/null
+++ b/gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch
@@ -0,0 +1,90 @@
+Fix ordering of Arbitrary definitions for GHC 9 compatibility.
+
+Taken from upstream:
+
+ https://github.com/ganeti/ganeti/commit/feab8faa8fe055c89205497e4f277ae4c7b8caad
+
+diff --git a/test/hs/Test/Ganeti/Objects.hs b/test/hs/Test/Ganeti/Objects.hs
+index 97ceb36dca..8d80be9e80 100644
+--- a/test/hs/Test/Ganeti/Objects.hs
++++ b/test/hs/Test/Ganeti/Objects.hs
+@@ -93,8 +93,14 @@ instance Arbitrary (Container DataCollectorConfig) where
+ instance Arbitrary BS.ByteString where
+ arbitrary = genPrintableByteString
+
++instance Arbitrary a => Arbitrary (Private a) where
++ arbitrary = Private <$> arbitrary
++
+ $(genArbitrary ''PartialNDParams)
+
++instance Arbitrary (Container J.JSValue) where
++ arbitrary = return $ GenericContainer Map.empty
++
+ instance Arbitrary Node where
+ arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
+ <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
+@@ -297,10 +303,6 @@ genDisk = genDiskWithChildren 3
+ -- validation rules.
+ $(genArbitrary ''PartialISpecParams)
+
+--- | FIXME: This generates completely random data, without normal
+--- validation rules.
+-$(genArbitrary ''PartialIPolicy)
+-
+ $(genArbitrary ''FilledISpecParams)
+ $(genArbitrary ''MinMaxISpecs)
+ $(genArbitrary ''FilledIPolicy)
+@@ -309,6 +311,10 @@ $(genArbitrary ''FilledNDParams)
+ $(genArbitrary ''FilledNicParams)
+ $(genArbitrary ''FilledBeParams)
+
++-- | FIXME: This generates completely random data, without normal
++-- validation rules.
++$(genArbitrary ''PartialIPolicy)
++
+ -- | No real arbitrary instance for 'ClusterHvParams' yet.
+ instance Arbitrary ClusterHvParams where
+ arbitrary = return $ GenericContainer Map.empty
+@@ -331,18 +337,12 @@ instance Arbitrary OsParams where
+ instance Arbitrary Objects.ClusterOsParamsPrivate where
+ arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
+
+-instance Arbitrary a => Arbitrary (Private a) where
+- arbitrary = Private <$> arbitrary
+-
+ instance Arbitrary ClusterOsParams where
+ arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
+
+ instance Arbitrary ClusterBeParams where
+ arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
+
+-instance Arbitrary IAllocatorParams where
+- arbitrary = return $ GenericContainer Map.empty
+-
+ $(genArbitrary ''Cluster)
+
+ instance Arbitrary ConfigData where
+diff --git a/test/hs/Test/Ganeti/Query/Language.hs b/test/hs/Test/Ganeti/Query/Language.hs
+index 04fb8c3898..fa50196f00 100644
+--- a/test/hs/Test/Ganeti/Query/Language.hs
++++ b/test/hs/Test/Ganeti/Query/Language.hs
+@@ -59,6 +59,9 @@ import Ganeti.Query.Language
+ instance Arbitrary (Filter FilterField) where
+ arbitrary = genFilter
+
++instance Arbitrary FilterRegex where
++ arbitrary = genName >>= mkRegex -- a name should be a good regex
++
+ -- | Custom 'Filter' generator (top-level), which enforces a
+ -- (sane) limit on the depth of the generated filters.
+ genFilter :: Gen (Filter FilterField)
+@@ -97,9 +100,6 @@ $(genArbitrary ''QueryTypeLuxi)
+
+ $(genArbitrary ''ItemType)
+
+-instance Arbitrary FilterRegex where
+- arbitrary = genName >>= mkRegex -- a name should be a good regex
+-
+ $(genArbitrary ''ResultStatus)
+
+ $(genArbitrary ''FieldType)
diff --git a/gnu/packages/patches/ganeti-template-haskell-2.17.patch b/gnu/packages/patches/ganeti-template-haskell-2.17.patch
new file mode 100644
index 0000000000..be5948bb96
--- /dev/null
+++ b/gnu/packages/patches/ganeti-template-haskell-2.17.patch
@@ -0,0 +1,69 @@
+Handle GHC 9 changes in a backwards compatible manner.
+
+Taken from upstream:
+
+ https://github.com/ganeti/ganeti/commit/b279fa738fd5b30320584f79f4d2f0e894315aab
+
+diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
+index 818c11f84..9ab93d5e3 100644
+--- a/src/Ganeti/THH.hs
++++ b/src/Ganeti/THH.hs
+@@ -884,7 +884,7 @@ genLoadOpCode opdefs fn = do
+ ) $ zip mexps opdefs
+ defmatch = Match WildP (NormalB fails) []
+ cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
+- body = DoE [st, cst]
++ body = mkDoE [st, cst]
+ -- include "OP_ID" to the list of used keys
+ bodyAndOpId <- [| $(return body)
+ <* tell (mkUsedKeys . S.singleton . T.pack $ opidKey) |]
+@@ -1541,7 +1541,7 @@ loadExcConstructor inname sname fields = do
+ [x] -> BindS (ListP [VarP x])
+ _ -> BindS (TupP (map VarP f_names))
+ cval = appCons name $ map VarE f_names
+- return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
++ return $ mkDoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
+
+ {-| Generates the loadException function.
+
+diff --git a/src/Ganeti/THH/Compat.hs b/src/Ganeti/THH/Compat.hs
+index d29e30d18..1f51e49d7 100644
+--- a/src/Ganeti/THH/Compat.hs
++++ b/src/Ganeti/THH/Compat.hs
+@@ -40,9 +40,11 @@ module Ganeti.THH.Compat
+ , extractDataDConstructors
+ , myNotStrict
+ , nonUnaryTupE
++ , mkDoE
+ ) where
+
+ import Language.Haskell.TH
++import Language.Haskell.TH.Syntax
+
+ -- | Convert Names to DerivClauses
+ --
+@@ -61,7 +63,11 @@ derivesFromNames names = map ConT names
+ --
+ -- Handle TH 2.11 and 2.12 changes in a transparent manner using the pre-2.11
+ -- API.
++#if MIN_VERSION_template_haskell(2,17,0)
++gntDataD :: Cxt -> Name -> [TyVarBndr ()] -> [Con] -> [Name] -> Dec
++#else
+ gntDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
++#endif
+ gntDataD x y z a b =
+ #if MIN_VERSION_template_haskell(2,12,0)
+ DataD x y z Nothing a $ derivesFromNames b
+@@ -114,3 +120,12 @@ nonUnaryTupE es = TupE $ map Just es
+ #else
+ nonUnaryTupE es = TupE $ es
+ #endif
++
++-- | DoE is now qualified with an optional ModName
++mkDoE :: [Stmt] -> Exp
++mkDoE s =
++#if MIN_VERSION_template_haskell(2,17,0)
++ DoE Nothing s
++#else
++ DoE s
++#endif
diff --git a/gnu/packages/patches/ganeti-template-haskell-2.18.patch b/gnu/packages/patches/ganeti-template-haskell-2.18.patch
new file mode 100644
index 0000000000..e7be869636
--- /dev/null
+++ b/gnu/packages/patches/ganeti-template-haskell-2.18.patch
@@ -0,0 +1,179 @@
+Fix compatibility with Template Haskell 2.18 and GHC 9.2.
+
+
+diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs
+index 10d0426cd..d68bc7d5b 100644
+--- a/src/Ganeti/BasicTypes.hs
++++ b/src/Ganeti/BasicTypes.hs
+@@ -206,12 +206,12 @@ instance MonadTrans (ResultT a) where
+ instance (MonadIO m, Error a) => MonadIO (ResultT a m) where
+ liftIO = ResultT . liftIO
+ . liftM (either (failError . show) return)
+- . (try :: IO a -> IO (Either IOError a))
++ . (try :: IO α -> IO (Either IOError α))
+
+ instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where
+ liftBase = ResultT . liftBase
+ . liftM (either (failError . show) return)
+- . (try :: IO a -> IO (Either IOError a))
++ . (try :: IO α -> IO (Either IOError α))
+
+ instance (Error a) => MonadTransControl (ResultT a) where
+ #if MIN_VERSION_monad_control(1,0,0)
+diff --git a/src/Ganeti/Lens.hs b/src/Ganeti/Lens.hs
+index faa5900ed..747366e6a 100644
+--- a/src/Ganeti/Lens.hs
++++ b/src/Ganeti/Lens.hs
+@@ -93,14 +93,14 @@ makeCustomLenses' name lst = makeCustomLensesFiltered f name
+ -- Most often the @g@ functor is @(,) r@ and 'traverseOf2' is used to
+ -- traverse an effectful computation that also returns an additional output
+ -- value.
+-traverseOf2 :: Over (->) (Compose f g) s t a b
+- -> (a -> f (g b)) -> s -> f (g t)
++-- traverseOf2 :: Over (->) (Compose f g) s t a b
++-- -> (a -> f (g b)) -> s -> f (g t)
+ traverseOf2 k f = getCompose . traverseOf k (Compose . f)
+
+ -- | Traverses over a composition of a monad and a functor.
+ -- See 'traverseOf2'.
+-mapMOf2 :: Over (->) (Compose (WrappedMonad m) g) s t a b
+- -> (a -> m (g b)) -> s -> m (g t)
++-- mapMOf2 :: Over (->) (Compose (WrappedMonad m) g) s t a b
++-- -> (a -> m (g b)) -> s -> m (g t)
+ mapMOf2 k f = unwrapMonad . traverseOf2 k (WrapMonad . f)
+
+ -- | A helper lens over sets.
+diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
+index 9ab93d5e3..9a10a9a07 100644
+--- a/src/Ganeti/THH.hs
++++ b/src/Ganeti/THH.hs
+@@ -996,8 +996,8 @@ buildAccessor fnm fpfx rnm rpfx nm pfx field = do
+ f_body = AppE (VarE fpfx_name) $ VarE x
+ return $ [ SigD pfx_name $ ArrowT `AppT` ConT nm `AppT` ftype
+ , FunD pfx_name
+- [ Clause [ConP rnm [VarP x]] (NormalB r_body) []
+- , Clause [ConP fnm [VarP x]] (NormalB f_body) []
++ [ Clause [myConP rnm [VarP x]] (NormalB r_body) []
++ , Clause [myConP fnm [VarP x]] (NormalB f_body) []
+ ]]
+
+ -- | Build lense declartions for a field.
+@@ -1037,10 +1037,10 @@ buildLens (fnm, fdnm) (rnm, rdnm) nm pfx ar (field, i) = do
+ (ConE cdn)
+ $ zip [0..] vars
+ let setterE = LamE [VarP context, VarP var] $ CaseE (VarE context)
+- [ Match (ConP fnm [ConP fdnm . set (element i) WildP
++ [ Match (myConP fnm [myConP fdnm . set (element i) WildP
+ $ map VarP vars])
+ (body (not isSimple) fnm fdnm) []
+- , Match (ConP rnm [ConP rdnm . set (element i) WildP
++ , Match (myConP rnm [myConP rdnm . set (element i) WildP
+ $ map VarP vars])
+ (body False rnm rdnm) []
+ ]
+@@ -1098,9 +1098,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
+ $ JSON.showJSON $(varE x) |]
+ let rdjson = FunD 'JSON.readJSON [Clause [] (NormalB read_body) []]
+ shjson = FunD 'JSON.showJSON
+- [ Clause [ConP (mkName real_nm) [VarP x]]
++ [ Clause [myConP (mkName real_nm) [VarP x]]
+ (NormalB show_real_body) []
+- , Clause [ConP (mkName forth_nm) [VarP x]]
++ , Clause [myConP (mkName forth_nm) [VarP x]]
+ (NormalB show_forth_body) []
+ ]
+ instJSONdecl = gntInstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
+@@ -1121,9 +1121,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
+ (fromDictWKeys $(varE xs)) |]
+ todictx_r <- [| toDict $(varE x) |]
+ todictx_f <- [| ("forthcoming", JSON.JSBool True) : toDict $(varE x) |]
+- let todict = FunD 'toDict [ Clause [ConP (mkName real_nm) [VarP x]]
++ let todict = FunD 'toDict [ Clause [myConP (mkName real_nm) [VarP x]]
+ (NormalB todictx_r) []
+- , Clause [ConP (mkName forth_nm) [VarP x]]
++ , Clause [myConP (mkName forth_nm) [VarP x]]
+ (NormalB todictx_f) []
+ ]
+ fromdict = FunD 'fromDictWKeys [ Clause [VarP xs]
+@@ -1136,9 +1136,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
+ let forthPredDecls = [ SigD forthPredName
+ $ ArrowT `AppT` ConT name `AppT` ConT ''Bool
+ , FunD forthPredName
+- [ Clause [ConP (mkName real_nm) [WildP]]
++ [ Clause [myConP (mkName real_nm) [WildP]]
+ (NormalB $ ConE 'False) []
+- , Clause [ConP (mkName forth_nm) [WildP]]
++ , Clause [myConP (mkName forth_nm) [WildP]]
+ (NormalB $ ConE 'True) []
+ ]
+ ]
+@@ -1412,9 +1412,9 @@ savePParamField fvar field = do
+ normalexpr <- saveObjectField actualVal field
+ -- we have to construct the block here manually, because we can't
+ -- splice-in-splice
+- return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
++ return $ CaseE (VarE fvar) [ Match (myConP 'Nothing [])
+ (NormalB (ConE '[])) []
+- , Match (ConP 'Just [VarP actualVal])
++ , Match (myConP 'Just [VarP actualVal])
+ (NormalB normalexpr) []
+ ]
+
+@@ -1440,9 +1440,9 @@ fillParam sname field_pfx fields = do
+ -- due to apparent bugs in some older GHC versions, we need to add these
+ -- prefixes to avoid "binding shadows ..." errors
+ fbinds <- mapM (newName . ("f_" ++) . nameBase) fnames
+- let fConP = ConP name_f (map VarP fbinds)
++ let fConP = myConP name_f (map VarP fbinds)
+ pbinds <- mapM (newName . ("p_" ++) . nameBase) pnames
+- let pConP = ConP name_p (map VarP pbinds)
++ let pConP = myConP name_p (map VarP pbinds)
+ -- PartialParams instance --------
+ -- fillParams
+ let fromMaybeExp fn pn = AppE (AppE (VarE 'fromMaybe) (VarE fn)) (VarE pn)
+@@ -1462,7 +1462,7 @@ fillParam sname field_pfx fields = do
+ memptyClause = Clause [] (NormalB memptyExp) []
+ -- mappend
+ pbinds2 <- mapM (newName . ("p2_" ++) . nameBase) pnames
+- let pConP2 = ConP name_p (map VarP pbinds2)
++ let pConP2 = myConP name_p (map VarP pbinds2)
+ -- note the reversal of 'l' and 'r' in the call to <|>
+ -- as we want the result to be the rightmost value
+ let altExp = zipWith (\l r -> AppE (AppE (VarE '(<|>)) (VarE r)) (VarE l))
+@@ -1575,9 +1575,9 @@ genLoadExc tname sname opdefs = do
+ opdefs
+ -- the first function clause; we can't use [| |] due to TH
+ -- limitations, so we have to build the AST by hand
+- let clause1 = Clause [ConP 'JSON.JSArray
+- [ListP [ConP 'JSON.JSString [VarP exc_name],
+- VarP exc_args]]]
++ let clause1 = Clause [myConP 'JSON.JSArray
++ [ListP [myConP 'JSON.JSString [VarP exc_name],
++ VarP exc_args]]]
+ (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
+ (VarE exc_name))
+ (str_matches ++ [defmatch]))) []
+diff --git a/src/Ganeti/THH/Compat.hs b/src/Ganeti/THH/Compat.hs
+index 1f51e49d7..9b07c47ef 100644
+--- a/src/Ganeti/THH/Compat.hs
++++ b/src/Ganeti/THH/Compat.hs
+@@ -41,6 +41,7 @@ module Ganeti.THH.Compat
+ , myNotStrict
+ , nonUnaryTupE
+ , mkDoE
++ , myConP
+ ) where
+
+ import Language.Haskell.TH
+@@ -129,3 +130,11 @@ mkDoE s =
+ #else
+ DoE s
+ #endif
++
++-- | ConP is now qualified with an optional [Type].
++myConP :: Name -> [Pat] -> Pat
++myConP n patterns = ConP n
++#if MIN_VERSION_template_haskell(2,18,0)
++ []
++#endif
++ patterns
diff --git a/gnu/packages/virtualization.scm b/gnu/packages/virtualization.scm
index 4ae0049269..5c5225b694 100644
--- a/gnu/packages/virtualization.scm
+++ b/gnu/packages/virtualization.scm
@@ -668,7 +668,13 @@ firmware blobs. You can
"ganeti-shepherd-master-failover.patch"
"ganeti-haskell-pythondir.patch"
"ganeti-pyyaml-compat.patch"
- "ganeti-disable-version-symlinks.patch"))))
+ "ganeti-procps-compat.patch"
+ "ganeti-disable-version-symlinks.patch"
+ "ganeti-lens-compat.patch"
+ "ganeti-template-haskell-2.17.patch"
+ "ganeti-template-haskell-2.18.patch"
+ "ganeti-reorder-arbitrary-definitions.patch"
+ "ganeti-relax-dependencies.patch"))))
(build-system gnu-build-system)
(arguments
`(#:imported-modules (,@%gnu-build-system-modules
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-18 14:40:38 +0000