diff options
| -rw-r--r-- | gnu/local.mk | 8 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-openssh-test-fix.patch | 46 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-procps-compat.patch | 45 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-pyyaml-compat.patch | 41 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-relax-dependencies.patch | 28 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch | 90 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-sphinx-import.patch | 12 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-template-haskell-2.17.patch | 69 | ||||
| -rw-r--r-- | gnu/packages/patches/ganeti-template-haskell-2.18.patch | 179 | ||||
| -rw-r--r-- | gnu/packages/virtualization.scm | 342 |
10 files changed, 153 insertions, 707 deletions
diff --git a/gnu/local.mk b/gnu/local.mk index 11274bda54..422e6ed6ba 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -1364,16 +1364,8 @@ dist_patch_DATA = \ %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-openssh-test-fix.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-sphinx-import.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-openssh-test-fix.patch b/gnu/packages/patches/ganeti-openssh-test-fix.patch deleted file mode 100644 index ed7a498fab..0000000000 --- a/gnu/packages/patches/ganeti-openssh-test-fix.patch +++ /dev/null @@ -1,46 +0,0 @@ -From 8a06656acf8f6e3dfa907bea77bd57a469a8d3fb Mon Sep 17 00:00:00 2001 -From: codefritzel <pascal-pf@hotmail.de> -Date: Thu, 11 Jul 2024 23:10:41 +0200 -Subject: replace dsa with rsa in TestUpdateSshRoot - -DSA to be deactivated in OpenSSH from 2025. Since version 7.0 dsa is -marked as deprecated. - -The TestUpdateSshRoot uses DSA, which will fail in the future with newer -OpenSSH versions. - -fixes #1752 - -Signed-off-by: codefritzel <pascal-pf@hotmail.de> - -diff --git a/test/py/ganeti.tools.prepare_node_join_unittest.py b/test/py/ganeti.tools.prepare_node_join_unittest.py -index fe7efdf8c..fe029b8f2 100755 ---- a/test/py/ganeti.tools.prepare_node_join_unittest.py -+++ b/test/py/ganeti.tools.prepare_node_join_unittest.py -@@ -229,20 +229,20 @@ class TestUpdateSshRoot(unittest.TestCase): - def testUpdate(self): - data = { - constants.SSHS_SSH_ROOT_KEY: [ -- (constants.SSHK_DSA, "privatedsa", "ssh-dss pubdsa"), -+ (constants.SSHK_RSA, "privatersa", "ssh-rsa pubrsa"), - ], -- constants.SSHS_SSH_KEY_TYPE: "dsa", -- constants.SSHS_SSH_KEY_BITS: 1024, -+ constants.SSHS_SSH_KEY_TYPE: "rsa", -+ constants.SSHS_SSH_KEY_BITS: 2048, - } - - prepare_node_join.UpdateSshRoot(data, False, - _homedir_fn=self._GetHomeDir) - self.assertEqual(os.listdir(self.tmpdir), [".ssh"]) - self.assertEqual(sorted(os.listdir(self.sshdir)), -- sorted(["authorized_keys", "id_dsa", "id_dsa.pub"])) -- self.assertTrue(utils.ReadFile(utils.PathJoin(self.sshdir, "id_dsa")) -+ sorted(["authorized_keys", "id_rsa", "id_rsa.pub"])) -+ self.assertTrue(utils.ReadFile(utils.PathJoin(self.sshdir, "id_rsa")) - is not None) -- pub_key = utils.ReadFile(utils.PathJoin(self.sshdir, "id_dsa.pub")) -+ pub_key = utils.ReadFile(utils.PathJoin(self.sshdir, "id_rsa.pub")) - self.assertTrue(pub_key is not None) - self.assertEqual(utils.ReadFile(utils.PathJoin(self.sshdir, - "authorized_keys")), diff --git a/gnu/packages/patches/ganeti-procps-compat.patch b/gnu/packages/patches/ganeti-procps-compat.patch deleted file mode 100644 index a2145274cb..0000000000 --- a/gnu/packages/patches/ganeti-procps-compat.patch +++ /dev/null @@ -1,45 +0,0 @@ -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-pyyaml-compat.patch b/gnu/packages/patches/ganeti-pyyaml-compat.patch deleted file mode 100644 index 2f74e48a82..0000000000 --- a/gnu/packages/patches/ganeti-pyyaml-compat.patch +++ /dev/null @@ -1,41 +0,0 @@ -Add Loader argument to 'yaml.load' invocations as required by PyYAML 6.0. - -Submitted upstream: - - https://github.com/ganeti/ganeti/pull/1668 - -diff --git a/qa/qa_utils.py b/qa/qa_utils.py -index da485df48..27428e685 100644 ---- a/qa/qa_utils.py -+++ b/qa/qa_utils.py -@@ -450,7 +450,7 @@ def GetObjectInfo(infocmd): - master = qa_config.GetMasterNode() - cmdline = utils.ShellQuoteArgs(infocmd) - info_out = GetCommandOutput(master.primary, cmdline) -- return yaml.load(info_out) -+ return yaml.load(info_out, Loader=yaml.SafeLoader) - - - def UploadFile(node, src): -diff --git a/test/py/ganeti.cli_unittest.py b/test/py/ganeti.cli_unittest.py -index 9cc980afa..242aac9fd 100755 ---- a/test/py/ganeti.cli_unittest.py -+++ b/test/py/ganeti.cli_unittest.py -@@ -1141,14 +1141,15 @@ class TestFormatPolicyInfo(unittest.TestCase): - self._RenameDictItem(minmax, key, keyparts[0]) - self.assertTrue(constants.IPOLICY_DTS in parsed) - parsed[constants.IPOLICY_DTS] = yaml.load("[%s]" % -- parsed[constants.IPOLICY_DTS]) -+ parsed[constants.IPOLICY_DTS], -+ Loader=yaml.SafeLoader) - - @staticmethod - def _PrintAndParsePolicy(custom, effective, iscluster): - formatted = cli.FormatPolicyInfo(custom, effective, iscluster) - buf = StringIO() - cli._SerializeGenericInfo(buf, formatted, 0) -- return yaml.load(buf.getvalue()) -+ return yaml.load(buf.getvalue(), Loader=yaml.SafeLoader) - - def _PrintAndCheckParsed(self, policy): - parsed = self._PrintAndParsePolicy(policy, NotImplemented, True) diff --git a/gnu/packages/patches/ganeti-relax-dependencies.patch b/gnu/packages/patches/ganeti-relax-dependencies.patch deleted file mode 100644 index 521b410b9e..0000000000 --- a/gnu/packages/patches/ganeti-relax-dependencies.patch +++ /dev/null @@ -1,28 +0,0 @@ -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 deleted file mode 100644 index ba34c0bdd6..0000000000 --- a/gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch +++ /dev/null @@ -1,90 +0,0 @@ -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-sphinx-import.patch b/gnu/packages/patches/ganeti-sphinx-import.patch deleted file mode 100644 index 8c6e7b5be5..0000000000 --- a/gnu/packages/patches/ganeti-sphinx-import.patch +++ /dev/null @@ -1,12 +0,0 @@ -diff --git a/lib/build/sphinx_ext.py b/lib/build/sphinx_ext.py -index ca8b8216e..017f52343 100644 ---- a/lib/build/sphinx_ext.py -+++ b/lib/build/sphinx_ext.py -@@ -45,7 +45,6 @@ import docutils.parsers.rst - from docutils.parsers.rst import Directive - - import sphinx.errors --import sphinx.util.compat - import sphinx.roles - import sphinx.addnodes - diff --git a/gnu/packages/patches/ganeti-template-haskell-2.17.patch b/gnu/packages/patches/ganeti-template-haskell-2.17.patch deleted file mode 100644 index be5948bb96..0000000000 --- a/gnu/packages/patches/ganeti-template-haskell-2.17.patch +++ /dev/null @@ -1,69 +0,0 @@ -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 deleted file mode 100644 index e7be869636..0000000000 --- a/gnu/packages/patches/ganeti-template-haskell-2.18.patch +++ /dev/null @@ -1,179 +0,0 @@ -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 f4621fdac7..49a7b24fa4 100644 --- a/gnu/packages/virtualization.scm +++ b/gnu/packages/virtualization.scm @@ -835,36 +835,26 @@ firmware blobs. You can (define-public ganeti (package (name "ganeti") - (version "3.0.2") + (version "3.1.0") (source (origin (method git-fetch) (uri (git-reference (url "https://github.com/ganeti/ganeti") (commit (string-append "v" version)))) (sha256 - (base32 "1xw7rm0k411aj0a4hrxz9drn7827bihp6bwizbapfx8k4c3125k4")) + (base32 "19pqlxcdhqr4nfd94x4grmdppna52wvhkjspry972w0w6glnyf6l")) (file-name (git-file-name name version)) (patches (search-patches "ganeti-shepherd-support.patch" "ganeti-shepherd-master-failover.patch" "ganeti-haskell-pythondir.patch" - "ganeti-pyyaml-compat.patch" - "ganeti-procps-compat.patch" "ganeti-disable-version-symlinks.patch" - "ganeti-lens-compat.patch" - "ganeti-openssh-test-fix.patch" - "ganeti-template-haskell-2.17.patch" - "ganeti-template-haskell-2.18.patch" - "ganeti-reorder-arbitrary-definitions.patch" - "ganeti-relax-dependencies.patch" - "ganeti-sphinx-import.patch")))) + "ganeti-lens-compat.patch")))) (build-system gnu-build-system) (arguments - `(#:imported-modules (,@%default-gnu-imported-modules - (guix build haskell-build-system) - (guix build python-build-system)) - #:modules (,@%default-gnu-modules - ((guix build haskell-build-system) #:prefix haskell:) - ((guix build python-build-system) #:select (site-packages)) + (list + #:imported-modules %pyproject-build-system-modules + #:modules `(,@%default-gnu-modules + ((guix build pyproject-build-system) #:select (site-packages)) (srfi srfi-1) (srfi srfi-26) (ice-9 match) @@ -877,55 +867,55 @@ firmware blobs. You can #:test-target "check-TESTS" #:configure-flags - (list "--localstatedir=/var" - "--sharedstatedir=/var" - "--sysconfdir=/etc" - "--enable-haskell-tests" + #~(list "--localstatedir=/var" + "--sharedstatedir=/var" + "--sysconfdir=/etc" + "--enable-haskell-tests" - ;; By default, the build system installs everything to versioned - ;; directories such as $libdir/3.0 and relies on a $libdir/default - ;; symlink pointed from /etc/ganeti/{lib,share} to actually function. - ;; This is done to accommodate installing multiple versions in - ;; parallel, but is of little use to us as Guix users can just - ;; roll back and forth. Thus, disable it for simplicity. - "--disable-version-links" + ;; By default, the build system installs everything to versioned + ;; directories such as $libdir/3.0 and relies on a $libdir/default + ;; symlink pointed from /etc/ganeti/{lib,share} to actually function. + ;; This is done to accommodate installing multiple versions in + ;; parallel, but is of little use to us as Guix users can just + ;; roll back and forth. Thus, disable it for simplicity. + "--disable-version-links" - ;; Ganeti can optionally take control over SSH host keys and - ;; distribute them to nodes as they are added, and also rotate keys - ;; with 'gnt-cluster renew-crypto --new-ssh-keys'. Thus it needs to - ;; know how to restart the SSH daemon. - "--with-sshd-restart-command='herd restart ssh-daemon'" + ;; Ganeti can optionally take control over SSH host keys and + ;; distribute them to nodes as they are added, and also rotate keys + ;; with 'gnt-cluster renew-crypto --new-ssh-keys'. Thus it needs to + ;; know how to restart the SSH daemon. + "--with-sshd-restart-command='herd restart ssh-daemon'" - ;; Look for OS definitions in this directory by default. It can - ;; be changed in the cluster configuration. - "--with-os-search-path=/run/current-system/profile/share/ganeti/os" + ;; Look for OS definitions in this directory by default. It can + ;; be changed in the cluster configuration. + "--with-os-search-path=/run/current-system/profile/share/ganeti/os" - ;; The default QEMU executable to use. We don't use the package - ;; here because this entry is stored in the cluster configuration. - (string-append "--with-kvm-path=/run/current-system/profile/bin/" - ,(system->qemu-target (%current-system)))) - #:phases - (modify-phases %standard-phases - (add-after 'unpack 'create-vcs-version - (lambda _ - ;; If we are building from a git checkout, we need to create a - ;; 'vcs-version' file manually because the build system does - ;; not have access to the git repository information. - (unless (file-exists? "vcs-version") - (call-with-output-file "vcs-version" - (lambda (port) - (format port "v~a~%" ,version)))))) - (add-after 'unpack 'patch-absolute-file-names - (lambda* (#:key inputs #:allow-other-keys) - (substitute* '("lib/utils/process.py" - "lib/utils/text.py" - "src/Ganeti/Constants.hs" - "src/Ganeti/HTools/CLI.hs" - "test/py/ganeti.config_unittest.py" - "test/py/ganeti.hooks_unittest.py" - "test/py/ganeti.utils.process_unittest.py" - "test/py/ganeti.utils.text_unittest.py" - "test/py/ganeti.utils.wrapper_unittest.py") + ;; The default QEMU executable to use. We don't use the package + ;; here because this entry is stored in the cluster configuration. + (string-append + "--with-kvm-path=/run/current-system/profile/bin/" + #$(system->qemu-target (%current-system)))) + #:phases + #~(modify-phases %standard-phases + (add-after 'unpack 'create-vcs-version + (lambda _ + ;; If we are building from a git checkout, we need to create a + ;; 'vcs-version' file manually because the build system does + ;; not have access to the git repository information. + (unless (file-exists? "vcs-version") + (call-with-output-file "vcs-version" + (cut format <> "v~a~%" #$version))))) + (add-after 'unpack 'patch-absolute-file-names + (lambda* (#:key inputs #:allow-other-keys) + (substitute* '("lib/utils/process.py" + "lib/utils/text.py" + "src/Ganeti/Constants.hs" + "src/Ganeti/HTools/CLI.hs" + "test/py/legacy/ganeti.config_unittest.py" + "test/py/legacy/ganeti.hooks_unittest.py" + "test/py/legacy/ganeti.utils.process_unittest.py" + "test/py/legacy/ganeti.utils.text_unittest.py" + "test/py/legacy/ganeti.utils.wrapper_unittest.py") (("/bin/sh") (search-input-file inputs "/bin/sh")) (("/bin/bash") (search-input-file inputs "/bin/bash")) (("/usr/bin/env") (search-input-file inputs "/bin/env")) @@ -959,76 +949,50 @@ firmware blobs. You can (("\\$SPHINX --version 2>&1") "$SPHINX --version 2>&1 \ | sed 's/.sphinx-build-real/sphinx-build/g'")))) - - ;; The build system invokes Cabal and GHC, which do not work with - ;; GHC_PACKAGE_PATH: <https://github.com/haskell/cabal/issues/3728>. - ;; Tweak the build system to do roughly what haskell-build-system does. - (add-before 'configure 'configure-haskell - (assoc-ref haskell:%standard-phases 'setup-compiler)) - (add-after 'configure 'do-not-use-GHC_PACKAGE_PATH - (lambda _ - (unsetenv "GHC_PACKAGE_PATH") - (substitute* "Makefile" - (("\\$\\(CABAL\\)") - "$(CABAL) --package-db=../package.conf.d") - (("\\$\\(GHC\\)") - "$(GHC) -package-db=../package.conf.d")))) - (add-after 'configure 'make-ghc-use-shared-libraries - (lambda _ - (substitute* "Makefile" + (add-after 'configure 'make-ghc-use-shared-libraries + (lambda _ + (substitute* "Makefile" (("HFLAGS =") "HFLAGS = -dynamic -fPIC")))) - (add-after 'configure 'fix-installation-directories - (lambda _ - (substitute* "Makefile" - ;; Do not attempt to create /var during install. - (("\\$\\(DESTDIR\\)\\$\\{localstatedir\\}") - "$(DESTDIR)${prefix}${localstatedir}") - ;; Similarly, do not attempt to install the sample ifup scripts - ;; to /etc/ganeti. - (("\\$\\(DESTDIR\\)\\$\\(ifupdir\\)") - "$(DESTDIR)${prefix}$(ifupdir)")))) - (add-before 'build 'adjust-tests - (lambda _ - ;; Disable tests that can not run. Do it early to prevent - ;; touching the Makefile later and triggering a needless rebuild. - (substitute* "Makefile" - ;; These tests expect the presence of a 'root' user (via - ;; ganeti/runtime.py), which fails in the build environment. - (("test/py/ganeti\\.asyncnotifier_unittest\\.py") "") - (("test/py/ganeti\\.backend_unittest\\.py") "") - (("test/py/ganeti\\.daemon_unittest\\.py") "") - (("test/py/ganeti\\.hypervisor\\.hv_kvm_unittest\\.py") "") - (("test/py/ganeti\\.tools\\.ensure_dirs_unittest\\.py") "") - (("test/py/ganeti\\.utils\\.io_unittest-runasroot\\.py") "") - ;; Tracked at: https://github.com/ganeti/ganeti/issues/1752 - (("test/py/ganeti\\.ssh_unittest\\.py") "") - ;; Disable the bash_completion test, as it requires the full - ;; bash instead of bash-minimal. - (("test/py/bash_completion\\.bash") - "") - ;; This test requires networking. - (("test/py/import-export_unittest\\.bash") - "")) - (substitute* "test/hs/Test/Ganeti/OpCodes.hs" - ;; Some serdes failure, tracked at: - ;; https://github.com/ganeti/ganeti/issues/1753 - ((", 'case_py_compat_types") "")))) - (add-after 'build 'build-bash-completions - (lambda _ - (setenv "PYTHONPATH" ".") - (invoke "./autotools/build-bash-completion") - (unsetenv "PYTHONPATH"))) - (add-before 'check 'pre-check - (lambda* (#:key inputs #:allow-other-keys) - ;; Set TZDIR so that time zones are found. + (add-after 'configure 'fix-installation-directories + (lambda _ + (substitute* "Makefile" + ;; Do not attempt to create /var during install. + (("\\$\\(DESTDIR\\)\\$\\{localstatedir\\}") + "$(DESTDIR)${prefix}${localstatedir}") + ;; Similarly, do not attempt to install the sample ifup scripts + ;; to /etc/ganeti. + (("\\$\\(DESTDIR\\)\\$\\(ifupdir\\)") + "$(DESTDIR)${prefix}$(ifupdir)")))) + (add-before 'build 'adjust-tests + (lambda _ + ;; Disable tests that can not run. Do it early to prevent + ;; touching the Makefile later and triggering a needless rebuild. + (substitute* "Makefile" + ;; Disable the bash_completion test, as it requires the full + ;; bash instead of bash-minimal. + (("test/py/legacy/bash_completion\\.bash") + "") + ;; XXX: Unclear why this test fails. + ;; Generating hspace simulation data for hinfo and hbal... + ;; FAIL to build test files + (("test/hs/offline-test\\.sh") + "")))) + (add-after 'build 'build-bash-completions + (lambda _ + (setenv "PYTHONPATH" ".") + (invoke "./autotools/build-bash-completion") + (unsetenv "PYTHONPATH"))) + (add-before 'check 'pre-check + (lambda* (#:key inputs #:allow-other-keys) + ;; Set TZDIR so that time zones are found. (setenv "TZDIR" (search-input-directory inputs "share/zoneinfo")) - (substitute* "test/py/ganeti.utils.process_unittest.py" - ;; This test attempts to run an executable with - ;; RunCmd(..., reset_env=True), which fails because the default - ;; PATH from Constants.hs does not exist in the build container. - ((".*def testResetEnv.*" all) - (string-append " @unittest.skipIf(True, " + (substitute* "test/py/legacy/ganeti.utils.process_unittest.py" + ;; This test attempts to run an executable with + ;; RunCmd(..., reset_env=True), which fails because the default + ;; PATH from Constants.hs does not exist in the build container. + ((".*def testResetEnv.*" all) + (string-append " @unittest.skipIf(True, " "\"cannot reset env in the build container\")\n" all)) @@ -1039,37 +1003,35 @@ firmware blobs. You can "\"testPidFile fails in the build container\")\n" all))) - ;; XXX: Why are these links not added automatically. - (with-directory-excursion "test/hs" - (for-each (lambda (file) - (symlink "../../src/htools" file)) + ;; XXX: Why are these links not added automatically. + (with-directory-excursion "test/hs" + (for-each (cut symlink "../../src/htools" <>) '("hspace" "hscan" "hinfo" "hbal" "hroller" "hcheck" "hail" "hsqueeze"))))) - (add-after 'install 'install-bash-completions - (lambda* (#:key outputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (compdir (string-append out "/etc/bash_completion.d"))) - (mkdir-p compdir) - (copy-file "doc/examples/bash_completion" - (string-append compdir "/ganeti")) - ;; The one file contains completions for many different - ;; executables. Create symlinks for found completions. - (with-directory-excursion compdir - (for-each - (lambda (prog) (symlink "ganeti" prog)) - (call-with-input-file "ganeti" - (lambda (port) - (let loop ((line (read-line port)) - (progs '())) - (if (eof-object? line) - progs - (if (string-prefix? "complete" line) - (loop (read-line port) - ;; Extract "prog" from lines of the form: - ;; "complete -F _prog -o filenames prog". - ;; Note that 'burnin' is listed with the - ;; absolute file name, which is why we - ;; run everything through 'basename'. + (add-after 'install 'install-bash-completions + (lambda _ + (let ((compdir (string-append #$output "/etc/bash_completion.d"))) + (mkdir-p compdir) + (copy-file "doc/examples/bash_completion" + (string-append compdir "/ganeti")) + ;; The one file contains completions for many different + ;; executables. Create symlinks for found completions. + (with-directory-excursion compdir + (for-each + (lambda (prog) (symlink "ganeti" prog)) + (call-with-input-file "ganeti" + (lambda (port) + (let loop ((line (read-line port)) + (progs '())) + (if (eof-object? line) + progs + (if (string-prefix? "complete" line) + (loop (read-line port) + ;; Extract "prog" from lines of the form: + ;; "complete -F _prog -o filenames prog". + ;; Note that 'burnin' is listed with the + ;; absolute file name, which is why we + ;; run everything through 'basename'. (match (string-split line #\ ) ((commands ... prog) (cons (basename prog) progs)))) @@ -1102,41 +1064,39 @@ firmware blobs. You can (not (symbolic-link? file)) (not (shell-script? file)))) - (for-each (lambda (file) - (wrap-program file - `("GUIX_PYTHONPATH" ":" prefix - (,PYTHONPATH)))) - (append-map (cut find-files <> wrap?) + (for-each (cut wrap-program <> + `("GUIX_PYTHONPATH" ":" prefix + (,PYTHONPATH))) + (append-map (cut find-files <> wrap?) (list (string-append lib "/ganeti") sbin))))))))) (native-inputs - `(("haskell" ,ghc) - ("cabal" ,cabal-install) - ("m4" ,m4) - - ;; These inputs are necessary to bootstrap the package, because we - ;; have patched the build system. - ("autoconf" ,autoconf) - ("automake" ,automake) + (list ghc + cabal-install + m4 + ;; These inputs are necessary to bootstrap the package, because we + ;; have patched the build system. + autoconf + automake - ;; For the documentation. - ("python-docutils" ,python-docutils-0.19) - ("sphinx" ,python-sphinx) - ("pandoc" ,pandoc) - ("dot" ,graphviz) + ;; For the documentation. + python-docutils-0.19 + python-sphinx + pandoc + graphviz - ;; Test dependencies. - ("fakeroot" ,fakeroot) - ("ghc-temporary" ,ghc-temporary) - ("ghc-test-framework" ,ghc-test-framework) - ("ghc-test-framework-hunit" ,ghc-test-framework-hunit) - ("ghc-test-framework-quickcheck2" ,ghc-test-framework-quickcheck2) - ("python-mock" ,python-mock) - ("python-pyyaml" ,python-pyyaml) - ("openssh" ,openssh) - ("procps" ,procps) - ("shelltestrunner" ,shelltestrunner) - ("tzdata" ,tzdata-for-tests))) + ;; Test dependencies. + fakeroot + ghc-temporary + ghc-test-framework + ghc-test-framework-hunit + ghc-test-framework-quickcheck2 + python-mock + python-pyyaml + openssh + procps + shelltestrunner + tzdata-for-tests)) (inputs (list bash-minimal iputils ;for 'arping' @@ -1148,6 +1108,7 @@ firmware blobs. You can qemu-minimal ;for qemu-img ghc-attoparsec ghc-base64-bytestring + ghc-case-insensitive ghc-cryptonite ghc-curl ghc-hinotify @@ -1155,10 +1116,13 @@ firmware blobs. You can ghc-json ghc-lens ghc-lifted-base + ghc-monad-control ghc-network ghc-old-time - ghc-psqueue + ghc-parallel ghc-regex-pcre + ghc-random + ghc-transformers-base ghc-utf8-string ghc-zlib ;; For the optional metadata daemon. |