* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack"
@ 2023-02-03 16:19 Maxim Cournoyer
2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer
2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer
0 siblings, 2 replies; 31+ messages in thread
From: Maxim Cournoyer @ 2023-02-03 16:19 UTC (permalink / raw)
To: 61255; +Cc: Maxim Cournoyer
Hello Guix!
This series adds support for the RPM format to "guix pack", so that one can
generate an RPM archive via e.g. "guix pack -f rpm hello", and install it on
their favorite RPM-based GNU/Linux distribution. With the exception of the
payload compression, the generation of the archive is fully handled in Scheme,
which ended up being tricky, with the documentation about the RPM binary
format being scarce. Most of the problems encountered were figured out
stepping an 'rpm' command invocation in GDB, which felt a bit like reverse
engineering!
Anyway, the end result appears to work well and has few dependencies (compared
to using 'rpmbuild', as most other projects do), so I think it was worth the
effort.
Thanks!
Maxim Cournoyer (5):
pack: Extract keyword-ref procedure from debian-archive.
gexp: computed-file: Honor %guile-for-build.
pack: Extract populate-profile-root from
self-contained-tarball/builder.
tests: pack: Fix indentation.
pack: Add RPM format.
Makefile.am | 2 +
doc/guix.texi | 45 +++-
guix/gexp.scm | 3 +-
guix/rpm.scm | 577 ++++++++++++++++++++++++++++++++++++++++++
guix/scripts/pack.scm | 478 +++++++++++++++++++++++++---------
tests/pack.scm | 331 ++++++++++++++----------
tests/rpm.scm | 86 +++++++
7 files changed, 1258 insertions(+), 264 deletions(-)
create mode 100644 guix/rpm.scm
create mode 100644 tests/rpm.scm
base-commit: a60c750eec73a2030b08b32af3b9f435c7ecca54
--
2.39.1
^ permalink raw reply [flat|nested] 31+ messages in thread* [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive. 2023-02-03 16:19 [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Maxim Cournoyer @ 2023-02-03 22:14 ` Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer ` (4 more replies) 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer 1 sibling, 5 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-03 22:14 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, Ludovic Courtès, Christopher Baines, Ricardo Wurmus Rationale: the upcoming rpm-archive builder will also use it. * guix/scripts/pack.scm: (keyword-ref): New top-level procedure, extracted from... (debian-archive): ... here. Adjust usages accordingly. --- guix/scripts/pack.scm | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f65642fb85..7e466a2be7 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -194,6 +194,12 @@ (define (symlink-spec-option-parser opt name arg result) (leave (G_ "~a: invalid symlink specification~%") arg)))) +(define (keyword-ref lst keyword) + "Return the value of KEYWORD in LST, else #f." + (match (memq keyword lst) + ((_ value . _) value) + (#f #f))) + \f ;;; ;;; Tarball format. @@ -762,20 +768,15 @@ (define data-tarball-file-name (strip-store-file-name (copy-file #+data-tarball data-tarball-file-name) - (define (keyword-ref lst keyword) - (match (memq keyword lst) - ((_ value . _) value) - (#f #f))) - ;; Generate the control archive. (define control-file - (keyword-ref '#$extra-options #:control-file)) + #$(keyword-ref `(,@extra-options) #:control-file)) (define postinst-file - (keyword-ref '#$extra-options #:postinst-file)) + #$(keyword-ref `(,@extra-options) #:postinst-file)) (define triggers-file - (keyword-ref '#$extra-options #:triggers-file)) + #$(keyword-ref `(,@extra-options) #:triggers-file)) (define control-tarball-file-name (string-append "control.tar" -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build. 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer @ 2023-02-03 22:14 ` Maxim Cournoyer 2023-02-04 1:11 ` Ludovic Courtès 2023-02-03 22:14 ` [bug#61255] [PATCH 3/5] pack: Extract populate-profile-root from self-contained-tarball/builder Maxim Cournoyer ` (3 subsequent siblings) 4 siblings, 1 reply; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-03 22:14 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, Ludovic Courtès, Christopher Baines, Ricardo Wurmus * guix/gexp.scm (computed-file): Set the default value of the #:guile argument to that of the %guile-for-build parameter. --- guix/gexp.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 5f92174a2c..bf75d1f8df 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -584,7 +584,8 @@ (define-record-type <computed-file> (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key guile (local-build? #t) (options '())) + #:key (guile (%guile-for-build)) + (local-build? #t) (options '())) "Return an object representing the store item NAME, a file or directory computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the corresponding derivation is built locally. OPTIONS may be used to pass -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build. 2023-02-03 22:14 ` [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer @ 2023-02-04 1:11 ` Ludovic Courtès 2023-02-04 3:43 ` Maxim Cournoyer 0 siblings, 1 reply; 31+ messages in thread From: Ludovic Courtès @ 2023-02-04 1:11 UTC (permalink / raw) To: Maxim Cournoyer Cc: Josselin Poiret, Tobias Geerinckx-Rice, Simon Tournier, Mathieu Othacehe, Christopher Baines, Ricardo Wurmus, 61255 Hello! Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > * guix/gexp.scm (computed-file): Set the default value of the #:guile argument > to that of the %guile-for-build parameter. [...] > (define* (computed-file name gexp > - #:key guile (local-build? #t) (options '())) > + #:key (guile (%guile-for-build)) > + (local-build? #t) (options '())) I think that would lead ‘computed-file’ to pick (%guile-for-build) at the wrong time (time of call instead of time of lowering). Commit ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 made it #f such that ‘gexp->derivation’ gets to resolve it at the “right” time. Does that make sense? But perhaps this approach isn’t suitable in the use case you’re looking at? HTH, Ludo’. ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build. 2023-02-04 1:11 ` Ludovic Courtès @ 2023-02-04 3:43 ` Maxim Cournoyer 2023-02-12 18:14 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès 0 siblings, 1 reply; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-04 3:43 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Tobias Geerinckx-Rice, Simon Tournier, Mathieu Othacehe, Christopher Baines, Ricardo Wurmus, 61255 Hi Luvodic, Ludovic Courtès <ludo@gnu.org> writes: > Hello! > > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> * guix/gexp.scm (computed-file): Set the default value of the #:guile argument >> to that of the %guile-for-build parameter. > > [...] > >> (define* (computed-file name gexp >> - #:key guile (local-build? #t) (options '())) >> + #:key (guile (%guile-for-build)) >> + (local-build? #t) (options '())) > > I think that would lead ‘computed-file’ to pick (%guile-for-build) at > the wrong time (time of call instead of time of lowering). > > Commit ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 made it #f such that > ‘gexp->derivation’ gets to resolve it at the “right” time. I see! I think you are right. Would making the change in the associated gexp compiler do the right thing? Currently it ignores the %guile-for-build fluid as set in the tests/pack.scm test suite for example. Something like this: --8<---------------cut here---------------start------------->8--- modified guix/gexp.scm @@ -584,7 +584,7 @@ (define-record-type <computed-file> (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key (guile (%guile-for-build)) + #:key guile (local-build? #t) (options '())) "Return an object representing the store item NAME, a file or directory computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the @@ -601,7 +601,8 @@ (define-gexp-compiler (computed-file-compiler (file <computed-file>) ;; gexp. (match file (($ <computed-file> name gexp guile options) - (mlet %store-monad ((guile (lower-object (or guile (default-guile)) + (mlet %store-monad ((guile (lower-object (or guile (%guile-for-build) + (default-guile)) system #:target #f))) (apply gexp->derivation name gexp #:guile-for-build guile #:system system #:target target options))))) --8<---------------cut here---------------end--------------->8--- I've verified that 'make check TESTS=tests/pack.scm' is still happy (without such patch, with patch 3/5 applied, the "self-contained-tarball" would try to build a non-bootstrap guile and timeout (on my old machine). Thanks and enjoy FOSDEM! -- Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-04 3:43 ` Maxim Cournoyer @ 2023-02-12 18:14 ` Ludovic Courtès 2023-02-16 15:12 ` Maxim Cournoyer 0 siblings, 1 reply; 31+ messages in thread From: Ludovic Courtès @ 2023-02-12 18:14 UTC (permalink / raw) To: Maxim Cournoyer Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hi Maxim, Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > Ludovic Courtès <ludo@gnu.org> writes: > >> Hello! >> >> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >> >>> * guix/gexp.scm (computed-file): Set the default value of the #:guile argument >>> to that of the %guile-for-build parameter. >> >> [...] >> >>> (define* (computed-file name gexp >>> - #:key guile (local-build? #t) (options '())) >>> + #:key (guile (%guile-for-build)) >>> + (local-build? #t) (options '())) >> >> I think that would lead ‘computed-file’ to pick (%guile-for-build) at >> the wrong time (time of call instead of time of lowering). >> >> Commit ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 made it #f such that >> ‘gexp->derivation’ gets to resolve it at the “right” time. > > I see! I think you are right. Would making the change in the > associated gexp compiler do the right thing? Currently it ignores the > %guile-for-build fluid as set in the tests/pack.scm test suite for > example. Something like this: I don’t fully understand the context. My preference would go to doing like the ‘computed-file’ tests in ‘tests/gexp.scm’, where we explicitly pass #:guile %bootstrap-guile. That said, it seems like patch #5 in this series doesn’t actually use ‘computed-file’ in ‘tests/pack.scm’, does it? Thanks, Ludo’, slowly catching up post-FOSDEM! ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-12 18:14 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès @ 2023-02-16 15:12 ` Maxim Cournoyer 2023-02-23 15:44 ` [bug#61255] (%guile-for-build) default in ‘computed-file’ Ludovic Courtès 0 siblings, 1 reply; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-16 15:12 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hi Ludovic! Ludovic Courtès <ludo@gnu.org> writes: > Hi Maxim, > > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> Ludovic Courtès <ludo@gnu.org> writes: >> >>> Hello! >>> >>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >>> >>>> * guix/gexp.scm (computed-file): Set the default value of the #:guile argument >>>> to that of the %guile-for-build parameter. >>> >>> [...] >>> >>>> (define* (computed-file name gexp >>>> - #:key guile (local-build? #t) (options '())) >>>> + #:key (guile (%guile-for-build)) >>>> + (local-build? #t) (options '())) >>> >>> I think that would lead ‘computed-file’ to pick (%guile-for-build) at >>> the wrong time (time of call instead of time of lowering). >>> >>> Commit ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 made it #f such that >>> ‘gexp->derivation’ gets to resolve it at the “right” time. >> >> I see! I think you are right. Would making the change in the >> associated gexp compiler do the right thing? Currently it ignores the >> %guile-for-build fluid as set in the tests/pack.scm test suite for >> example. Something like this: > > I don’t fully understand the context. My preference would go to doing > like the ‘computed-file’ tests in ‘tests/gexp.scm’, where we explicitly > pass #:guile %bootstrap-guile. With the refactoring done in patch 3/5 ("pack: Extract populate-profile-root from self-contained-tarball/builder."), a computed-file is used in the factorized building block 'populate-profile-root'. Without this patch, the tests making use of it would attempt to build Guile & friends in the test store. > That said, it seems like patch #5 in this series doesn’t actually use > ‘computed-file’ in ‘tests/pack.scm’, does it? It does, indirectly. I hope that helps! -- Thanks, Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] (%guile-for-build) default in ‘computed-file’ 2023-02-16 15:12 ` Maxim Cournoyer @ 2023-02-23 15:44 ` Ludovic Courtès 2023-02-24 2:38 ` Maxim Cournoyer 0 siblings, 1 reply; 31+ messages in thread From: Ludovic Courtès @ 2023-02-23 15:44 UTC (permalink / raw) To: Maxim Cournoyer Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hello! Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > Hi Ludovic! > > Ludovic Courtès <ludo@gnu.org> writes: > >> Hi Maxim, >> >> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >> >>> Ludovic Courtès <ludo@gnu.org> writes: >>> >>>> Hello! >>>> >>>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >>>> >>>>> * guix/gexp.scm (computed-file): Set the default value of the #:guile argument >>>>> to that of the %guile-for-build parameter. >>>> >>>> [...] >>>> >>>>> (define* (computed-file name gexp >>>>> - #:key guile (local-build? #t) (options '())) >>>>> + #:key (guile (%guile-for-build)) >>>>> + (local-build? #t) (options '())) >>>> >>>> I think that would lead ‘computed-file’ to pick (%guile-for-build) at >>>> the wrong time (time of call instead of time of lowering). >>>> >>>> Commit ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 made it #f such that >>>> ‘gexp->derivation’ gets to resolve it at the “right” time. >>> >>> I see! I think you are right. Would making the change in the >>> associated gexp compiler do the right thing? Currently it ignores the >>> %guile-for-build fluid as set in the tests/pack.scm test suite for >>> example. Something like this: >> >> I don’t fully understand the context. My preference would go to doing >> like the ‘computed-file’ tests in ‘tests/gexp.scm’, where we explicitly >> pass #:guile %bootstrap-guile. > > With the refactoring done in patch 3/5 ("pack: Extract > populate-profile-root from self-contained-tarball/builder."), a > computed-file is used in the factorized building block > 'populate-profile-root'. Without this patch, the tests making use of it > would attempt to build Guile & friends in the test store. > >> That said, it seems like patch #5 in this series doesn’t actually use >> ‘computed-file’ in ‘tests/pack.scm’, does it? > > It does, indirectly. > > I hope that helps! I’m really not sure what the impact of 68775338a510f84e63657ab09242d79e726fa457 is, nor whether it was the only solution to the problem. One thing that probably happens is that (default-guile) is now never used for <computed-file>, contrary to what was happening before. The spirit is that (default-guile) would be used as the default for all the declarative file-like objects; gexp compilers refer to (default-guile), not (%guile-for-build). Importantly, (%guile-for-build) is a derivation, possibly built for another system, whereas (default-guile) is a package, which allows ‘lower-object’ to return the derivation for the right system type. Overall, I think this change should be reverted but of course, we should find a solution to the problem you hit in the first place. I hope this makes sense to you. Ludo’. ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] (%guile-for-build) default in ‘computed-file’ 2023-02-23 15:44 ` [bug#61255] (%guile-for-build) default in ‘computed-file’ Ludovic Courtès @ 2023-02-24 2:38 ` Maxim Cournoyer 0 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-24 2:38 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hi Ludovic, Ludovic Courtès <ludo@gnu.org> writes: > Hello! > > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> Hi Ludovic! >> >> Ludovic Courtès <ludo@gnu.org> writes: >> >>> Hi Maxim, >>> >>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >>> >>>> Ludovic Courtès <ludo@gnu.org> writes: >>>> >>>>> Hello! >>>>> >>>>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >>>>> >>>>>> * guix/gexp.scm (computed-file): Set the default value of the #:guile argument >>>>>> to that of the %guile-for-build parameter. >>>>> >>>>> [...] >>>>> >>>>>> (define* (computed-file name gexp >>>>>> - #:key guile (local-build? #t) (options '())) >>>>>> + #:key (guile (%guile-for-build)) >>>>>> + (local-build? #t) (options '())) >>>>> >>>>> I think that would lead ‘computed-file’ to pick (%guile-for-build) at >>>>> the wrong time (time of call instead of time of lowering). >>>>> >>>>> Commit ab25eb7caaf5571cc9f8d6397a1eae127d7e29d1 made it #f such that >>>>> ‘gexp->derivation’ gets to resolve it at the “right” time. >>>> >>>> I see! I think you are right. Would making the change in the >>>> associated gexp compiler do the right thing? Currently it ignores the >>>> %guile-for-build fluid as set in the tests/pack.scm test suite for >>>> example. Something like this: >>> >>> I don’t fully understand the context. My preference would go to doing >>> like the ‘computed-file’ tests in ‘tests/gexp.scm’, where we explicitly >>> pass #:guile %bootstrap-guile. >> >> With the refactoring done in patch 3/5 ("pack: Extract >> populate-profile-root from self-contained-tarball/builder."), a >> computed-file is used in the factorized building block >> 'populate-profile-root'. Without this patch, the tests making use of it >> would attempt to build Guile & friends in the test store. >> >>> That said, it seems like patch #5 in this series doesn’t actually use >>> ‘computed-file’ in ‘tests/pack.scm’, does it? >> >> It does, indirectly. >> >> I hope that helps! > > I’m really not sure what the impact of > 68775338a510f84e63657ab09242d79e726fa457 is, nor whether it was the only > solution to the problem. > > One thing that probably happens is that (default-guile) is now never > used for <computed-file>, contrary to what was happening before. The > spirit is that (default-guile) would be used as the default for all the > declarative file-like objects; gexp compilers refer to (default-guile), > not (%guile-for-build). > > Importantly, (%guile-for-build) is a derivation, possibly built for > another system, whereas (default-guile) is a package, which allows > ‘lower-object’ to return the derivation for the right system type. I assumed the purpose of the %guile-for-build fluid was to override the value of the guile used in some conditions, such as during tests (e.g. the '(set-guile-for-build (default-guile))' calls inside the store monad in tests/pack.scm). It's honored for gexp->derivation, but isn't honored for computed-file, which is supposed to be its declarative counterpart. This problem was only exposed when factoring out 'populate-profile-root' as a computed-file object in 68380db4c40a2ee1156349a87254fd7b1f1a52d5 ("pack: Extract populate-profile-root from self-contained-tarball/builder.") > Overall, I think this change should be reverted but of course, we should > find a solution to the problem you hit in the first place. > > I hope this makes sense to you. See the problem it solves below. If we revert this now, we'd have to mark the 'self-contained-tarball' as an expected fail until we find a a better solution. The problem it solves is this: after reverting the change with: > modified guix/gexp.scm > @@ -601,7 +601,7 @@ (define-gexp-compiler (computed-file-compiler (file <computed-file>) > ;; gexp. > (match file > (($ <computed-file> name gexp guile options) > - (mlet %store-monad ((guile (lower-object (or guile (%guile-for-build) > + (mlet %store-monad ((guile (lower-object (or guile ;(%guile-for-build) > (default-guile)) > system #:target #f))) > (apply gexp->derivation name gexp #:guile-for-build guile Running the pack.scm tests: $ make check TESTS=tests/pack.scm Fails with a timeout, because the %guile-for-build is not honored by a computed-file derivation, and it goes on building the non-bootstrap build-side guile, gcc, etc. in the test store (see: pack.log): --8<---------------cut here---------------start------------->8--- gcc-10.3.0/gcc/targhooks.h gcc-10.3.0/gcc/testsuite/ gcc-10.3.0/gcc/testsuite/.gitattributes gcc-10.3.0/gcc/testsuite/ChangeLog gcc-10.3.0/gcc/testsuite/ChangeLog-1993-2007 gcc-10.3.0/gcc/testsuite/ChangeLog-2008 gcc-10.3.0/gcc/testsuite/ChangeLog-2009 gcc-10.3.0/gcc/testsuite/ChangeLog-2010 gcc-10.3.0/gcc/testsuite/ChangeLog-2011 gcc-10.3.0/gcc/testsuite/ChangeLog-2012 gcc-10.3.0/gcc/testsuite/ChangeLog-2013 gcc-10.3.0/gcc/testsuite/ChangeLog-2014 gcc-10.3.0/gcc/testsuite/ChangeLog-2015 gcc-10.3.0/gcc/testsuite/ChangeLog-2016 gcc-10.3.0/gcc/testsuite/ChangeLog-2017 gcc-10.3.0/gcc/testsuite/ChangeLog-2018 building of `/home/maxim/src/guix/test-tmp/store/hp86j4850ajphhs1hyryis5nj93pv66l-gcc-10.3.0.tar.xz.drv' timed out after 300 seconds @ build-failed /home/maxim/src/guix/test-tmp/store/hp86j4850ajphhs1hyryis5nj93pv66l-gcc-10.3.0.tar.xz.drv - timeout killing process 4149 cannot build derivation `/home/maxim/src/guix/test-tmp/store/82yb9zwxdwhmacz36pjrrzzmgjgakavy-gcc-10.3.0.drv': 1 dependencies couldn't be built @ build-started /home/maxim/src/guix/test-tmp/store/8dfjl4594zgb7wi3icw8s9z3rr3pck6x-gcc-4.9.4.tar.xz.drv - x86_64-linux /home/maxim/src/guix/test-tmp/var/log/guix/drvs/8d//fjl4594zgb7wi3icw8s9z3rr3pck6x-gcc-4.9.4.tar.xz.drv.gz 4611 cannot build derivation `/home/maxim/src/guix/test-tmp/store/hcv6vh1gx5fkw62l3nravi1aqhi8cq60-gcc-cross-boot0-10.3.0.drv': 1 dependencies couldn't be built killing process 4611 cannot build derivation `/home/maxim/src/guix/test-tmp/store/1ihb1yadv4dfbqhfcgn1cyvsl8444yaw-guile-3.0.7.drv': 1 dependencies couldn't be built cannot build derivation `/home/maxim/src/guix/test-tmp/store/6g7fhyr1b84b5qg8nwn46hkrg55i8c2q-profile-directory.drv': 1 dependencies couldn't be built cannot build derivation `/home/maxim/src/guix/test-tmp/store/apm8bjvzs1n707lagw0spzr2m2nc0p4v-pack.tar.gz.drv': 1 dependencies couldn't be built cannot build derivation `/home/maxim/src/guix/test-tmp/store/syiq7lmx3v0pkrjp5wqd5kfapqpxpki3-check-tarball.drv': 1 dependencies couldn't be built test-name: self-contained-tarball location: /home/maxim/src/guix/tests/pack.scm:80 source: + (test-assert + "self-contained-tarball" + (let ((guile (package-derivation %store %bootstrap-guile))) + (run-with-store + %store + (mlet* %store-monad + ((profile + -> + (profile + (content + (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) + (tarball + (self-contained-tarball + "pack" + profile + #:symlinks + '(("/bin/Guile" -> "bin/guile")) + #:compressor + %gzip-compressor + #:archiver + %tar-bootstrap)) + (check (gexp->derivation + "check-tarball" + (with-imported-modules + '((guix build utils)) + (gexp (begin + (use-modules + (guix build utils) + (srfi srfi-1)) + (define store + (string-append + "." + (%store-directory) + "/")) + (define (canonical? file) + (let ((st (lstat file))) + (or (not (string-prefix? store file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand + 146 + (stat:mode st))))))) + (define bin + (string-append + "." + (ungexp profile) + "/bin")) + (setenv + "PATH" + (string-append + (ungexp %tar-bootstrap) + "/bin")) + (system* "tar" "xvf" (ungexp tarball)) + (mkdir (ungexp output)) + (exit (and (file-exists? + (string-append bin "/guile")) + (file-exists? store) + (every canonical? + (find-files + "." + (const #t) + #:directories? + #t)) + (string=? + (string-append + (ungexp %bootstrap-guile) + "/bin") + (readlink bin)) + (string=? + (string-append + ".." + (ungexp profile) + "/bin/guile") + (readlink "bin/Guile")))))))))) + (built-derivations (list check))) + #:guile-for-build + guile))) actual-value: #f actual-error: + (%exception + #<&store-protocol-error message: "build of `/home/maxim/src/guix/test-tmp/store/syiq7lmx3v0pkrjp5wqd5kfapqpxpki3-check-tarball.drv' failed" status: 101>) result: FAIL --8<---------------cut here---------------end--------------->8--- -- Thanks, Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 3/5] pack: Extract populate-profile-root from self-contained-tarball/builder. 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer @ 2023-02-03 22:14 ` Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 4/5] tests: pack: Fix indentation Maxim Cournoyer ` (2 subsequent siblings) 4 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-03 22:14 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, Ludovic Courtès, Christopher Baines, Ricardo Wurmus This allows more code to be reused between the various archive writers. * guix/scripts/pack.scm (set-utf8-locale): New top-level procedure, extracted from... (populate-profile-root): New procedure, extracted from... (self-contained-tarball/builder): ... here. Add #:target argument. Call populate-profile-root. [LOCALSTATEDIR?]: Set db.sqlite file permissions. (self-contained-tarball): Call self-contained-tarball/builder with the TARGET argument, and set #:local-build? to #f for the gexp-derivation call. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. (debian-archive): Call self-contained-tarball/builder with the #:target argument. Fix indentation. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. --- guix/scripts/pack.scm | 247 ++++++++++++++++++++++++------------------ 1 file changed, 142 insertions(+), 105 deletions(-) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7e466a2be7..7a5fb9bd0d 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -200,104 +200,144 @@ (define (keyword-ref lst keyword) ((_ value . _) value) (#f #f))) -\f -;;; -;;; Tarball format. -;;; -(define* (self-contained-tarball/builder profile - #:key (profile-name "guix-profile") - (compressor (first %compressors)) - localstatedir? - (symlinks '()) - (archiver tar) - (extra-options '())) - "Return the G-Expression of the builder used for self-contained-tarball." +(define (set-utf8-locale profile) + "Configure the environment to use the \"en_US.utf8\" locale provided by the +GLIBC-UT8-LOCALES package." + ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. + (and (or (not (profile? profile)) + (profile-locales? profile)) + #~(begin + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8")))) + +(define* (populate-profile-root profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + (symlinks '())) + "Populate the root profile directory with SYMLINKS and a Guix database, when +LOCALSTATEDIR? is set. When DEDUPLICATE? is true, deduplicate the store +items, which relies on hard links." (define database (and localstatedir? (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define set-utf8-locale - ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. - (and (or (not (profile? profile)) - (profile-locales? profile)) - #~(begin - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8")))) - (define (import-module? module) ;; Since we don't use deduplication support in 'populate-store', don't ;; import (guix store deduplication) and its dependencies, which includes - ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'. + ;; Guile-Gcrypt, unless DEDUPLICATE? is #t. This makes it possible to run + ;; tests with '--bootstrap'. (and (not-config? module) - (not (equal? '(guix store deduplication) module)))) - - (with-imported-modules (source-module-closure - `((guix build pack) - (guix build store-copy) - (guix build utils) - (guix build union) - (gnu build install)) - #:select? import-module?) + (or deduplicate? (not (equal? '(guix store deduplication) module))))) + + (computed-file "profile-directory" + (with-imported-modules (source-module-closure + `((guix build pack) + (guix build store-copy) + (guix build utils) + (guix build union) + (gnu build install)) + #:select? import-module?) + #~(begin + (use-modules (guix build pack) + (guix build store-copy) + (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off by + ;; default. Furthermore GNU tar < 1.30 sometimes fails to extract + ;; tarballs with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-store (list "profile") #$output + #:deduplicate? #$deduplicate?) + + (when #+localstatedir? + (install-database-and-gc-roots #$output #+database #$profile + #:profile-name #$profile-name)) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> #$output) + directives))) + #:local-build? #f + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) + +\f +;;; +;;; Tarball format. +;;; +(define* (self-contained-tarball/builder profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + symlinks + compressor + archiver) + "Return a GEXP that can build a self-contained tarball." + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (with-imported-modules (source-module-closure '((guix build pack) + (guix build utils))) #~(begin (use-modules (guix build pack) - (guix build store-copy) - (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - ;; Use a relative file name for compatibility with - ;; relocatable packs. - (,source -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + (guix build utils)) ;; Make sure non-ASCII file names are properly handled. - #+set-utf8-locale + #+(set-utf8-locale profile) (define tar #+(file-append archiver "/bin/tar")) - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-store (list "profile") %root #:deduplicate? #f) + (define %root (if #$localstatedir? "." #$root)) - (when #+localstatedir? - (install-database-and-gc-roots %root #+database #$profile - #:profile-name #$profile-name)) + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. (with-directory-excursion %root ;; GNU Tar recurses directories by default. Simply add the whole - ;; current directory, which contains all the generated files so far. + ;; current directory, which contains all the files to be archived. ;; This avoids creating duplicate files in the archives that would ;; be stored as hard links by GNU Tar. (apply invoke tar "-cvf" #$output "." @@ -326,17 +366,16 @@ (define* (self-contained-tarball name profile (warning (G_ "entry point not supported in the '~a' format~%") 'tarball)) - (gexp->derivation - (string-append name ".tar" - (compressor-extension compressor)) - (self-contained-tarball/builder profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".tar" + (compressor-extension compressor)) + (self-contained-tarball/builder profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver))) \f ;;; @@ -682,18 +721,19 @@ (define %valid-compressors '("gzip" "xz" "none")) 'deb)) (define data-tarball - (computed-file (string-append "data.tar" - (compressor-extension compressor)) - (self-contained-tarball/builder - profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:local-build? #f ;allow offloading - #:options (list #:references-graphs `(("profile" ,profile)) - #:target target))) + (computed-file (string-append "data.tar" (compressor-extension + compressor)) + (self-contained-tarball/builder profile + #:target target + #:profile-name profile-name + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver) + #:local-build? #f ;allow offloading + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) (define build (with-extensions (list guile-gcrypt) @@ -821,10 +861,7 @@ (define tar (string-append #+archiver "/bin/tar")) "debian-binary" control-tarball-file-name data-tarball-file-name))))) - (gexp->derivation (string-append name ".deb") - build - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".deb") build)) \f ;;; -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 4/5] tests: pack: Fix indentation. 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 3/5] pack: Extract populate-profile-root from self-contained-tarball/builder Maxim Cournoyer @ 2023-02-03 22:14 ` Maxim Cournoyer 2023-02-12 18:20 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès 2023-02-03 22:14 ` [bug#61255] [PATCH 5/5] pack: Add RPM format Maxim Cournoyer 2023-02-12 18:57 ` Ludovic Courtès 4 siblings, 1 reply; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-03 22:14 UTC (permalink / raw) To: 61255; +Cc: Maxim Cournoyer * tests/pack.scm: Fix indentation. --- tests/pack.scm | 274 ++++++++++++++++++++++++------------------------- 1 file changed, 137 insertions(+), 137 deletions(-) diff --git a/tests/pack.scm b/tests/pack.scm index a4c388d93e..2e3b9d0ca4 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -75,43 +75,43 @@ (define %ar-bootstrap %bootstrap-binutils) #:compressor %gzip-compressor #:archiver %tar-bootstrap)) (check (gexp->derivation - "check-tarball" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (srfi srfi-1)) - - (define store - ;; The unpacked store. - (string-append "." (%store-directory) "/")) - - (define (canonical? file) - ;; Return #t if FILE is read-only and its mtime is 1. - (let ((st (lstat file))) - (or (not (string-prefix? store file)) - (eq? 'symlink (stat:type st)) - (and (= 1 (stat:mtime st)) - (zero? (logand #o222 - (stat:mode st))))))) - - (define bin - (string-append "." #$profile "/bin")) - - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (file-exists? store) - (every canonical? - (find-files "." (const #t) - #:directories? #t)) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile"))))))))) + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define store + ;; The unpacked store. + (string-append "." (%store-directory) "/")) + + (define (canonical? file) + ;; Return #t if FILE is read-only and its mtime is 1. + (let ((st (lstat file))) + (or (not (string-prefix? store file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 + (stat:mode st))))))) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (file-exists? store) + (every canonical? + (find-files "." (const #t) + #:directories? #t)) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile"))))))))) (built-derivations (list check)))) ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of @@ -132,16 +132,16 @@ (define bin (tarball (self-contained-tarball "tar-pack" profile #:localstatedir? #t)) (check (gexp->derivation - "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? "var/guix/db/db.sqlite") - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)))))))) + "check-tarball" + #~(let ((bin (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -155,44 +155,44 @@ (define bin (tarball (self-contained-tarball "tar-pack" tree #:localstatedir? #t)) (check (gexp->derivation - "check-tarball" - (with-extensions (list guile-sqlite3 guile-gcrypt) - (with-imported-modules (source-module-closure - '((guix store database))) - #~(begin - (use-modules (guix store database) - (rnrs io ports) - (srfi srfi-1)) - - (define (valid-file? basename data) - (define file - (string-append "./" #$tree "/" basename)) - - (string=? (call-with-input-file (pk 'file file) - get-string-all) - data)) - - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - - (sql-schema - #$(local-file (search-path %load-path - "guix/store/schema.sql"))) - (with-database "var/guix/db/db.sqlite" db - ;; Make sure non-ASCII file names are properly - ;; handled. - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales - "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - (mkdir #$output) - (exit - (and (every valid-file? - '("α" "λ") - '("alpha" "lambda")) - (integer? (path-id db #$tree))))))))))) + "check-tarball" + (with-extensions (list guile-sqlite3 guile-gcrypt) + (with-imported-modules (source-module-closure + '((guix store database))) + #~(begin + (use-modules (guix store database) + (rnrs io ports) + (srfi srfi-1)) + + (define (valid-file? basename data) + (define file + (string-append "./" #$tree "/" basename)) + + (string=? (call-with-input-file (pk 'file file) + get-string-all) + data)) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + + (sql-schema + #$(local-file (search-path %load-path + "guix/store/schema.sql"))) + (with-database "var/guix/db/db.sqlite" db + ;; Make sure non-ASCII file names are properly + ;; handled. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales + "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (mkdir #$output) + (exit + (and (every valid-file? + '("α" "λ") + '("alpha" "lambda")) + (integer? (path-id db #$tree))))))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -207,33 +207,33 @@ (define file #:symlinks '(("/bin/Guile" -> "bin/guile")) #:localstatedir? #t)) (check (gexp->derivation - "check-tarball" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (define bin - (string-append "." #$profile "/bin")) - - (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) - (mkdir "base") - (with-directory-excursion "base" - (invoke "tar" "xvf" #$tarball)) - - (match (find-files "base" "layer.tar") - ((layer) - (invoke "tar" "xvf" layer))) - - (when - (and (file-exists? (string-append bin "/guile")) - (file-exists? "var/guix/db/db.sqlite") - (file-is-directory? "tmp") - (string=? (string-append #$%bootstrap-guile "/bin") - (pk 'binlink (readlink bin))) - (string=? (string-append #$profile "/bin/guile") - (pk 'guilelink (readlink "bin/Guile")))) - (mkdir #$output))))))) + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) + (mkdir "base") + (with-directory-excursion "base" + (invoke "tar" "xvf" #$tarball)) + + (match (find-files "base" "layer.tar") + ((layer) + (invoke "tar" "xvf" layer))) + + (when + (and (file-exists? (string-append bin "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (file-is-directory? "tmp") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + (string=? (string-append #$profile "/bin/guile") + (pk 'guilelink (readlink "bin/Guile")))) + (mkdir #$output))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -248,31 +248,31 @@ (define bin #:symlinks '(("/bin" -> "bin")) #:localstatedir? #t)) (check (gexp->derivation - "check-tarball" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (define bin - (string-append "." #$profile "/bin")) - - (setenv "PATH" - (string-append #$squashfs-tools "/bin")) - (invoke "unsquashfs" #$image) - (with-directory-excursion "squashfs-root" - (when (and (file-exists? (string-append bin - "/guile")) - (file-exists? "var/guix/db/db.sqlite") - (string=? (string-append #$%bootstrap-guile "/bin") - (pk 'binlink (readlink bin))) - - ;; This is a relative symlink target. - (string=? (string-drop - (string-append #$profile "/bin") - 1) - (pk 'guilelink (readlink "bin")))) - (mkdir #$output)))))))) + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$squashfs-tools "/bin")) + (invoke "unsquashfs" #$image) + (with-directory-excursion "squashfs-root" + (when (and (file-exists? (string-append bin + "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + + ;; This is a relative symlink target. + (string=? (string-drop + (string-append #$profile "/bin") + 1) + (pk 'guilelink (readlink "bin")))) + (mkdir #$output)))))))) (built-derivations (list check)))) (unless store (test-skip 1)) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-03 22:14 ` [bug#61255] [PATCH 4/5] tests: pack: Fix indentation Maxim Cournoyer @ 2023-02-12 18:20 ` Ludovic Courtès 2023-02-16 15:22 ` Maxim Cournoyer 0 siblings, 1 reply; 31+ messages in thread From: Ludovic Courtès @ 2023-02-12 18:20 UTC (permalink / raw) To: Maxim Cournoyer; +Cc: 61255 Hi, Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > * tests/pack.scm: Fix indentation. [...] > (check (gexp->derivation > - "check-tarball" > - (with-imported-modules '((guix build utils)) [...] > + "check-tarball" > + (with-imported-modules '((guix build utils)) I’m not convinced by the indentation rule for ‘gexp->derivation’ added in 82daab42811a2e3c7684ebdf12af75ff0fa67b99: there’s no reason to treat ‘gexp->derivation’ differently from other procedures. What about removing that rule from ‘.dir-locals.el’ and keeping ‘tests/pack.scm’ unchanged? (Also not sure about the ‘computed-file’ rule. For all these things, we’ll want to keep Emacs and (guix read-print) in sync, too.) Thanks, Ludo’. ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-12 18:20 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès @ 2023-02-16 15:22 ` Maxim Cournoyer 2023-02-23 15:47 ` Ludovic Courtès 0 siblings, 1 reply; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-16 15:22 UTC (permalink / raw) To: Ludovic Courtès; +Cc: 61255 Hi Ludovic, Ludovic Courtès <ludo@gnu.org> writes: > Hi, > > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> * tests/pack.scm: Fix indentation. > > [...] > >> (check (gexp->derivation >> - "check-tarball" >> - (with-imported-modules '((guix build utils)) > > [...] > >> + "check-tarball" >> + (with-imported-modules '((guix build utils)) > > I’m not convinced by the indentation rule for ‘gexp->derivation’ added > in 82daab42811a2e3c7684ebdf12af75ff0fa67b99: there’s no reason to treat > ‘gexp->derivation’ differently from other procedures. The benefit I saw was that writing --8<---------------cut here---------------start------------->8--- (gexp->derivation the-name #~(begin (the (multi-line (gexp))))) --8<---------------cut here---------------end--------------->8--- Seemed most readable/natural. I saw some code in our code base was already indented that way, but Emacs wasn't happy about it then. > What about removing that rule from ‘.dir-locals.el’ and keeping > ‘tests/pack.scm’ unchanged? I don't feel too strongly about it, but I thought being able to indent as above was neater than having to drop the-name on the second like, or have it indented like under: --8<---------------cut here---------------start------------->8--- (gexp->derivation the-name #~(begin (the (multi-line (gexp))))) --8<---------------cut here---------------end--------------->8--- > (Also not sure about the ‘computed-file’ rule. For all these things, > we’ll want to keep Emacs and (guix read-print) in sync, too.) Ah! Thanks for pointing that out. I can address this separately. It'd be nice if (guix read-print) understood the rules under .dir-locals.el :-). -- Thanks, Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-16 15:22 ` Maxim Cournoyer @ 2023-02-23 15:47 ` Ludovic Courtès 0 siblings, 0 replies; 31+ messages in thread From: Ludovic Courtès @ 2023-02-23 15:47 UTC (permalink / raw) To: Maxim Cournoyer; +Cc: 61255 Hi, Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > Ludovic Courtès <ludo@gnu.org> writes: > >> Hi, >> >> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: >> >>> * tests/pack.scm: Fix indentation. >> >> [...] >> >>> (check (gexp->derivation >>> - "check-tarball" >>> - (with-imported-modules '((guix build utils)) >> >> [...] >> >>> + "check-tarball" >>> + (with-imported-modules '((guix build utils)) >> >> I’m not convinced by the indentation rule for ‘gexp->derivation’ added >> in 82daab42811a2e3c7684ebdf12af75ff0fa67b99: there’s no reason to treat >> ‘gexp->derivation’ differently from other procedures. > > The benefit I saw was that writing > > (gexp->derivation the-name > #~(begin > (the > (multi-line > (gexp))))) I understand, but you know, it’s best to avoid unilaterally changing established conventions. :-) If and when there’s consensus about this change, (guix read-print) should be updated. Ludo’. ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 5/5] pack: Add RPM format. 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer ` (2 preceding siblings ...) 2023-02-03 22:14 ` [bug#61255] [PATCH 4/5] tests: pack: Fix indentation Maxim Cournoyer @ 2023-02-03 22:14 ` Maxim Cournoyer 2023-02-12 18:52 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès 2023-02-12 18:57 ` Ludovic Courtès 4 siblings, 1 reply; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-03 22:14 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, Ludovic Courtès, Christopher Baines, Ricardo Wurmus * guix/rpm.scm: New file. * guix/scripts/pack.scm (rpm-archive): New procedure. (%formats): Register it. (show-formats): Add it. (guix-pack): Register supported extra-options for the rpm format. * tests/pack.scm (rpm-for-tests): New variable. ("rpm archive can be installed/uninstalled"): New test. * tests/rpm.scm: New test. * doc/guix.texi (Invoking guix pack): Document it. --- Makefile.am | 2 + doc/guix.texi | 45 ++- guix/rpm.scm | 621 ++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pack.scm | 227 ++++++++++++++- tests/pack.scm | 57 +++- tests/rpm.scm | 86 ++++++ 6 files changed, 1025 insertions(+), 13 deletions(-) create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm diff --git a/Makefile.am b/Makefile.am index a4b6f03b3a..ac4485dd30 100644 --- a/Makefile.am +++ b/Makefile.am @@ -111,6 +111,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/rpm.scm \ guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ @@ -533,6 +534,7 @@ SCM_TESTS = \ tests/pypi.scm \ tests/read-print.scm \ tests/records.scm \ + tests/rpm.scm \ tests/scripts.scm \ tests/search-paths.scm \ tests/services.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index d69be8586e..3584274848 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6894,6 +6894,7 @@ such file or directory'' message. @end quotation @item deb +@cindex Debian, build a .deb package with guix pack This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. @@ -6910,7 +6911,8 @@ guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello Because archives produced with @command{guix pack} contain a collection of store items and because each @command{dpkg} package must not have conflicting files, in practice that means you likely won't be able to -install more than one such archive on a given system. +install more than one such archive on a given system. You can +nonetheless pack as many Guix packages as you want in one such archive. @end quotation @quotation Warning @@ -6921,6 +6923,47 @@ shared by other software, such as a Guix installation or other, non-deb packs. @end quotation +@item rpm +@cindex RPM, build an RPM archive with guix pack +This produces an RPM archive (a package with the @samp{.rpm} file +extension) containing all the specified binaries and symbolic links, +that can be installed on top of any RPM-based GNU/Linux distribution. +The RPM format embeds checksums for every file it contains, which the +@command{rpm} command uses to validate the integrity of the archive. + +Advanced RPM-related options are revealed via the +@option{--help-rpm-format} option. These options allow embedding +maintainer scripts that can run before or after the installation of the +RPM archive, for example. + +The RPM format supports relocatable packages via the @option{--prefix} +option of the @command{rpm} command, which can be handy to install an +RPM package to a specific prefix, making installing multiple +Guix-produced RPM packages side by side possible. + +@example +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm +@end example + +@quotation Note +Similarly to Debian packages, two RPM packages with conflicting files +cannot be installed simultaneously. Contrary to Debian packages, RPM +supports relocatable packages, so file conflicts can be avoided by +installing the RPM packages under different installation prefixes, as +shown in the above example. +@end quotation + +@quotation Warning +@command{rpm} assumes ownership of any files contained in the pack, +which means it will remove @file{/gnu/store} upon uninstalling a +Guix-generated RPM package, unless the RPM package was installed with +the @option{--prefix} option of the @command{rpm} command. It is unwise +to install Guix-produced @samp{.rpm} packages on a system where +@file{/gnu/store} is shared by other software, such as a Guix +installation or other, non-rpm packs. +@end quotation + @end table @cindex relocatable binaries diff --git a/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..d11ac7d72a --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,621 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; This module provides the building blocks required to construct RPM +;;; archives. It is intended to be importable on the build side, so shouldn't +;;; depend on (guix diagnostics) or other host-side-only modules. + +(define-module (guix rpm) + #:autoload (gcrypt hash) (hash-algorithm file-hash md5) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-171) + #:export (generate-lead + generate-signature + generate-header + assemble-rpm-metadata + + ;; XXX: These are internals, but the inline disabling trick + ;; doesn't work on them. + make-header-entry + header-entry? + header-entry-tag + header-entry-count + header-entry-value + + bytevector->hex-string + + fhs-directory?)) + +(define (gnu-system-triplet->machine-type triplet) + "Return the machine component of TRIPLET, a GNU system triplet." + (first (string-split triplet #\-))) + +(define (gnu-machine-type->rpm-arch type) + "Return the canonical RPM architecture string, given machine TYPE." + (match type + ("arm" "armv7hl") + ("powerpc" "ppc") + ("powerpc64le" "ppc64le") + (machine machine))) ;unchanged + +(define (gnu-machine-type->rpm-number type) + "Translate machine TYPE to its corresponding RPM integer value." + ;; Refer to the rpmrc.in file in the RPM source for the complete + ;; translation tables. + (match type + ((or "i486" "i586" "i686" "x86_64") 1) + ((? (cut string-prefix? "powerpc" <>)) 5) + ("mips64el" 11) + ((? (cut string-prefix? "arm" <>)) 12) + ("aarch64" 19) + ((? (cut string-prefix? "riscv" <>)) 22) + (_ (error "no RPM number known for machine type" type)))) + +(define (u16-number->u8-list number) + "Return a list of byte values made of NUMBER, a 16 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 2))) + (bytevector->u8-list bv))) + +(define (u32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (s32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit signed integer." + (let ((bv (sint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (u8-list->u32-number lst) + "Return the 32 bit unsigned integer corresponding to the 4 bytes in LST." + (bytevector-u32-ref (u8-list->bytevector lst) 0 (endianness big))) + +\f +;;; +;;; Lead section. +;;; + +;; Refer to the docs/manual/format.md file of the RPM source for the details +;; regarding the binary format of an RPM archive. +(define* (generate-lead name-version #:key (target %host-type)) + "Generate a RPM lead u8-list that uses NAME-VERSION, the name and version +string of the package, and TARGET, a GNU triplet used to derive the target +machine type." + (define machine-type (gnu-system-triplet->machine-type target)) + (define magic (list #xed #xab #xee #xdb)) + (define file-format-version (list 3 0)) ;3.0 + (define type (list 0 0)) ;0 for binary packages + (define arch-number (u16-number->u8-list + (gnu-machine-type->rpm-number machine-type))) + ;; The 66 bytes from 10 to 75 are for the name-version-release string. + (define name + (let ((padding-bytes (make-list (- 66 (string-length name-version)) 0))) + (append (bytevector->u8-list (string->utf8 name-version)) + padding-bytes))) + ;; There is no OS number corresponding to GNU/Hurd (GNU), only Linux, per + ;; rpmrc.in. + (define os-number (list 0 1)) + + ;; For RPM format 3.0, the signature type is 5, which means a "Header-style" + ;; signature. + (define signature-type (list 0 5)) + + (define reserved-bytes (make-list 16 0)) + + (append magic file-format-version type arch-number name + os-number signature-type reserved-bytes)) + +\f +;;; +;;; Header section. +;;; + +(define header-magic (list #x8e #xad #xe8)) +(define header-version (list 1)) +(define header-reserved (make-list 4 0)) ;4 reserved bytes +;;; Every header starts with 8 bytes made by the header magic number, the +;;; header version and 4 reserved bytes. +(define header-intro (append header-magic header-version header-reserved)) + +;;; Header entry data types. +(define NULL 0) +(define CHAR 1) +(define INT8 2) +(define INT16 3) ;2-bytes aligned +(define INT32 4) ;4-bytes aligned +(define INT64 5) ;8-bytes aligned +(define STRING 6) +(define BIN 7) +(define STRING_ARRAY 8) +(define I18NSTRIN_TYPE 9) + +;;; Header entry tags. +(define-record-type <rpm-tag> + (make-rpm-tag number type) + rpm-tag? + (number rpm-tag-number) + (type rpm-tag-type)) + +;;; The following are internal tags used to identify the data sections. +(define RPMTAG_HEADERSIGNATURES (make-rpm-tag 62 BIN)) ;signature header +(define RPMTAG_HEADERIMMUTABLE (make-rpm-tag 63 BIN)) ;main/data header +(define RPMTAG_HEADERI18NTABLE (make-rpm-tag 100 STRING_ARRAY)) + +;;; Subset of RPM tags from include/rpm/rpmtag.h. +(define RPMTAG_NAME (make-rpm-tag 1000 STRING)) +(define RPMTAG_VERSION (make-rpm-tag 1001 STRING)) +(define RPMTAG_RELEASE (make-rpm-tag 1002 STRING)) +(define RPMTAG_SUMMARY (make-rpm-tag 1004 STRING)) +(define RPMTAG_SIZE (make-rpm-tag 1009 INT32)) +(define RPMTAG_LICENSE (make-rpm-tag 1014 STRING)) +(define RPMTAG_OS (make-rpm-tag 1021 STRING)) +(define RPMTAG_ARCH (make-rpm-tag 1022 STRING)) +(define RPMTAG_PREIN (make-rpm-tag 1023 STRING)) +(define RPMTAG_POSTIN (make-rpm-tag 1024 STRING)) +(define RPMTAG_PREUN (make-rpm-tag 1025 STRING)) +(define RPMTAG_POSTUN (make-rpm-tag 1026 STRING)) +(define RPMTAG_FILESIZES (make-rpm-tag 1028 INT32)) +(define RPMTAG_FILEMODES (make-rpm-tag 1030 INT16)) +(define RPMTAG_FILEDIGESTS (make-rpm-tag 1035 STRING_ARRAY)) +(define RPMTAG_FILELINKTOS (make-rpm-tag 1036 STRING_ARRAY)) +(define RPMTAG_FILEUSERNAME (make-rpm-tag 1039 STRING_ARRAY)) +(define RPMTAG_GROUPNAME (make-rpm-tag 1040 STRING_ARRAY)) +(define RPMTAG_PREFIXES (make-rpm-tag 1098 STRING_ARRAY)) +(define RPMTAG_DIRINDEXES (make-rpm-tag 1116 INT32)) +(define RPMTAG_BASENAMES (make-rpm-tag 1117 STRING_ARRAY)) +(define RPMTAG_DIRNAMES (make-rpm-tag 1118 STRING_ARRAY)) +(define RPMTAG_PAYLOADFORMAT (make-rpm-tag 1124 STRING)) +(define RPMTAG_PAYLOADCOMPRESSOR (make-rpm-tag 1125 STRING)) +(define RPMTAG_LONGFILESIZES (make-rpm-tag 5008 INT64)) +(define RPMTAG_LONGSIZE (make-rpm-tag 5009 INT64)) +;;; The algorithm used to compute the digest of each file, e.g. RPM_HASH_MD5. +(define RPMTAG_FILEDIGESTALGO (make-rpm-tag 5011 INT32)) +;;; RPMTAG_ENCODING specifies the encoding used for strings, e.g. "utf-8". +(define RPMTAG_ENCODING (make-rpm-tag 5062 STRING)) +;;; Compressed payload digest. Its type is a string array, but currently in +;;; practice it is equivalent to STRING, since only the first element is used. +(define RPMTAG_PAYLOADDIGEST (make-rpm-tag 5092 STRING_ARRAY)) +;;; The algorithm used to compute the payload digest, e.g. RPM_HASH_SHA256. +(define RPMTAG_PAYLOADDIGESTALGO (make-rpm-tag 5093 INT32)) +;;; The following are taken from the rpmHashAlgo_e enum in rpmcrypto.h. +(define RPM_HASH_MD5 1) +(define RPM_HASH_SHA256 8) + +;;; Other useful internal definitions. +(define REGION_TAG_COUNT 16) ;number of bytes +(define INT32_MAX (1- (expt 2 32))) ;4294967295 bytes (unsigned) + +(define (rpm-tag->u8-list tag) + "Return the u8 list corresponding to RPM-TAG, a <rpm-tag> object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type <header-entry> + (make-header-entry tag count value) + header-entry? + (tag header-entry-tag) ;<rpm-tag> + (count header-entry-count) ;number (u32) + (value header-entry-value)) ;string|number|list|... + +(define (entry-type->alignement type) + "Return the byte alignment of TYPE, an RPM header entry type." + (cond ((= INT16 type) 2) + ((= INT32 type) 4) + ((= INT64 type) 8) + (else 1))) + +(define (next-aligned-offset offset alignment) + "Return the next position from OFFSET which satisfies ALIGNMENT." + (if (= 0 (modulo offset alignment)) + offset + (next-aligned-offset (1+ offset) alignment))) + +(define (header-entry->data entry) + "Return the data of ENTRY, a <header-entry> object, as a u8 list." + (let* ((tag (header-entry-tag entry)) + (count (header-entry-count entry)) + (value (header-entry-value entry)) + (number (rpm-tag-number tag)) + (type (rpm-tag-type tag))) + (cond + ((= STRING type) + (unless (string? value) + (error "expected string value for STRING type, got" value)) + (unless (= 1 count) + (error "count must be 1 for STRING type")) + (let ((value (cond ((= (rpm-tag-number RPMTAG_VERSION) number) + ;; Hyphens are not allowed in version strings. + (string-map (match-lambda + (#\- #\+) + (c c)) + value)) + (else value)))) + (append (bytevector->u8-list (string->utf8 value)) + (list 0)))) ;strings must end with null byte + ((= STRING_ARRAY type) + (unless (list? value) + (error "expected a list of strings for STRING_ARRAY type, got" value)) + (unless (= count (length value)) + (error "expected count to be equal to" (length value) 'got count)) + (append-map (lambda (s) + (append (bytevector->u8-list (string->utf8 s)) + (list 0))) ;null byte separated + value)) + ((member type (list INT8 INT16 INT32)) + (if (= 1 count) + (unless (number? value) + (error "expected number value for scalar INT type; got" value)) + (unless (list? value) + (error "expected list value for array INT type; got" value))) + (if (list? value) + (cond ((= INT8 type) value) + ((= INT16 type) (append-map u16-number->u8-list value)) + ((= INT32 type) (append-map u32-number->u8-list value)) + (else (error "unexpected type" type))) + (cond ((= INT8 type) (list value)) + ((= INT16 type) (u16-number->u8-list value)) + ((= INT32 type) (u32-number->u8-list value)) + (else (error "unexpected type" type))))) + ((= BIN type) + (unless (list? value) + (error "expected list value for BIN type; got" value)) + value) + (else (error "unimplemented type" type))))) + +(define (make-header-index+data entries) + "Return the index and data sections as u8 number lists, via multiple values. +An index is composed of four u32 (16 bytes total) quantities, in order: tag, +type, offset and count." + (match (fold (match-lambda* + ((entry (offset . (index . data))) + (let* ((tag (header-entry-tag entry)) + (tag-number (rpm-tag-number tag)) + (tag-type (rpm-tag-type tag)) + (count (header-entry-count entry)) + (data* (header-entry->data entry)) + (alignment (entry-type->alignement tag-type)) + (aligned-offset (next-aligned-offset offset alignment)) + (padding (make-list (- aligned-offset offset) 0))) + (cons (+ aligned-offset (length data*)) + (cons (append index + (u32-number->u8-list tag-number) + (u32-number->u8-list tag-type) + (u32-number->u8-list aligned-offset) + (u32-number->u8-list count)) + (append data padding data*)))))) + '(0 . (() . ())) + entries) + ((offset . (index . data)) + (values index data)))) + +;; Prevent inlining of the variables/procedures accessed by unit tests. +(set! make-header-index+data make-header-index+data) +(set! RPMTAG_ARCH RPMTAG_ARCH) +(set! RPMTAG_LICENSE RPMTAG_LICENSE) +(set! RPMTAG_NAME RPMTAG_NAME) +(set! RPMTAG_OS RPMTAG_OS) +(set! RPMTAG_RELEASE RPMTAG_RELEASE) +(set! RPMTAG_SUMMARY RPMTAG_SUMMARY) +(set! RPMTAG_VERSION RPMTAG_VERSION) + +(define (wrap-in-region-tags header region-tag) + "Wrap HEADER, a header provided as u8-list with REGION-TAG." + (let* ((type (rpm-tag-type region-tag)) + (header-intro (take header 16)) + (header-rest (drop header 16)) + ;; Increment the existing index value to account for the added region + ;; tag index. + (index-length (1+ (u8-list->u32-number + (drop-right (drop header-intro 8) 4)))) ;bytes 8-11 + ;; Increment the data length value to account for the added region + ;; tag data. + (data-length (+ REGION_TAG_COUNT + (u8-list->u32-number + (take-right header-intro 4))))) ;last 4 bytes of intro + (unless (member region-tag (list RPMTAG_HEADERSIGNATURES + RPMTAG_HEADERIMMUTABLE)) + (error "expected RPMTAG_HEADERSIGNATURES or RPMTAG_HEADERIMMUTABLE, got" + region-tag)) + (append (drop-right header-intro 8) ;strip existing index and data lengths + (u32-number->u8-list index-length) + (u32-number->u8-list data-length) + ;; Region tag (16 bytes). + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (u32-number->u8-list (- data-length REGION_TAG_COUNT)) ;offset + (u32-number->u8-list REGION_TAG_COUNT) ;count + ;; Immutable region. + header-rest + ;; Region tag trailer (16 bytes). Note: the trailer offset value + ;; is an enforced convention; it has no practical use. + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (s32-number->u8-list (* -1 index-length 16)) ;negative offset + (u32-number->u8-list REGION_TAG_COUNT)))) ;count + +(define (bytevector->hex-string bv) + (format #f "~{~2,'0x~}" (bytevector->u8-list bv))) + +(define (files->md5-checksums files) + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." + (let ((file-md5 (cut file-hash (hash-algorithm md5) <>))) + (map (lambda (f) + (or (and=> (false-if-exception (file-md5 f)) + bytevector->hex-string) + ;; Only regular files (e.g., not directories) can have their + ;; checksum computed. + "")) + files))) + +(define (strip-leading-dot name) + "Remove the leading \".\" from NAME, if present. If a single \".\" is +encountered, translate it to \"/\"." + (match name + ("." "/") ;special case + ((? (cut string-prefix? "." <>)) + (string-drop name 1)) + (x name))) + +;;; An extensive list of required and optional FHS directories, per its 3.0 +;;; revision. +(define %fhs-directories + (list "/bin" "/boot" "/dev" + "/etc" "/etc/opt" "/etc/X11" "/etc/sgml" "/etc/xml" + "/home" "/root" "/lib" "/media" "/mnt" + "/opt" "/opt/bin" "/opt/doc" "/opt/include" + "/opt/info" "/opt/lib" "/opt/man" + "/run" "/sbin" "/srv" "/sys" "/tmp" + "/usr" "/usr/bin" "/usr/include" "/usr/libexec" + "/usr/share/color" "/usr/share/dict" "/usr/share/doc" "/usr/share/games" + "/usr/share/info" "/usr/share/locale" "/usr/share/man" "/usr/share/misc" + "/usr/share/nls" "/usr/share/ppd" "/usr/share/sgml" + "/usr/share/terminfo" "/usr/share/tmac" "/usr/share/xml" + "/usr/share/zoneinfo" "/usr/local" "/usr/local/bin" "/usr/local/etc" + "/usr/local/games" "/usr/local/include" "/usr/local/lib" + "/usr/local/man" "/usr/local/sbin" "/usr/local/sbin" "/usr/local/share" + "/usr/local/src" "/var" "/var/account" "/var/backups" + "/var/cache" "/var/cache/fonts" "/var/cache/man" "/var/cache/www" + "/var/crash" "/var/cron" "/var/games" "/var/mail" "/var/msgs" + "/var/lib" "/var/lib/color" "/var/lib/hwclock" "/var/lib/misc" + "/var/local" "/var/lock" "/var/log" "/var/opt" "/var/preserve" + "/var/run" "/var/spool" "/var/spool/lpd" "/var/spool/mqueue" + "/var/spool/news" "/var/spool/rwho" "/var/spool/uucp" + "/var/tmp" "/var/yp")) + +(define (fhs-directory? file-name) + "Predicate to check if FILE-NAME is a known File Hierarchy Standard (FHS) +directory." + (member (strip-leading-dot file-name) %fhs-directories)) + +(define (directory->file-entries directory) + "Return the file lists triplet header entries for the files found under +DIRECTORY." + (with-directory-excursion directory + ;; Skip the initial "." directory, as its name would get concatenated with + ;; the "./" dirname and fail to match "." in the payload. + (let* ((files (cdr (find-files "." #:directories? #t))) + (file-stats (map lstat files)) + (directories + (append (list ".") + (filter-map (match-lambda + ((index . file) + (let ((st (list-ref file-stats index))) + (and (eq? 'directory (stat:type st)) + file)))) + (list-transduce (tenumerate) rcons files)))) + ;; Omit any FHS directories found in FILES to avoid the RPM package + ;; from owning them. This can occur when symlinks directives such + ;; as "/usr/bin/hello -> bin/hello" are used. + (package-files package-file-stats + (unzip2 (reverse + (fold (lambda (file stat res) + (if (fhs-directory? file) + res + (cons (list file stat) res))) + '() files file-stats)))) + + ;; When provided with the index of a file, the directory index must + ;; return the index of the corresponding directory entry. + (dirindexes (map (lambda (d) + (list-index (cut string=? <> d) directories)) + (map dirname package-files))) + ;; The files owned are those appearing in 'basenames'; own them + ;; all. + (basenames (map basename package-files)) + ;; The directory names must end with a trailing "/". + (dirnames (map (compose strip-leading-dot (cut string-append <> "/")) + directories)) + ;; Note: All the file-related entries must have the same length as + ;; the basenames entry. + (symlink-targets (map (lambda (f) + (if (symbolic-link? f) + (readlink f) + "")) ;unused + package-files)) + (file-modes (map stat:mode package-file-stats)) + (file-sizes (map stat:size package-file-stats)) + (file-md5s (files->md5-checksums package-files))) + (let ((basenames-length (length basenames)) + (dirindexes-length (length dirindexes))) + (unless (= basenames-length dirindexes-length) + (error "length mismatch for dirIndexes; expected/actual" + basenames-length dirindexes-length)) + (append + (if (> (apply max file-sizes) INT32_MAX) + (list (make-header-entry RPMTAG_LONGFILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_LONGSIZE 1 + (reduce + 0 file-sizes))) + (list (make-header-entry RPMTAG_FILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_SIZE 1 (reduce + 0 file-sizes)))) + (list + (make-header-entry RPMTAG_FILEMODES (length file-modes) file-modes) + (make-header-entry RPMTAG_FILEDIGESTS (length file-md5s) file-md5s) + (make-header-entry RPMTAG_FILEDIGESTALGO 1 RPM_HASH_MD5) + (make-header-entry RPMTAG_FILELINKTOS (length symlink-targets) + symlink-targets) + (make-header-entry RPMTAG_FILEUSERNAME basenames-length + (make-list basenames-length "root")) + (make-header-entry RPMTAG_GROUPNAME basenames-length + (make-list basenames-length "root")) + ;; The dirindexes, basenames and dirnames tags form the so-called RPM + ;; "path triplet". + (make-header-entry RPMTAG_DIRINDEXES dirindexes-length dirindexes) + (make-header-entry RPMTAG_BASENAMES basenames-length basenames) + (make-header-entry RPMTAG_DIRNAMES (length dirnames) dirnames))))))) + +(define (make-header entries) + "Return the u8 list of a RPM header containing ENTRIES, a list of +<rpm-entry> objects." + (let* ((entries (sort entries (lambda (x y) + (< (rpm-tag-number (header-entry-tag x)) + (rpm-tag-number (header-entry-tag y)))))) + (count (length entries)) + (index data (make-header-index+data entries))) + (append header-intro ;8 bytes + (u32-number->u8-list count) ;4 bytes + (u32-number->u8-list (length data)) ;4 bytes + ;; Now starts the header index, which can contain up to 32 entries + ;; of 16 bytes each. + index data))) + +(define* (generate-header name version + payload-digest + payload-directory + payload-compressor + #:key + relocatable? + prein-file postin-file + preun-file postun-file + (target %host-type) + (release "0") + (license "N/A") + (summary "RPM archive generated by GNU Guix.") + (os "Linux")) ;see rpmrc.in + "Return the u8 list corresponding to the Header section. PAYLOAD-DIGEST is +the SHA256 checksum string of the compressed payload. PAYLOAD-DIRECTORY is +the directory containing the payload files. PAYLOAD-COMPRESSOR is the name of +the compressor used to compress the CPIO payload, such as \"none\", \"gz\", +\"xz\" or \"zstd\"." + (let* ((rpm-arch (gnu-machine-type->rpm-arch + (gnu-system-triplet->machine-type target))) + (file->string (cut call-with-input-file <> get-string-all)) + (prein-script (and=> prein-file file->string)) + (postin-script (and=> postin-file file->string)) + (preun-script (and=> preun-file file->string)) + (postun-script (and=> postun-file file->string))) + (wrap-in-region-tags + (make-header (append + (list (make-header-entry RPMTAG_HEADERI18NTABLE 1 (list "C")) + (make-header-entry RPMTAG_NAME 1 name) + (make-header-entry RPMTAG_VERSION 1 version) + (make-header-entry RPMTAG_RELEASE 1 release) + (make-header-entry RPMTAG_SUMMARY 1 summary) + (make-header-entry RPMTAG_LICENSE 1 license) + (make-header-entry RPMTAG_OS 1 os) + (make-header-entry RPMTAG_ARCH 1 rpm-arch)) + (directory->file-entries payload-directory) + (if relocatable? + ;; Note: RPMTAG_PREFIXES must not have a trailing + ;; slash, unless it's '/'. This allows installing the + ;; package via 'rpm -i --prefix=/tmp', for example. + (list (make-header-entry RPMTAG_PREFIXES 1 (list "/"))) + '()) + (if prein-script + (list (make-header-entry RPMTAG_PREIN 1 prein-script)) + '()) + (if postin-script + (list (make-header-entry RPMTAG_POSTIN 1 postin-script)) + '()) + (if preun-script + (list (make-header-entry RPMTAG_PREUN 1 preun-script)) + '()) + (if postun-script + (list (make-header-entry RPMTAG_POSTUN 1 postun-script)) + '()) + (if (string=? "none" payload-compressor) + '() + (list (make-header-entry RPMTAG_PAYLOADCOMPRESSOR 1 + payload-compressor))) + (list (make-header-entry RPMTAG_ENCODING 1 "utf-8") + (make-header-entry RPMTAG_PAYLOADFORMAT 1 "cpio") + (make-header-entry RPMTAG_PAYLOADDIGEST 1 + (list payload-digest)) + (make-header-entry RPMTAG_PAYLOADDIGESTALGO 1 + RPM_HASH_SHA256)))) + RPMTAG_HEADERIMMUTABLE))) + +\f +;;; +;;; Signature section +;;; + +;;; Header sha256 checksum. +(define RPMSIGTAG_SHA256 (make-rpm-tag 273 STRING)) +;;; Uncompressed payload size. +(define RPMSIGTAG_PAYLOADSIZE (make-rpm-tag 1007 INT32)) +;;; Header and compressed payload combined size. +(define RPMSIGTAG_SIZE (make-rpm-tag 1000 INT32)) +;;; Uncompressed payload size (when size > max u32). +(define RPMSIGTAG_LONGARCHIVESIZE (make-rpm-tag 271 INT64)) +;;; Header and compressed payload combined size (when size > max u32). +(define RPMSIGTAG_LONGSIZE (make-rpm-tag 270 INT64)) +;;; Extra space reserved for signatures (typically 32 bytes). +(define RPMSIGTAG_RESERVEDSPACE (make-rpm-tag 1008 BIN)) + +(define (generate-signature header-sha256 + header+compressed-payload-size + ;; uncompressed-payload-size + ) + "Return the u8 list representing a signature header containing the +HEADER-SHA256 (a string) and the PAYLOAD-SIZE, which is the combined size of +the header and compressed payload." + (define size-tag (if (> header+compressed-payload-size INT32_MAX) + RPMSIGTAG_LONGSIZE + RPMSIGTAG_SIZE)) + (wrap-in-region-tags + (make-header (list (make-header-entry RPMSIGTAG_SHA256 1 header-sha256) + (make-header-entry size-tag 1 + header+compressed-payload-size) + ;; (make-header-entry RPMSIGTAG_PAYLOADSIZE 1 + ;; uncompressed-payload-size) + ;; Reserve 32 bytes of extra space in case users would + ;; like to add signatures, as done in rpmGenerateSignature. + (make-header-entry RPMSIGTAG_RESERVEDSPACE 32 + (make-list 32 0)))) + RPMTAG_HEADERSIGNATURES)) + +(define (assemble-rpm-metadata lead signature header) + "Align and append the various u8 list components together, and return the +result as a bytevector." + (let* ((offset (+ (length lead) (length signature))) + (header-offset (next-aligned-offset offset 8)) + (padding (make-list (- header-offset offset) 0))) + ;; The Header is 8-bytes aligned. + (u8-list->bytevector (append lead signature padding header)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7a5fb9bd0d..b56c7d7f80 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; @@ -67,6 +67,7 @@ (define-module (guix scripts pack) self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -865,6 +866,163 @@ (define tar (string-append #+archiver "/bin/tar")) \f ;;; +;;; RPM archive format. +;;; +(define* (rpm-archive name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (first %compressors)) + deduplicate? + localstatedir? + (symlinks '()) + archiver + (extra-options '())) + "Return a RPM archive (.rpm) containing a store initialized with the closure +of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be +a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack. +ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE, +PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." + (define relocatable? (keyword-ref extra-options #:relocatable?)) + (define prein-file (keyword-ref extra-options #:prein-file)) + (define postin-file (keyword-ref extra-options #:postin-file)) + (define preun-file (keyword-ref extra-options #:preun-file)) + (define postun-file (keyword-ref extra-options #:postun-file)) + + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (define payload + (let* ((raw-cpio-file-name "payload.cpio") + (compressed-cpio-file-name (string-append raw-cpio-file-name + (compressor-extension + compressor)))) + (computed-file compressed-cpio-file-name + (with-imported-modules (source-module-closure + '((guix build utils) + (guix cpio) + (guix rpm))) + #~(begin + (use-modules (guix build utils) + (guix cpio) + (guix rpm) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define %root (if #$localstatedir? "." #$root)) + + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion %root + ;; The first "." entry is discarded. + (write-cpio-archive + (remove fhs-directory? + (cdr (find-files "." #:directories? #t))) + port)))) + (when #+(compressor-command compressor) + (apply invoke (append #+(compressor-command compressor) + (list #$raw-cpio-file-name)))) + (copy-file #$compressed-cpio-file-name #$output))) + #:local-build? #f))) ;allow offloading + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm)) + #:select? not-config?)) + #~(begin + (use-modules (gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm) + (ice-9 binary-ports) + (ice-9 match) ;for manifest->friendly-name + (rnrs bytevectors) + (srfi srfi-1)) + + (define machine-type + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (_ #f))) + + (define name (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define version (or (and=> single-entry manifest-entry-version) + "0.0.0")) + + (define lead (generate-lead (string-append name "-" version) + #:target (or #$target %host-type))) + + (define payload-digest (bytevector->hex-string + (file-sha256 #$payload))) + + (define header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? #$relocatable? + #:prein-file #$prein-file + #:postin-file #$postin-file + #:preun-file #$preun-file + #:postun-file #$postun-file)) + + (define header-sha256 (bytevector->hex-string + (sha256 (u8-list->bytevector header)))) + + (define payload-size (stat:size (stat #$payload))) + + (define header+compressed-payload-size (+ (length header) + payload-size)) + + (define signature (generate-signature + header-sha256 + header+compressed-payload-size)) + + ;; Serialize the archive components to a file. + (call-with-input-file #$payload + (lambda (in) + (call-with-output-file #$output + (lambda (out) + (put-bytevector out (assemble-rpm-metadata lead + signature + header)) + (sendfile out in payload-size))))))))) + + (gexp->derivation (string-append name ".rpm") build)) + + \f +;;; ;;; Compiling C programs. ;;; @@ -1196,7 +1354,8 @@ (define %formats `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) - (deb . ,debian-archive))) + (deb . ,debian-archive) + (rpm . ,rpm-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -1210,18 +1369,22 @@ (define (show-formats) docker Tarball ready for 'docker load'")) (display (G_ " deb Debian archive installable via dpkg/apt")) + (display (G_ " + rpm RPM archive installable via rpm/yum")) (newline)) +(define (required-option symbol) + "Return an SYMBOL option that requires a value." + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))) + (define %deb-format-options - (let ((required-option (lambda (symbol) - (option (list (symbol->string symbol)) #t #f - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest)))))) - (list (required-option 'control-file) - (required-option 'postinst-file) - (required-option 'triggers-file)))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file))) (define (show-deb-format-options) (display (G_ " @@ -1240,6 +1403,32 @@ (define (show-deb-format-options/detailed) (newline) (exit 0)) +(define %rpm-format-options + (list (required-option 'prein-file) + (required-option 'postin-file) + (required-option 'preun-file) + (required-option 'postun-file))) + +(define (show-rpm-format-options) + (display (G_ " + --help-rpm-format list options specific to the RPM format"))) + +(define (show-rpm-format-options/detailed) + (display (G_ " + --prein-file=FILE + Embed the provided prein script")) + (display (G_ " + --postin-file=FILE + Embed the provided postin script")) + (display (G_ " + --preun-file=FILE + Embed the provided preun script")) + (display (G_ " + --postun-file=FILE + Embed the provided postun script")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1316,7 +1505,12 @@ (define %options (lambda args (show-deb-format-options/detailed))) + (option '("help-rpm-format") #f #f + (lambda args + (show-rpm-format-options/detailed))) + (append %deb-format-options + %rpm-format-options %transformation-options %standard-build-options %standard-cross-build-options @@ -1334,6 +1528,7 @@ (define (show-help) (show-transformation-options-help) (newline) (show-deb-format-options) + (show-rpm-format-options) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) @@ -1492,6 +1687,16 @@ (define (process-file-arg opts name) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable? + #:prein-file + (process-file-arg opts 'prein-file) + #:postin-file + (process-file-arg opts 'postin-file) + #:preun-file + (process-file-arg opts 'preun-file) + #:postun-file + (process-file-arg opts 'postun-file))) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/tests/pack.scm b/tests/pack.scm index 2e3b9d0ca4..0708f8dfd5 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,13 +28,16 @@ (define-module (test-pack) #:use-module (guix tests) #:use-module (guix gexp) #:use-module (guix modules) + #:use-module (guix utils) #:use-module (gnu packages) #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages package-management) #:select (rpm)) #:use-module ((gnu packages compression) #:select (squashfs-tools)) #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages linux) #:select (fakeroot)) #:use-module (srfi srfi-64)) (define %store @@ -59,6 +62,17 @@ (define %tar-bootstrap %bootstrap-coreutils&co) (define %ar-bootstrap %bootstrap-binutils) +;;; This is a variant of the RPM package configured so that its database can +;;; be created on a writable location readily available inside the build +;;; container ("/tmp"). +(define rpm-for-tests + (package + (inherit rpm) + (arguments (substitute-keyword-arguments (package-arguments rpm) + ((#:configure-flags flags '()) + #~(cons "--localstatedir=/tmp" + (delete "--localstatedir=/var" #$flags))))))) + \f (test-begin "pack") @@ -360,6 +374,47 @@ (define hard-links (stat "postinst")))))) (assert (file-exists? "triggers")) + (mkdir #$output)))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "rpm archive can be installed/uninstalled" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (rpm-pack (rpm-archive "rpm-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/bin/guile" -> "bin/guile")) + #:extra-options '(#:relocatable? #t))) + (check + (gexp->derivation "check-rpm-pack" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install the RPM package. This causes RPM to validate the + ;; signatures, header as well as the file digests, which + ;; makes it a rather thorough test. + (mkdir "test-prefix") + (invoke fakeroot rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; Invoke the installed Guile command. + (invoke "./test-prefix/bin/guile" "--version") + + ;; Uninstall the RPM package. + (invoke fakeroot rpm "--erase" "guile-bootstrap") + + ;; Required so the above is run. (mkdir #$output)))))) (built-derivations (list check))))) diff --git a/tests/rpm.scm b/tests/rpm.scm new file mode 100644 index 0000000000..f40b36fe60 --- /dev/null +++ b/tests/rpm.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-rpm) + #:use-module (guix rpm) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71)) + +;; For white-box testing. +(define-syntax-rule (expose-internal name) + (define name (@@ (guix rpm) name))) + +(expose-internal RPMTAG_ARCH) +(expose-internal RPMTAG_LICENSE) +(expose-internal RPMTAG_NAME) +(expose-internal RPMTAG_OS) +(expose-internal RPMTAG_RELEASE) +(expose-internal RPMTAG_SUMMARY) +(expose-internal RPMTAG_VERSION) +(expose-internal header-entry-count) +(expose-internal header-entry-tag) +(expose-internal header-entry-value) +(expose-internal header-entry?) +(expose-internal make-header) +(expose-internal make-header-entry) +(expose-internal make-header-index+data) + +(test-begin "rpm") + +(test-equal "lead must be 96 bytes long" + 96 + (length (generate-lead "hello-2.12.1"))) + +(define header-entries + (list (make-header-entry RPMTAG_NAME 1 "hello") + (make-header-entry RPMTAG_VERSION 1 "2.12.1") + (make-header-entry RPMTAG_RELEASE 1 "0") + (make-header-entry RPMTAG_SUMMARY 1 + "Hello, GNU world: An example GNU package") + (make-header-entry RPMTAG_LICENSE 1 "GPL 3 or later") + (make-header-entry RPMTAG_OS 1 "Linux") + (make-header-entry RPMTAG_ARCH 1 "x86_64"))) + +(define expected-header-index-length + (* 16 (length header-entries))) ;16 bytes per index entry + +(define expected-header-data-length + (+ (length header-entries) ;to account for null bytes + (fold + 0 (map (compose string-length (cut header-entry-value <>)) + header-entries)))) + +(let ((index data (make-header-index+data header-entries))) + (test-equal "header index" + expected-header-index-length + (length index)) + + ;; This test depends on the fact that only STRING entries are used, and that + ;; they are composed of single byte characters and the delimiting null byte. + (test-equal "header data" + expected-header-data-length + (length data))) + +(test-equal "complete header section" + (+ 16 ;leading magic + count bytes + expected-header-index-length expected-header-data-length) + (length (make-header header-entries))) + +(test-end) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-03 22:14 ` [bug#61255] [PATCH 5/5] pack: Add RPM format Maxim Cournoyer @ 2023-02-12 18:52 ` Ludovic Courtès 2023-02-16 22:17 ` Maxim Cournoyer 0 siblings, 1 reply; 31+ messages in thread From: Ludovic Courtès @ 2023-02-12 18:52 UTC (permalink / raw) To: Maxim Cournoyer Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hey! Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > * guix/rpm.scm: New file. > * guix/scripts/pack.scm (rpm-archive): New procedure. > (%formats): Register it. > (show-formats): Add it. > (guix-pack): Register supported extra-options for the rpm format. > * tests/pack.scm (rpm-for-tests): New variable. > ("rpm archive can be installed/uninstalled"): New test. > * tests/rpm.scm: New test. > * doc/guix.texi (Invoking guix pack): Document it. (‘Makefile.am’ changes are missing here.) Woow, there’s a lot of fun stuff in here! :-) Nice work! Perhaps we’ll soon see Guix-generated RPMs for, say, Jami? :-) Overall it looks great to me. Perhaps you should submit an ‘etc/news.scm’ entry here so that translators can work on it before it’s eventually pushed (I think that’s the workflow Julien proposed). Some comments follow: > +@cindex Debian, build a .deb package with guix pack @file{.deb} and @command{guix pack} > +The RPM format supports relocatable packages via the @option{--prefix} > +option of the @command{rpm} command, which can be handy to install an > +RPM package to a specific prefix, making installing multiple > +Guix-produced RPM packages side by side possible. > + > +@example > +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello > +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm > +@end example Perhaps use two different @example boxes to distinguish between the Guix machine that produces the RPM, and the RPM-based system that installs it? > +@quotation Note > +Similarly to Debian packages, two RPM packages with conflicting files > +cannot be installed simultaneously. Contrary to Debian packages, RPM > +supports relocatable packages, so file conflicts can be avoided by > +installing the RPM packages under different installation prefixes, as > +shown in the above example. So for relocatable packages, one really needs ‘guix pack -R’ IIUC. Interesting. > +;;; Commentary: > +;;; > +;;; This module provides the building blocks required to construct RPM > +;;; archives. It is intended to be importable on the build side, so shouldn't > +;;; depend on (guix diagnostics) or other host-side-only modules. > + > +(define-module (guix rpm) The commentary should be followed by “Code:” and it should come after the ‘define-module’ form. That way, (ice-9 documentation) can find it. > +(define (make-header-index+data entries) > + "Return the index and data sections as u8 number lists, via multiple values. > +An index is composed of four u32 (16 bytes total) quantities, in order: tag, > +type, offset and count." > + (match (fold (match-lambda* > + ((entry (offset . (index . data))) > + (let* ((tag (header-entry-tag entry)) > + (tag-number (rpm-tag-number tag)) > + (tag-type (rpm-tag-type tag)) > + (count (header-entry-count entry)) > + (data* (header-entry->data entry)) > + (alignment (entry-type->alignement tag-type)) > + (aligned-offset (next-aligned-offset offset alignment)) > + (padding (make-list (- aligned-offset offset) 0))) > + (cons (+ aligned-offset (length data*)) > + (cons (append index > + (u32-number->u8-list tag-number) > + (u32-number->u8-list tag-type) > + (u32-number->u8-list aligned-offset) > + (u32-number->u8-list count)) > + (append data padding data*)))))) I think it would be possible (throughout the code) to avoid building lists of bytes and instead directly produce bytevectors or, better, produce procedures that write bytes directly to an output port (with macros along the lines of ‘define-operation’ in (guix store) or ‘define-pack’ in (guix cpio)). I don’t think it should be a blocker though, it’s okay to keep it this way. > +(define (files->md5-checksums files) > + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." Does it have to be MD5? If RPM supports SHA1 or SHA2*, it would be best to pick one of these; MD5 is okay to detect unintended modifications, but it’s useless if we care about malicious tampering. > + (define name (or (and=> single-entry manifest-entry-name) > + (manifest->friendly-name manifest))) > + > + (define version (or (and=> single-entry manifest-entry-version) > + "0.0.0")) > + > + (define lead (generate-lead (string-append name "-" version) > + #:target (or #$target %host-type))) > + > + (define payload-digest (bytevector->hex-string > + (file-sha256 #$payload))) Nitpick: the convention usually followed is to write the value, when it’s long enough as is the case here, on the next line, as in: (define something value-thats-a-little-bit-long) > + (unless store (test-skip 1)) > + (test-assertm "rpm archive can be installed/uninstalled" store Really cool to have a full-blown test like this. > +(define-module (test-rpm) > + #:use-module (guix rpm) That too! Thanks, Ludo’. ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-12 18:52 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès @ 2023-02-16 22:17 ` Maxim Cournoyer 0 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-16 22:17 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hi again! Ludovic Courtès <ludo@gnu.org> writes: > Hey! > > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> * guix/rpm.scm: New file. >> * guix/scripts/pack.scm (rpm-archive): New procedure. >> (%formats): Register it. >> (show-formats): Add it. >> (guix-pack): Register supported extra-options for the rpm format. >> * tests/pack.scm (rpm-for-tests): New variable. >> ("rpm archive can be installed/uninstalled"): New test. >> * tests/rpm.scm: New test. >> * doc/guix.texi (Invoking guix pack): Document it. > > (‘Makefile.am’ changes are missing here.) > > Woow, there’s a lot of fun stuff in here! :-) Nice work! > > Perhaps we’ll soon see Guix-generated RPMs for, say, Jami? :-) Thanks! Yes, Guix-baked RPMs to the packaging pipeline of Jami was the motivator; in theory maintaining just "One Way" of packaging things (Guix) should now allow covering all the systems that Jami currently targets (and more). > Overall it looks great to me. Great! > Perhaps you should submit an ‘etc/news.scm’ entry here so that > translators can work on it before it’s eventually pushed (I think that’s > the workflow Julien proposed). Done, although I'm weary of forgetting to update the commit (I guess make check-news would catch this though). > Some comments follow: > >> +@cindex Debian, build a .deb package with guix pack > > @file{.deb} and @command{guix pack} I thought cindex text shouldn't be decorated, no? >> +The RPM format supports relocatable packages via the @option{--prefix} >> +option of the @command{rpm} command, which can be handy to install an >> +RPM package to a specific prefix, making installing multiple >> +Guix-produced RPM packages side by side possible. >> + >> +@example >> +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello >> +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm >> +@end example > > Perhaps use two different @example boxes to distinguish between the Guix > machine that produces the RPM, and the RPM-based system that installs > it? Technically, the above can run on your Guix System if you 'mkdir /var/lib/rpm && chown $USER /var/lib/rpm' :-). That's what I used while developing. But I've separated the box, as the common and recommended use case is to install these on non-Guix systems. >> +@quotation Note >> +Similarly to Debian packages, two RPM packages with conflicting files >> +cannot be installed simultaneously. Contrary to Debian packages, RPM >> +supports relocatable packages, so file conflicts can be avoided by >> +installing the RPM packages under different installation prefixes, as >> +shown in the above example. > > So for relocatable packages, one really needs ‘guix pack -R’ IIUC. > Interesting. Indeed. If you try to use rpm's --relocate without having passed -R, it'll fail and tell you the package is not relocatable. >> +;;; Commentary: >> +;;; >> +;;; This module provides the building blocks required to construct RPM >> +;;; archives. It is intended to be importable on the build side, so shouldn't >> +;;; depend on (guix diagnostics) or other host-side-only modules. >> + >> +(define-module (guix rpm) > > The commentary should be followed by “Code:” and it should come after > the ‘define-module’ form. That way, (ice-9 documentation) can find it. Thanks. I didn't know that, or the reason it was this way. >> +(define (make-header-index+data entries) >> + "Return the index and data sections as u8 number lists, via multiple values. >> +An index is composed of four u32 (16 bytes total) quantities, in order: tag, >> +type, offset and count." >> + (match (fold (match-lambda* >> + ((entry (offset . (index . data))) >> + (let* ((tag (header-entry-tag entry)) >> + (tag-number (rpm-tag-number tag)) >> + (tag-type (rpm-tag-type tag)) >> + (count (header-entry-count entry)) >> + (data* (header-entry->data entry)) >> + (alignment (entry-type->alignement tag-type)) >> + (aligned-offset (next-aligned-offset offset alignment)) >> + (padding (make-list (- aligned-offset offset) 0))) >> + (cons (+ aligned-offset (length data*)) >> + (cons (append index >> + (u32-number->u8-list tag-number) >> + (u32-number->u8-list tag-type) >> + (u32-number->u8-list aligned-offset) >> + (u32-number->u8-list count)) >> + (append data padding data*)))))) > > I think it would be possible (throughout the code) to avoid building > lists of bytes and instead directly produce bytevectors or, better, > produce procedures that write bytes directly to an output port (with > macros along the lines of ‘define-operation’ in (guix store) or > ‘define-pack’ in (guix cpio)). > > I don’t think it should be a blocker though, it’s okay to keep it this > way. OK. I pondered about the API, but in the end it seems more malleable to keep everything in an list "intermediate representation", as I could stitch it together at a later point and more easily inspect things in tests. >> +(define (files->md5-checksums files) >> + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." > > Does it have to be MD5? If RPM supports SHA1 or SHA2*, it would be best > to pick one of these; MD5 is okay to detect unintended modifications, > but it’s useless if we care about malicious tampering. We can choose the algorithm, but MD5 is still the default in the latest RPM version. These are intended to detect simple data corruption. >> + (define name (or (and=> single-entry manifest-entry-name) >> + (manifest->friendly-name manifest))) >> + >> + (define version (or (and=> single-entry manifest-entry-version) >> + "0.0.0")) >> + >> + (define lead (generate-lead (string-append name "-" version) >> + #:target (or #$target %host-type))) >> + >> + (define payload-digest (bytevector->hex-string >> + (file-sha256 #$payload))) > > Nitpick: the convention usually followed is to write the value, when > it’s long enough as is the case here, on the next line, as in: Oh, OK! I hadn't noticed, adjusted. > (define something > value-thats-a-little-bit-long) > >> + (unless store (test-skip 1)) >> + (test-assertm "rpm archive can be installed/uninstalled" store > > Really cool to have a full-blown test like this. > >> +(define-module (test-rpm) >> + #:use-module (guix rpm) > > That too! > > Thanks, > Ludo’. Thanks for taking the time to review this! The changes implemented will appear in v2. -- Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer ` (3 preceding siblings ...) 2023-02-03 22:14 ` [bug#61255] [PATCH 5/5] pack: Add RPM format Maxim Cournoyer @ 2023-02-12 18:57 ` Ludovic Courtès 2023-02-16 15:25 ` Maxim Cournoyer 4 siblings, 1 reply; 31+ messages in thread From: Ludovic Courtès @ 2023-02-12 18:57 UTC (permalink / raw) To: Maxim Cournoyer Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > Rationale: the upcoming rpm-archive builder will also use it. > > * guix/scripts/pack.scm: > (keyword-ref): New top-level procedure, extracted from... > (debian-archive): ... here. Adjust usages accordingly. Commit aeded14b8342c1e72afd014a1bc121770f8c3a1c added #:extra-options, which is why we need ‘keyword-ref’ now. I’m thinking a different option would be to use #:allow-other-keys in all the image build procedures. That way the deb and rpm build procedures would get their extra arguments, which would be automatically bound without requiring manual ‘keyword-ref’ calls. Sounds a bit nicer maybe? If we skip to the current approach, we should consider using ‘let-keywords’ from (ice-9 optargs) instead of adding ‘keyword-ref’. Anyway, not a blocker IMO, but something to keep in mind. Ludo’. ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" 2023-02-12 18:57 ` Ludovic Courtès @ 2023-02-16 15:25 ` Maxim Cournoyer 0 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-16 15:25 UTC (permalink / raw) To: Ludovic Courtès Cc: Josselin Poiret, Christopher Baines, Simon Tournier, Mathieu Othacehe, Tobias Geerinckx-Rice, Ricardo Wurmus, 61255 Hi Ludovic, Ludovic Courtès <ludo@gnu.org> writes: > Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis: > >> Rationale: the upcoming rpm-archive builder will also use it. >> >> * guix/scripts/pack.scm: >> (keyword-ref): New top-level procedure, extracted from... >> (debian-archive): ... here. Adjust usages accordingly. > > Commit aeded14b8342c1e72afd014a1bc121770f8c3a1c added #:extra-options, > which is why we need ‘keyword-ref’ now. > > I’m thinking a different option would be to use #:allow-other-keys in > all the image build procedures. That way the deb and rpm build > procedures would get their extra arguments, which would be automatically > bound without requiring manual ‘keyword-ref’ calls. Sounds a bit nicer > maybe? I'm not sure; it sounds convenient, but at the same time, it makes the "contract" of the pack builders even fuzzier that it currently is. > If we skip to the current approach, we should consider using > ‘let-keywords’ from (ice-9 optargs) instead of adding ‘keyword-ref’. > > Anyway, not a blocker IMO, but something to keep in mind. OK! I'll try adapting to use (ice-9 optargs) for the next revision. -- Thanks, Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 0/8] Add support for the RPM format to "guix pack" 2023-02-03 16:19 [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 1/8] .dir-locals: Add let-keywords indentation rules Maxim Cournoyer ` (7 more replies) 1 sibling, 8 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, ludo, Christopher Baines, Julien Lepiller, Florian Pelz, Ricardo Wurmus, Thiago Jung Bauermann Hello, I've addressed most of Ludovic's comments in this v2 rework (thanks!). Below is the original cover letter. This series adds support for the RPM format to "guix pack", so that one can generate an RPM archive via e.g. "guix pack -f rpm hello", and install it on their favorite RPM-based GNU/Linux distribution. With the exception of the payload compression, the generation of the archive is fully handled in Scheme, which ended up being tricky, with the documentation about the RPM binary format being scarce. Most of the problems encountered were figured out stepping an 'rpm' command invocation in GDB, which felt a bit like reverse engineering! Anyway, the end result appears to work well and has few dependencies (compared to using 'rpmbuild', as most other projects do), so I think it was worth the effort. Thanks! Changes in v2: - New commit - Use let-keywords instead of custom keyword-ref - Better make use of the new indentation rule - Use let-keywords instead of custom keyword-ref - Adjust commentary block in (guix rpm) - Adjust long define indentation in (guix scripts pack) - Separate guix pack / rpm --install example blocks - New commit - New commit Maxim Cournoyer (8): .dir-locals: Add let-keywords indentation rules. pack: Use let-keywords instead of keyword-ref. gexp: computed-file: Honor %guile-for-build. pack: Extract populate-profile-root from self-contained-tarball/builder. tests: pack: Fix indentation. pack: Add RPM format. etc: Add a news entry snippet. news: Add entry for the new 'rpm' guix pack format. .dir-locals.el | 3 + Makefile.am | 2 + doc/guix.texi | 48 +- etc/news.scm | 17 +- etc/snippets/yas/scheme-mode/guix-news-entry | 9 + guix/gexp.scm | 6 +- guix/rpm.scm | 623 +++++++++++++++++++ guix/scripts/pack.scm | 555 ++++++++++++----- tests/pack.scm | 336 +++++----- tests/rpm.scm | 86 +++ 10 files changed, 1379 insertions(+), 306 deletions(-) create mode 100644 etc/snippets/yas/scheme-mode/guix-news-entry create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm base-commit: c1303a914c172dc80166be22389e7032c5ea5e09 -- 2.39.1 ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 1/8] .dir-locals: Add let-keywords indentation rules. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 2/8] pack: Use let-keywords instead of keyword-ref Maxim Cournoyer ` (6 subsequent siblings) 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255; +Cc: ludo, Maxim Cournoyer * .dir-locals.el (scheme-mode): Add let-keywords indentation rules. --- Changes in v2: - New commit .dir-locals.el | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.dir-locals.el b/.dir-locals.el index a331bde0f1..b8b0fec4ca 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -72,6 +72,9 @@ (eval . (put 'substitute* 'scheme-indent-function 1)) (eval . (put 'match-record 'scheme-indent-function 2)) + ;; TODO: Contribute these to Emacs' scheme-mode. + (eval . (put 'let-keywords 'scheme-indent-function 3)) + ;; 'modify-inputs' and its keywords. (eval . (put 'modify-inputs 'scheme-indent-function 1)) (eval . (put 'replace 'scheme-indent-function 1)) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 2/8] pack: Use let-keywords instead of keyword-ref. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 1/8] .dir-locals: Add let-keywords indentation rules Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 3/8] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer ` (5 subsequent siblings) 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, ludo, Christopher Baines, Ricardo Wurmus * guix/scripts/pack.scm: (debian-archive): Bind extra-options keyword arguments via let-keywords. --- Changes in v2: - Use let-keywords instead of custom keyword-ref guix/scripts/pack.scm | 97 ++++++++++++++++++++----------------------- 1 file changed, 44 insertions(+), 53 deletions(-) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f65642fb85..e552cb108a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -678,16 +678,15 @@ (define %valid-compressors '("gzip" "xz" "none")) (define data-tarball (computed-file (string-append "data.tar" (compressor-extension compressor)) - (self-contained-tarball/builder - profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:local-build? #f ;allow offloading - #:options (list #:references-graphs `(("profile" ,profile)) - #:target target))) + (self-contained-tarball/builder profile + #:profile-name profile-name + #:compressor compressor + #:localstatedir? localstatedir? + #:symlinks symlinks + #:archiver archiver) + #:local-build? #f ;allow offloading + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) (define build (with-extensions (list guile-gcrypt) @@ -702,6 +701,7 @@ (define build (guix build utils) (guix profiles) (ice-9 match) + (ice-9 optargs) (srfi srfi-1)) (define machine-type @@ -762,32 +762,23 @@ (define data-tarball-file-name (strip-store-file-name (copy-file #+data-tarball data-tarball-file-name) - (define (keyword-ref lst keyword) - (match (memq keyword lst) - ((_ value . _) value) - (#f #f))) - ;; Generate the control archive. - (define control-file - (keyword-ref '#$extra-options #:control-file)) - - (define postinst-file - (keyword-ref '#$extra-options #:postinst-file)) - - (define triggers-file - (keyword-ref '#$extra-options #:triggers-file)) - - (define control-tarball-file-name - (string-append "control.tar" - #$(compressor-extension compressor))) - - ;; Write the compressed control tarball. Only the control file is - ;; mandatory (see: 'man deb' and 'man deb-control'). - (if control-file - (copy-file control-file "control") - (call-with-output-file "control" - (lambda (port) - (format port "\ + (let-keywords '#$extra-options #f + ((control-file #f) + (postinst-file #f) + (triggers-file #f)) + + (define control-tarball-file-name + (string-append "control.tar" + #$(compressor-extension compressor))) + + ;; Write the compressed control tarball. Only the control file is + ;; mandatory (see: 'man deb' and 'man deb-control'). + (if control-file + (copy-file control-file "control") + (call-with-output-file "control" + (lambda (port) + (format port "\ Package: ~a Version: ~a Description: Debian archive generated by GNU Guix. @@ -797,28 +788,28 @@ (define control-tarball-file-name Section: misc ~%" package-name package-version architecture)))) - (when postinst-file - (copy-file postinst-file "postinst") - (chmod "postinst" #o755)) + (when postinst-file + (copy-file postinst-file "postinst") + (chmod "postinst" #o755)) - (when triggers-file - (copy-file triggers-file "triggers")) + (when triggers-file + (copy-file triggers-file "triggers")) - (define tar (string-append #+archiver "/bin/tar")) + (define tar (string-append #+archiver "/bin/tar")) - (apply invoke tar - `(,@(tar-base-options - #:tar tar - #:compressor #+(and=> compressor compressor-command)) - "-cvf" ,control-tarball-file-name - "control" - ,@(if postinst-file '("postinst") '()) - ,@(if triggers-file '("triggers") '()))) + (apply invoke tar + `(,@(tar-base-options + #:tar tar + #:compressor #+(and=> compressor compressor-command)) + "-cvf" ,control-tarball-file-name + "control" + ,@(if postinst-file '("postinst") '()) + ,@(if triggers-file '("triggers") '()))) - ;; Create the .deb archive using GNU ar. - (invoke (string-append #+binutils "/bin/ar") "-rv" #$output - "debian-binary" - control-tarball-file-name data-tarball-file-name))))) + ;; Create the .deb archive using GNU ar. + (invoke (string-append #+binutils "/bin/ar") "-rv" #$output + "debian-binary" + control-tarball-file-name data-tarball-file-name)))))) (gexp->derivation (string-append name ".deb") build -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 3/8] gexp: computed-file: Honor %guile-for-build. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 1/8] .dir-locals: Add let-keywords indentation rules Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 2/8] pack: Use let-keywords instead of keyword-ref Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 4/8] pack: Extract populate-profile-root from self-contained-tarball/builder Maxim Cournoyer ` (4 subsequent siblings) 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, ludo, Christopher Baines, Ricardo Wurmus * guix/gexp.scm (computed-file-compiler): Honor %guile-for-build. --- (no changes since v1) guix/gexp.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 5f92174a2c..cabf163076 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -584,7 +584,8 @@ (define-record-type <computed-file> (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key guile (local-build? #t) (options '())) + #:key guile + (local-build? #t) (options '())) "Return an object representing the store item NAME, a file or directory computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the corresponding derivation is built locally. OPTIONS may be used to pass @@ -600,7 +601,8 @@ (define-gexp-compiler (computed-file-compiler (file <computed-file>) ;; gexp. (match file (($ <computed-file> name gexp guile options) - (mlet %store-monad ((guile (lower-object (or guile (default-guile)) + (mlet %store-monad ((guile (lower-object (or guile (%guile-for-build) + (default-guile)) system #:target #f))) (apply gexp->derivation name gexp #:guile-for-build guile #:system system #:target target options))))) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 4/8] pack: Extract populate-profile-root from self-contained-tarball/builder. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer ` (2 preceding siblings ...) 2023-02-17 1:49 ` [bug#61255] [PATCH v2 3/8] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 5/8] tests: pack: Fix indentation Maxim Cournoyer ` (3 subsequent siblings) 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, ludo, Christopher Baines, Ricardo Wurmus This allows more code to be reused between the various archive writers. * guix/scripts/pack.scm (set-utf8-locale): New top-level procedure, extracted from... (populate-profile-root): New procedure, extracted from... (self-contained-tarball/builder): ... here. Add #:target argument. Call populate-profile-root. [LOCALSTATEDIR?]: Set db.sqlite file permissions. (self-contained-tarball): Call self-contained-tarball/builder with the TARGET argument, and set #:local-build? to #f for the gexp-derivation call. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. (debian-archive): Call self-contained-tarball/builder with the #:target argument. Fix indentation. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. --- (no changes since v1) guix/scripts/pack.scm | 230 ++++++++++++++++++++++++------------------ 1 file changed, 134 insertions(+), 96 deletions(-) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e552cb108a..77425e5b0f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -194,104 +194,144 @@ (define (symlink-spec-option-parser opt name arg result) (leave (G_ "~a: invalid symlink specification~%") arg)))) -\f -;;; -;;; Tarball format. -;;; -(define* (self-contained-tarball/builder profile - #:key (profile-name "guix-profile") - (compressor (first %compressors)) - localstatedir? - (symlinks '()) - (archiver tar) - (extra-options '())) - "Return the G-Expression of the builder used for self-contained-tarball." +(define (set-utf8-locale profile) + "Configure the environment to use the \"en_US.utf8\" locale provided by the +GLIBC-UT8-LOCALES package." + ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. + (and (or (not (profile? profile)) + (profile-locales? profile)) + #~(begin + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8")))) + +(define* (populate-profile-root profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + (symlinks '())) + "Populate the root profile directory with SYMLINKS and a Guix database, when +LOCALSTATEDIR? is set. When DEDUPLICATE? is true, deduplicate the store +items, which relies on hard links." (define database (and localstatedir? (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define set-utf8-locale - ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. - (and (or (not (profile? profile)) - (profile-locales? profile)) - #~(begin - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8")))) - (define (import-module? module) ;; Since we don't use deduplication support in 'populate-store', don't ;; import (guix store deduplication) and its dependencies, which includes - ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'. + ;; Guile-Gcrypt, unless DEDUPLICATE? is #t. This makes it possible to run + ;; tests with '--bootstrap'. (and (not-config? module) - (not (equal? '(guix store deduplication) module)))) - - (with-imported-modules (source-module-closure - `((guix build pack) - (guix build store-copy) - (guix build utils) - (guix build union) - (gnu build install)) - #:select? import-module?) + (or deduplicate? (not (equal? '(guix store deduplication) module))))) + + (computed-file "profile-directory" + (with-imported-modules (source-module-closure + `((guix build pack) + (guix build store-copy) + (guix build utils) + (guix build union) + (gnu build install)) + #:select? import-module?) + #~(begin + (use-modules (guix build pack) + (guix build store-copy) + (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off by + ;; default. Furthermore GNU tar < 1.30 sometimes fails to extract + ;; tarballs with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-store (list "profile") #$output + #:deduplicate? #$deduplicate?) + + (when #+localstatedir? + (install-database-and-gc-roots #$output #+database #$profile + #:profile-name #$profile-name)) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> #$output) + directives))) + #:local-build? #f + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) + +\f +;;; +;;; Tarball format. +;;; +(define* (self-contained-tarball/builder profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + symlinks + compressor + archiver) + "Return a GEXP that can build a self-contained tarball." + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (with-imported-modules (source-module-closure '((guix build pack) + (guix build utils))) #~(begin (use-modules (guix build pack) - (guix build store-copy) - (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - ;; Use a relative file name for compatibility with - ;; relocatable packs. - (,source -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + (guix build utils)) ;; Make sure non-ASCII file names are properly handled. - #+set-utf8-locale + #+(set-utf8-locale profile) (define tar #+(file-append archiver "/bin/tar")) - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-store (list "profile") %root #:deduplicate? #f) - - (when #+localstatedir? - (install-database-and-gc-roots %root #+database #$profile - #:profile-name #$profile-name)) + (define %root (if #$localstatedir? "." #$root)) - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) - ;; Create the tarball. (with-directory-excursion %root ;; GNU Tar recurses directories by default. Simply add the whole - ;; current directory, which contains all the generated files so far. + ;; current directory, which contains all the files to be archived. ;; This avoids creating duplicate files in the archives that would ;; be stored as hard links by GNU Tar. (apply invoke tar "-cvf" #$output "." @@ -320,17 +360,16 @@ (define* (self-contained-tarball name profile (warning (G_ "entry point not supported in the '~a' format~%") 'tarball)) - (gexp->derivation - (string-append name ".tar" - (compressor-extension compressor)) - (self-contained-tarball/builder profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".tar" + (compressor-extension compressor)) + (self-contained-tarball/builder profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver))) \f ;;; @@ -676,13 +715,15 @@ (define %valid-compressors '("gzip" "xz" "none")) 'deb)) (define data-tarball - (computed-file (string-append "data.tar" - (compressor-extension compressor)) + (computed-file (string-append "data.tar" (compressor-extension + compressor)) (self-contained-tarball/builder profile + #:target target #:profile-name profile-name - #:compressor compressor #:localstatedir? localstatedir? + #:deduplicate? deduplicate? #:symlinks symlinks + #:compressor compressor #:archiver archiver) #:local-build? #f ;allow offloading #:options (list #:references-graphs `(("profile" ,profile)) @@ -811,10 +852,7 @@ (define tar (string-append #+archiver "/bin/tar")) "debian-binary" control-tarball-file-name data-tarball-file-name)))))) - (gexp->derivation (string-append name ".deb") - build - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".deb") build)) \f ;;; -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 5/8] tests: pack: Fix indentation. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer ` (3 preceding siblings ...) 2023-02-17 1:49 ` [bug#61255] [PATCH v2 4/8] pack: Extract populate-profile-root from self-contained-tarball/builder Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 6/8] pack: Add RPM format Maxim Cournoyer ` (2 subsequent siblings) 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255; +Cc: ludo, Maxim Cournoyer * tests/pack.scm: Fix indentation. --- Changes in v2: - Better make use of the new indentation rule tests/pack.scm | 279 ++++++++++++++++++++++++------------------------- 1 file changed, 137 insertions(+), 142 deletions(-) diff --git a/tests/pack.scm b/tests/pack.scm index a4c388d93e..a02924b7d2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -74,44 +74,43 @@ (define %ar-bootstrap %bootstrap-binutils) -> "bin/guile")) #:compressor %gzip-compressor #:archiver %tar-bootstrap)) - (check (gexp->derivation - "check-tarball" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (srfi srfi-1)) - - (define store - ;; The unpacked store. - (string-append "." (%store-directory) "/")) - - (define (canonical? file) - ;; Return #t if FILE is read-only and its mtime is 1. - (let ((st (lstat file))) - (or (not (string-prefix? store file)) - (eq? 'symlink (stat:type st)) - (and (= 1 (stat:mtime st)) - (zero? (logand #o222 - (stat:mode st))))))) - - (define bin - (string-append "." #$profile "/bin")) - - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (file-exists? store) - (every canonical? - (find-files "." (const #t) - #:directories? #t)) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile"))))))))) + (check (gexp->derivation "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define store + ;; The unpacked store. + (string-append "." (%store-directory) "/")) + + (define (canonical? file) + ;; Return #t if FILE is read-only and its mtime is 1. + (let ((st (lstat file))) + (or (not (string-prefix? store file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 + (stat:mode st))))))) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (file-exists? store) + (every canonical? + (find-files "." (const #t) + #:directories? #t)) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile"))))))))) (built-derivations (list check)))) ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of @@ -131,17 +130,16 @@ (define bin #:locales? #f)) (tarball (self-contained-tarball "tar-pack" profile #:localstatedir? #t)) - (check (gexp->derivation - "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? "var/guix/db/db.sqlite") - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)))))))) + (check (gexp->derivation "check-tarball" + #~(let ((bin (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -154,45 +152,44 @@ (define bin ("λ" regular (data "lambda"))))) (tarball (self-contained-tarball "tar-pack" tree #:localstatedir? #t)) - (check (gexp->derivation - "check-tarball" - (with-extensions (list guile-sqlite3 guile-gcrypt) - (with-imported-modules (source-module-closure - '((guix store database))) - #~(begin - (use-modules (guix store database) - (rnrs io ports) - (srfi srfi-1)) - - (define (valid-file? basename data) - (define file - (string-append "./" #$tree "/" basename)) - - (string=? (call-with-input-file (pk 'file file) - get-string-all) - data)) - - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - - (sql-schema - #$(local-file (search-path %load-path - "guix/store/schema.sql"))) - (with-database "var/guix/db/db.sqlite" db - ;; Make sure non-ASCII file names are properly - ;; handled. - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales - "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - (mkdir #$output) - (exit - (and (every valid-file? - '("α" "λ") - '("alpha" "lambda")) - (integer? (path-id db #$tree))))))))))) + (check (gexp->derivation "check-tarball" + (with-extensions (list guile-sqlite3 guile-gcrypt) + (with-imported-modules (source-module-closure + '((guix store database))) + #~(begin + (use-modules (guix store database) + (rnrs io ports) + (srfi srfi-1)) + + (define (valid-file? basename data) + (define file + (string-append "./" #$tree "/" basename)) + + (string=? (call-with-input-file (pk 'file file) + get-string-all) + data)) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + + (sql-schema + #$(local-file (search-path %load-path + "guix/store/schema.sql"))) + (with-database "var/guix/db/db.sqlite" db + ;; Make sure non-ASCII file names are properly + ;; handled. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales + "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (mkdir #$output) + (exit + (and (every valid-file? + '("α" "λ") + '("alpha" "lambda")) + (integer? (path-id db #$tree))))))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -206,34 +203,33 @@ (define file (tarball (docker-image "docker-pack" profile #:symlinks '(("/bin/Guile" -> "bin/guile")) #:localstatedir? #t)) - (check (gexp->derivation - "check-tarball" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (define bin - (string-append "." #$profile "/bin")) - - (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) - (mkdir "base") - (with-directory-excursion "base" - (invoke "tar" "xvf" #$tarball)) - - (match (find-files "base" "layer.tar") - ((layer) - (invoke "tar" "xvf" layer))) - - (when - (and (file-exists? (string-append bin "/guile")) - (file-exists? "var/guix/db/db.sqlite") - (file-is-directory? "tmp") - (string=? (string-append #$%bootstrap-guile "/bin") - (pk 'binlink (readlink bin))) - (string=? (string-append #$profile "/bin/guile") - (pk 'guilelink (readlink "bin/Guile")))) - (mkdir #$output))))))) + (check (gexp->derivation "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) + (mkdir "base") + (with-directory-excursion "base" + (invoke "tar" "xvf" #$tarball)) + + (match (find-files "base" "layer.tar") + ((layer) + (invoke "tar" "xvf" layer))) + + (when + (and (file-exists? (string-append bin "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (file-is-directory? "tmp") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + (string=? (string-append #$profile "/bin/guile") + (pk 'guilelink (readlink "bin/Guile")))) + (mkdir #$output))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -247,32 +243,31 @@ (define bin (image (squashfs-image "squashfs-pack" profile #:symlinks '(("/bin" -> "bin")) #:localstatedir? #t)) - (check (gexp->derivation - "check-tarball" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (define bin - (string-append "." #$profile "/bin")) - - (setenv "PATH" - (string-append #$squashfs-tools "/bin")) - (invoke "unsquashfs" #$image) - (with-directory-excursion "squashfs-root" - (when (and (file-exists? (string-append bin - "/guile")) - (file-exists? "var/guix/db/db.sqlite") - (string=? (string-append #$%bootstrap-guile "/bin") - (pk 'binlink (readlink bin))) - - ;; This is a relative symlink target. - (string=? (string-drop - (string-append #$profile "/bin") - 1) - (pk 'guilelink (readlink "bin")))) - (mkdir #$output)))))))) + (check (gexp->derivation "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$squashfs-tools "/bin")) + (invoke "unsquashfs" #$image) + (with-directory-excursion "squashfs-root" + (when (and (file-exists? (string-append bin + "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + + ;; This is a relative symlink target. + (string=? (string-drop + (string-append #$profile "/bin") + 1) + (pk 'guilelink (readlink "bin")))) + (mkdir #$output)))))))) (built-derivations (list check)))) (unless store (test-skip 1)) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 6/8] pack: Add RPM format. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer ` (4 preceding siblings ...) 2023-02-17 1:49 ` [bug#61255] [PATCH v2 5/8] tests: pack: Fix indentation Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 7/8] etc: Add a news entry snippet Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format Maxim Cournoyer 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255 Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe, ludo, Christopher Baines, Ricardo Wurmus * guix/rpm.scm: New file. * guix/scripts/pack.scm (rpm-archive): New procedure. (%formats): Register it. (show-formats): Add it. (guix-pack): Register supported extra-options for the rpm format. * tests/pack.scm (rpm-for-tests): New variable. ("rpm archive can be installed/uninstalled"): New test. * tests/rpm.scm: New test. * doc/guix.texi (Invoking guix pack): Document it. --- Changes in v2: - Use let-keywords instead of custom keyword-ref - Adjust commentary block in (guix rpm) - Adjust long define indentation in (guix scripts pack) - Separate guix pack / rpm --install example blocks Makefile.am | 2 + doc/guix.texi | 48 +++- guix/rpm.scm | 623 ++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pack.scm | 230 +++++++++++++++- tests/pack.scm | 57 +++- tests/rpm.scm | 86 ++++++ 6 files changed, 1033 insertions(+), 13 deletions(-) create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm diff --git a/Makefile.am b/Makefile.am index 5ce6cc84f4..8e3815b9c2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -111,6 +111,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/rpm.scm \ guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ @@ -535,6 +536,7 @@ SCM_TESTS = \ tests/pypi.scm \ tests/read-print.scm \ tests/records.scm \ + tests/rpm.scm \ tests/scripts.scm \ tests/search-paths.scm \ tests/services.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 44e2165a82..11f6b3636f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6896,6 +6896,7 @@ such file or directory'' message. @end quotation @item deb +@cindex Debian, build a .deb package with guix pack This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. @@ -6912,7 +6913,8 @@ guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello Because archives produced with @command{guix pack} contain a collection of store items and because each @command{dpkg} package must not have conflicting files, in practice that means you likely won't be able to -install more than one such archive on a given system. +install more than one such archive on a given system. You can +nonetheless pack as many Guix packages as you want in one such archive. @end quotation @quotation Warning @@ -6923,6 +6925,50 @@ shared by other software, such as a Guix installation or other, non-deb packs. @end quotation +@item rpm +@cindex RPM, build an RPM archive with guix pack +This produces an RPM archive (a package with the @samp{.rpm} file +extension) containing all the specified binaries and symbolic links, +that can be installed on top of any RPM-based GNU/Linux distribution. +The RPM format embeds checksums for every file it contains, which the +@command{rpm} command uses to validate the integrity of the archive. + +Advanced RPM-related options are revealed via the +@option{--help-rpm-format} option. These options allow embedding +maintainer scripts that can run before or after the installation of the +RPM archive, for example. + +The RPM format supports relocatable packages via the @option{--prefix} +option of the @command{rpm} command, which can be handy to install an +RPM package to a specific prefix, making installing multiple +Guix-produced RPM packages side by side possible. + +@example +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello +@end example + +@example +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm +@end example + +@quotation Note +Similarly to Debian packages, two RPM packages with conflicting files +cannot be installed simultaneously. Contrary to Debian packages, RPM +supports relocatable packages, so file conflicts can be avoided by +installing the RPM packages under different installation prefixes, as +shown in the above example. +@end quotation + +@quotation Warning +@command{rpm} assumes ownership of any files contained in the pack, +which means it will remove @file{/gnu/store} upon uninstalling a +Guix-generated RPM package, unless the RPM package was installed with +the @option{--prefix} option of the @command{rpm} command. It is unwise +to install Guix-produced @samp{.rpm} packages on a system where +@file{/gnu/store} is shared by other software, such as a Guix +installation or other, non-rpm packs. +@end quotation + @end table @cindex relocatable binaries diff --git a/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..1cb8326a9b --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,623 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix rpm) + #:autoload (gcrypt hash) (hash-algorithm file-hash md5) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-171) + #:export (generate-lead + generate-signature + generate-header + assemble-rpm-metadata + + ;; XXX: These are internals, but the inline disabling trick + ;; doesn't work on them. + make-header-entry + header-entry? + header-entry-tag + header-entry-count + header-entry-value + + bytevector->hex-string + + fhs-directory?)) + +;;; Commentary: +;;; +;;; This module provides the building blocks required to construct RPM +;;; archives. It is intended to be importable on the build side, so shouldn't +;;; depend on (guix diagnostics) or other host-side-only modules. +;;; +;;; Code: + +(define (gnu-system-triplet->machine-type triplet) + "Return the machine component of TRIPLET, a GNU system triplet." + (first (string-split triplet #\-))) + +(define (gnu-machine-type->rpm-arch type) + "Return the canonical RPM architecture string, given machine TYPE." + (match type + ("arm" "armv7hl") + ("powerpc" "ppc") + ("powerpc64le" "ppc64le") + (machine machine))) ;unchanged + +(define (gnu-machine-type->rpm-number type) + "Translate machine TYPE to its corresponding RPM integer value." + ;; Refer to the rpmrc.in file in the RPM source for the complete + ;; translation tables. + (match type + ((or "i486" "i586" "i686" "x86_64") 1) + ((? (cut string-prefix? "powerpc" <>)) 5) + ("mips64el" 11) + ((? (cut string-prefix? "arm" <>)) 12) + ("aarch64" 19) + ((? (cut string-prefix? "riscv" <>)) 22) + (_ (error "no RPM number known for machine type" type)))) + +(define (u16-number->u8-list number) + "Return a list of byte values made of NUMBER, a 16 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 2))) + (bytevector->u8-list bv))) + +(define (u32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (s32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit signed integer." + (let ((bv (sint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (u8-list->u32-number lst) + "Return the 32 bit unsigned integer corresponding to the 4 bytes in LST." + (bytevector-u32-ref (u8-list->bytevector lst) 0 (endianness big))) + +\f +;;; +;;; Lead section. +;;; + +;; Refer to the docs/manual/format.md file of the RPM source for the details +;; regarding the binary format of an RPM archive. +(define* (generate-lead name-version #:key (target %host-type)) + "Generate a RPM lead u8-list that uses NAME-VERSION, the name and version +string of the package, and TARGET, a GNU triplet used to derive the target +machine type." + (define machine-type (gnu-system-triplet->machine-type target)) + (define magic (list #xed #xab #xee #xdb)) + (define file-format-version (list 3 0)) ;3.0 + (define type (list 0 0)) ;0 for binary packages + (define arch-number (u16-number->u8-list + (gnu-machine-type->rpm-number machine-type))) + ;; The 66 bytes from 10 to 75 are for the name-version-release string. + (define name + (let ((padding-bytes (make-list (- 66 (string-length name-version)) 0))) + (append (bytevector->u8-list (string->utf8 name-version)) + padding-bytes))) + ;; There is no OS number corresponding to GNU/Hurd (GNU), only Linux, per + ;; rpmrc.in. + (define os-number (list 0 1)) + + ;; For RPM format 3.0, the signature type is 5, which means a "Header-style" + ;; signature. + (define signature-type (list 0 5)) + + (define reserved-bytes (make-list 16 0)) + + (append magic file-format-version type arch-number name + os-number signature-type reserved-bytes)) + +\f +;;; +;;; Header section. +;;; + +(define header-magic (list #x8e #xad #xe8)) +(define header-version (list 1)) +(define header-reserved (make-list 4 0)) ;4 reserved bytes +;;; Every header starts with 8 bytes made by the header magic number, the +;;; header version and 4 reserved bytes. +(define header-intro (append header-magic header-version header-reserved)) + +;;; Header entry data types. +(define NULL 0) +(define CHAR 1) +(define INT8 2) +(define INT16 3) ;2-bytes aligned +(define INT32 4) ;4-bytes aligned +(define INT64 5) ;8-bytes aligned +(define STRING 6) +(define BIN 7) +(define STRING_ARRAY 8) +(define I18NSTRIN_TYPE 9) + +;;; Header entry tags. +(define-record-type <rpm-tag> + (make-rpm-tag number type) + rpm-tag? + (number rpm-tag-number) + (type rpm-tag-type)) + +;;; The following are internal tags used to identify the data sections. +(define RPMTAG_HEADERSIGNATURES (make-rpm-tag 62 BIN)) ;signature header +(define RPMTAG_HEADERIMMUTABLE (make-rpm-tag 63 BIN)) ;main/data header +(define RPMTAG_HEADERI18NTABLE (make-rpm-tag 100 STRING_ARRAY)) + +;;; Subset of RPM tags from include/rpm/rpmtag.h. +(define RPMTAG_NAME (make-rpm-tag 1000 STRING)) +(define RPMTAG_VERSION (make-rpm-tag 1001 STRING)) +(define RPMTAG_RELEASE (make-rpm-tag 1002 STRING)) +(define RPMTAG_SUMMARY (make-rpm-tag 1004 STRING)) +(define RPMTAG_SIZE (make-rpm-tag 1009 INT32)) +(define RPMTAG_LICENSE (make-rpm-tag 1014 STRING)) +(define RPMTAG_OS (make-rpm-tag 1021 STRING)) +(define RPMTAG_ARCH (make-rpm-tag 1022 STRING)) +(define RPMTAG_PREIN (make-rpm-tag 1023 STRING)) +(define RPMTAG_POSTIN (make-rpm-tag 1024 STRING)) +(define RPMTAG_PREUN (make-rpm-tag 1025 STRING)) +(define RPMTAG_POSTUN (make-rpm-tag 1026 STRING)) +(define RPMTAG_FILESIZES (make-rpm-tag 1028 INT32)) +(define RPMTAG_FILEMODES (make-rpm-tag 1030 INT16)) +(define RPMTAG_FILEDIGESTS (make-rpm-tag 1035 STRING_ARRAY)) +(define RPMTAG_FILELINKTOS (make-rpm-tag 1036 STRING_ARRAY)) +(define RPMTAG_FILEUSERNAME (make-rpm-tag 1039 STRING_ARRAY)) +(define RPMTAG_GROUPNAME (make-rpm-tag 1040 STRING_ARRAY)) +(define RPMTAG_PREFIXES (make-rpm-tag 1098 STRING_ARRAY)) +(define RPMTAG_DIRINDEXES (make-rpm-tag 1116 INT32)) +(define RPMTAG_BASENAMES (make-rpm-tag 1117 STRING_ARRAY)) +(define RPMTAG_DIRNAMES (make-rpm-tag 1118 STRING_ARRAY)) +(define RPMTAG_PAYLOADFORMAT (make-rpm-tag 1124 STRING)) +(define RPMTAG_PAYLOADCOMPRESSOR (make-rpm-tag 1125 STRING)) +(define RPMTAG_LONGFILESIZES (make-rpm-tag 5008 INT64)) +(define RPMTAG_LONGSIZE (make-rpm-tag 5009 INT64)) +;;; The algorithm used to compute the digest of each file, e.g. RPM_HASH_MD5. +(define RPMTAG_FILEDIGESTALGO (make-rpm-tag 5011 INT32)) +;;; RPMTAG_ENCODING specifies the encoding used for strings, e.g. "utf-8". +(define RPMTAG_ENCODING (make-rpm-tag 5062 STRING)) +;;; Compressed payload digest. Its type is a string array, but currently in +;;; practice it is equivalent to STRING, since only the first element is used. +(define RPMTAG_PAYLOADDIGEST (make-rpm-tag 5092 STRING_ARRAY)) +;;; The algorithm used to compute the payload digest, e.g. RPM_HASH_SHA256. +(define RPMTAG_PAYLOADDIGESTALGO (make-rpm-tag 5093 INT32)) +;;; The following are taken from the rpmHashAlgo_e enum in rpmcrypto.h. +(define RPM_HASH_MD5 1) +(define RPM_HASH_SHA256 8) + +;;; Other useful internal definitions. +(define REGION_TAG_COUNT 16) ;number of bytes +(define INT32_MAX (1- (expt 2 32))) ;4294967295 bytes (unsigned) + +(define (rpm-tag->u8-list tag) + "Return the u8 list corresponding to RPM-TAG, a <rpm-tag> object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type <header-entry> + (make-header-entry tag count value) + header-entry? + (tag header-entry-tag) ;<rpm-tag> + (count header-entry-count) ;number (u32) + (value header-entry-value)) ;string|number|list|... + +(define (entry-type->alignement type) + "Return the byte alignment of TYPE, an RPM header entry type." + (cond ((= INT16 type) 2) + ((= INT32 type) 4) + ((= INT64 type) 8) + (else 1))) + +(define (next-aligned-offset offset alignment) + "Return the next position from OFFSET which satisfies ALIGNMENT." + (if (= 0 (modulo offset alignment)) + offset + (next-aligned-offset (1+ offset) alignment))) + +(define (header-entry->data entry) + "Return the data of ENTRY, a <header-entry> object, as a u8 list." + (let* ((tag (header-entry-tag entry)) + (count (header-entry-count entry)) + (value (header-entry-value entry)) + (number (rpm-tag-number tag)) + (type (rpm-tag-type tag))) + (cond + ((= STRING type) + (unless (string? value) + (error "expected string value for STRING type, got" value)) + (unless (= 1 count) + (error "count must be 1 for STRING type")) + (let ((value (cond ((= (rpm-tag-number RPMTAG_VERSION) number) + ;; Hyphens are not allowed in version strings. + (string-map (match-lambda + (#\- #\+) + (c c)) + value)) + (else value)))) + (append (bytevector->u8-list (string->utf8 value)) + (list 0)))) ;strings must end with null byte + ((= STRING_ARRAY type) + (unless (list? value) + (error "expected a list of strings for STRING_ARRAY type, got" value)) + (unless (= count (length value)) + (error "expected count to be equal to" (length value) 'got count)) + (append-map (lambda (s) + (append (bytevector->u8-list (string->utf8 s)) + (list 0))) ;null byte separated + value)) + ((member type (list INT8 INT16 INT32)) + (if (= 1 count) + (unless (number? value) + (error "expected number value for scalar INT type; got" value)) + (unless (list? value) + (error "expected list value for array INT type; got" value))) + (if (list? value) + (cond ((= INT8 type) value) + ((= INT16 type) (append-map u16-number->u8-list value)) + ((= INT32 type) (append-map u32-number->u8-list value)) + (else (error "unexpected type" type))) + (cond ((= INT8 type) (list value)) + ((= INT16 type) (u16-number->u8-list value)) + ((= INT32 type) (u32-number->u8-list value)) + (else (error "unexpected type" type))))) + ((= BIN type) + (unless (list? value) + (error "expected list value for BIN type; got" value)) + value) + (else (error "unimplemented type" type))))) + +(define (make-header-index+data entries) + "Return the index and data sections as u8 number lists, via multiple values. +An index is composed of four u32 (16 bytes total) quantities, in order: tag, +type, offset and count." + (match (fold (match-lambda* + ((entry (offset . (index . data))) + (let* ((tag (header-entry-tag entry)) + (tag-number (rpm-tag-number tag)) + (tag-type (rpm-tag-type tag)) + (count (header-entry-count entry)) + (data* (header-entry->data entry)) + (alignment (entry-type->alignement tag-type)) + (aligned-offset (next-aligned-offset offset alignment)) + (padding (make-list (- aligned-offset offset) 0))) + (cons (+ aligned-offset (length data*)) + (cons (append index + (u32-number->u8-list tag-number) + (u32-number->u8-list tag-type) + (u32-number->u8-list aligned-offset) + (u32-number->u8-list count)) + (append data padding data*)))))) + '(0 . (() . ())) + entries) + ((offset . (index . data)) + (values index data)))) + +;; Prevent inlining of the variables/procedures accessed by unit tests. +(set! make-header-index+data make-header-index+data) +(set! RPMTAG_ARCH RPMTAG_ARCH) +(set! RPMTAG_LICENSE RPMTAG_LICENSE) +(set! RPMTAG_NAME RPMTAG_NAME) +(set! RPMTAG_OS RPMTAG_OS) +(set! RPMTAG_RELEASE RPMTAG_RELEASE) +(set! RPMTAG_SUMMARY RPMTAG_SUMMARY) +(set! RPMTAG_VERSION RPMTAG_VERSION) + +(define (wrap-in-region-tags header region-tag) + "Wrap HEADER, a header provided as u8-list with REGION-TAG." + (let* ((type (rpm-tag-type region-tag)) + (header-intro (take header 16)) + (header-rest (drop header 16)) + ;; Increment the existing index value to account for the added region + ;; tag index. + (index-length (1+ (u8-list->u32-number + (drop-right (drop header-intro 8) 4)))) ;bytes 8-11 + ;; Increment the data length value to account for the added region + ;; tag data. + (data-length (+ REGION_TAG_COUNT + (u8-list->u32-number + (take-right header-intro 4))))) ;last 4 bytes of intro + (unless (member region-tag (list RPMTAG_HEADERSIGNATURES + RPMTAG_HEADERIMMUTABLE)) + (error "expected RPMTAG_HEADERSIGNATURES or RPMTAG_HEADERIMMUTABLE, got" + region-tag)) + (append (drop-right header-intro 8) ;strip existing index and data lengths + (u32-number->u8-list index-length) + (u32-number->u8-list data-length) + ;; Region tag (16 bytes). + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (u32-number->u8-list (- data-length REGION_TAG_COUNT)) ;offset + (u32-number->u8-list REGION_TAG_COUNT) ;count + ;; Immutable region. + header-rest + ;; Region tag trailer (16 bytes). Note: the trailer offset value + ;; is an enforced convention; it has no practical use. + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (s32-number->u8-list (* -1 index-length 16)) ;negative offset + (u32-number->u8-list REGION_TAG_COUNT)))) ;count + +(define (bytevector->hex-string bv) + (format #f "~{~2,'0x~}" (bytevector->u8-list bv))) + +(define (files->md5-checksums files) + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." + (let ((file-md5 (cut file-hash (hash-algorithm md5) <>))) + (map (lambda (f) + (or (and=> (false-if-exception (file-md5 f)) + bytevector->hex-string) + ;; Only regular files (e.g., not directories) can have their + ;; checksum computed. + "")) + files))) + +(define (strip-leading-dot name) + "Remove the leading \".\" from NAME, if present. If a single \".\" is +encountered, translate it to \"/\"." + (match name + ("." "/") ;special case + ((? (cut string-prefix? "." <>)) + (string-drop name 1)) + (x name))) + +;;; An extensive list of required and optional FHS directories, per its 3.0 +;;; revision. +(define %fhs-directories + (list "/bin" "/boot" "/dev" + "/etc" "/etc/opt" "/etc/X11" "/etc/sgml" "/etc/xml" + "/home" "/root" "/lib" "/media" "/mnt" + "/opt" "/opt/bin" "/opt/doc" "/opt/include" + "/opt/info" "/opt/lib" "/opt/man" + "/run" "/sbin" "/srv" "/sys" "/tmp" + "/usr" "/usr/bin" "/usr/include" "/usr/libexec" + "/usr/share/color" "/usr/share/dict" "/usr/share/doc" "/usr/share/games" + "/usr/share/info" "/usr/share/locale" "/usr/share/man" "/usr/share/misc" + "/usr/share/nls" "/usr/share/ppd" "/usr/share/sgml" + "/usr/share/terminfo" "/usr/share/tmac" "/usr/share/xml" + "/usr/share/zoneinfo" "/usr/local" "/usr/local/bin" "/usr/local/etc" + "/usr/local/games" "/usr/local/include" "/usr/local/lib" + "/usr/local/man" "/usr/local/sbin" "/usr/local/sbin" "/usr/local/share" + "/usr/local/src" "/var" "/var/account" "/var/backups" + "/var/cache" "/var/cache/fonts" "/var/cache/man" "/var/cache/www" + "/var/crash" "/var/cron" "/var/games" "/var/mail" "/var/msgs" + "/var/lib" "/var/lib/color" "/var/lib/hwclock" "/var/lib/misc" + "/var/local" "/var/lock" "/var/log" "/var/opt" "/var/preserve" + "/var/run" "/var/spool" "/var/spool/lpd" "/var/spool/mqueue" + "/var/spool/news" "/var/spool/rwho" "/var/spool/uucp" + "/var/tmp" "/var/yp")) + +(define (fhs-directory? file-name) + "Predicate to check if FILE-NAME is a known File Hierarchy Standard (FHS) +directory." + (member (strip-leading-dot file-name) %fhs-directories)) + +(define (directory->file-entries directory) + "Return the file lists triplet header entries for the files found under +DIRECTORY." + (with-directory-excursion directory + ;; Skip the initial "." directory, as its name would get concatenated with + ;; the "./" dirname and fail to match "." in the payload. + (let* ((files (cdr (find-files "." #:directories? #t))) + (file-stats (map lstat files)) + (directories + (append (list ".") + (filter-map (match-lambda + ((index . file) + (let ((st (list-ref file-stats index))) + (and (eq? 'directory (stat:type st)) + file)))) + (list-transduce (tenumerate) rcons files)))) + ;; Omit any FHS directories found in FILES to avoid the RPM package + ;; from owning them. This can occur when symlinks directives such + ;; as "/usr/bin/hello -> bin/hello" are used. + (package-files package-file-stats + (unzip2 (reverse + (fold (lambda (file stat res) + (if (fhs-directory? file) + res + (cons (list file stat) res))) + '() files file-stats)))) + + ;; When provided with the index of a file, the directory index must + ;; return the index of the corresponding directory entry. + (dirindexes (map (lambda (d) + (list-index (cut string=? <> d) directories)) + (map dirname package-files))) + ;; The files owned are those appearing in 'basenames'; own them + ;; all. + (basenames (map basename package-files)) + ;; The directory names must end with a trailing "/". + (dirnames (map (compose strip-leading-dot (cut string-append <> "/")) + directories)) + ;; Note: All the file-related entries must have the same length as + ;; the basenames entry. + (symlink-targets (map (lambda (f) + (if (symbolic-link? f) + (readlink f) + "")) ;unused + package-files)) + (file-modes (map stat:mode package-file-stats)) + (file-sizes (map stat:size package-file-stats)) + (file-md5s (files->md5-checksums package-files))) + (let ((basenames-length (length basenames)) + (dirindexes-length (length dirindexes))) + (unless (= basenames-length dirindexes-length) + (error "length mismatch for dirIndexes; expected/actual" + basenames-length dirindexes-length)) + (append + (if (> (apply max file-sizes) INT32_MAX) + (list (make-header-entry RPMTAG_LONGFILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_LONGSIZE 1 + (reduce + 0 file-sizes))) + (list (make-header-entry RPMTAG_FILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_SIZE 1 (reduce + 0 file-sizes)))) + (list + (make-header-entry RPMTAG_FILEMODES (length file-modes) file-modes) + (make-header-entry RPMTAG_FILEDIGESTS (length file-md5s) file-md5s) + (make-header-entry RPMTAG_FILEDIGESTALGO 1 RPM_HASH_MD5) + (make-header-entry RPMTAG_FILELINKTOS (length symlink-targets) + symlink-targets) + (make-header-entry RPMTAG_FILEUSERNAME basenames-length + (make-list basenames-length "root")) + (make-header-entry RPMTAG_GROUPNAME basenames-length + (make-list basenames-length "root")) + ;; The dirindexes, basenames and dirnames tags form the so-called RPM + ;; "path triplet". + (make-header-entry RPMTAG_DIRINDEXES dirindexes-length dirindexes) + (make-header-entry RPMTAG_BASENAMES basenames-length basenames) + (make-header-entry RPMTAG_DIRNAMES (length dirnames) dirnames))))))) + +(define (make-header entries) + "Return the u8 list of a RPM header containing ENTRIES, a list of +<rpm-entry> objects." + (let* ((entries (sort entries (lambda (x y) + (< (rpm-tag-number (header-entry-tag x)) + (rpm-tag-number (header-entry-tag y)))))) + (count (length entries)) + (index data (make-header-index+data entries))) + (append header-intro ;8 bytes + (u32-number->u8-list count) ;4 bytes + (u32-number->u8-list (length data)) ;4 bytes + ;; Now starts the header index, which can contain up to 32 entries + ;; of 16 bytes each. + index data))) + +(define* (generate-header name version + payload-digest + payload-directory + payload-compressor + #:key + relocatable? + prein-file postin-file + preun-file postun-file + (target %host-type) + (release "0") + (license "N/A") + (summary "RPM archive generated by GNU Guix.") + (os "Linux")) ;see rpmrc.in + "Return the u8 list corresponding to the Header section. PAYLOAD-DIGEST is +the SHA256 checksum string of the compressed payload. PAYLOAD-DIRECTORY is +the directory containing the payload files. PAYLOAD-COMPRESSOR is the name of +the compressor used to compress the CPIO payload, such as \"none\", \"gz\", +\"xz\" or \"zstd\"." + (let* ((rpm-arch (gnu-machine-type->rpm-arch + (gnu-system-triplet->machine-type target))) + (file->string (cut call-with-input-file <> get-string-all)) + (prein-script (and=> prein-file file->string)) + (postin-script (and=> postin-file file->string)) + (preun-script (and=> preun-file file->string)) + (postun-script (and=> postun-file file->string))) + (wrap-in-region-tags + (make-header (append + (list (make-header-entry RPMTAG_HEADERI18NTABLE 1 (list "C")) + (make-header-entry RPMTAG_NAME 1 name) + (make-header-entry RPMTAG_VERSION 1 version) + (make-header-entry RPMTAG_RELEASE 1 release) + (make-header-entry RPMTAG_SUMMARY 1 summary) + (make-header-entry RPMTAG_LICENSE 1 license) + (make-header-entry RPMTAG_OS 1 os) + (make-header-entry RPMTAG_ARCH 1 rpm-arch)) + (directory->file-entries payload-directory) + (if relocatable? + ;; Note: RPMTAG_PREFIXES must not have a trailing + ;; slash, unless it's '/'. This allows installing the + ;; package via 'rpm -i --prefix=/tmp', for example. + (list (make-header-entry RPMTAG_PREFIXES 1 (list "/"))) + '()) + (if prein-script + (list (make-header-entry RPMTAG_PREIN 1 prein-script)) + '()) + (if postin-script + (list (make-header-entry RPMTAG_POSTIN 1 postin-script)) + '()) + (if preun-script + (list (make-header-entry RPMTAG_PREUN 1 preun-script)) + '()) + (if postun-script + (list (make-header-entry RPMTAG_POSTUN 1 postun-script)) + '()) + (if (string=? "none" payload-compressor) + '() + (list (make-header-entry RPMTAG_PAYLOADCOMPRESSOR 1 + payload-compressor))) + (list (make-header-entry RPMTAG_ENCODING 1 "utf-8") + (make-header-entry RPMTAG_PAYLOADFORMAT 1 "cpio") + (make-header-entry RPMTAG_PAYLOADDIGEST 1 + (list payload-digest)) + (make-header-entry RPMTAG_PAYLOADDIGESTALGO 1 + RPM_HASH_SHA256)))) + RPMTAG_HEADERIMMUTABLE))) + +\f +;;; +;;; Signature section +;;; + +;;; Header sha256 checksum. +(define RPMSIGTAG_SHA256 (make-rpm-tag 273 STRING)) +;;; Uncompressed payload size. +(define RPMSIGTAG_PAYLOADSIZE (make-rpm-tag 1007 INT32)) +;;; Header and compressed payload combined size. +(define RPMSIGTAG_SIZE (make-rpm-tag 1000 INT32)) +;;; Uncompressed payload size (when size > max u32). +(define RPMSIGTAG_LONGARCHIVESIZE (make-rpm-tag 271 INT64)) +;;; Header and compressed payload combined size (when size > max u32). +(define RPMSIGTAG_LONGSIZE (make-rpm-tag 270 INT64)) +;;; Extra space reserved for signatures (typically 32 bytes). +(define RPMSIGTAG_RESERVEDSPACE (make-rpm-tag 1008 BIN)) + +(define (generate-signature header-sha256 + header+compressed-payload-size + ;; uncompressed-payload-size + ) + "Return the u8 list representing a signature header containing the +HEADER-SHA256 (a string) and the PAYLOAD-SIZE, which is the combined size of +the header and compressed payload." + (define size-tag (if (> header+compressed-payload-size INT32_MAX) + RPMSIGTAG_LONGSIZE + RPMSIGTAG_SIZE)) + (wrap-in-region-tags + (make-header (list (make-header-entry RPMSIGTAG_SHA256 1 header-sha256) + (make-header-entry size-tag 1 + header+compressed-payload-size) + ;; (make-header-entry RPMSIGTAG_PAYLOADSIZE 1 + ;; uncompressed-payload-size) + ;; Reserve 32 bytes of extra space in case users would + ;; like to add signatures, as done in rpmGenerateSignature. + (make-header-entry RPMSIGTAG_RESERVEDSPACE 32 + (make-list 32 0)))) + RPMTAG_HEADERSIGNATURES)) + +(define (assemble-rpm-metadata lead signature header) + "Align and append the various u8 list components together, and return the +result as a bytevector." + (let* ((offset (+ (length lead) (length signature))) + (header-offset (next-aligned-offset offset 8)) + (padding (make-list (- header-offset offset) 0))) + ;; The Header is 8-bytes aligned. + (u8-list->bytevector (append lead signature padding header)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 77425e5b0f..701e41ff1a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; @@ -67,6 +67,7 @@ (define-module (guix scripts pack) self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -856,6 +857,166 @@ (define tar (string-append #+archiver "/bin/tar")) \f ;;; +;;; RPM archive format. +;;; +(define* (rpm-archive name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (first %compressors)) + deduplicate? + localstatedir? + (symlinks '()) + archiver + (extra-options '())) + "Return a RPM archive (.rpm) containing a store initialized with the closure +of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be +a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack. +ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE, +PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (define payload + (let* ((raw-cpio-file-name "payload.cpio") + (compressed-cpio-file-name (string-append raw-cpio-file-name + (compressor-extension + compressor)))) + (computed-file compressed-cpio-file-name + (with-imported-modules (source-module-closure + '((guix build utils) + (guix cpio) + (guix rpm))) + #~(begin + (use-modules (guix build utils) + (guix cpio) + (guix rpm) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define %root (if #$localstatedir? "." #$root)) + + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion %root + ;; The first "." entry is discarded. + (write-cpio-archive + (remove fhs-directory? + (cdr (find-files "." #:directories? #t))) + port)))) + (when #+(compressor-command compressor) + (apply invoke (append #+(compressor-command compressor) + (list #$raw-cpio-file-name)))) + (copy-file #$compressed-cpio-file-name #$output))) + #:local-build? #f))) ;allow offloading + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm)) + #:select? not-config?)) + #~(begin + (use-modules (gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm) + (ice-9 binary-ports) + (ice-9 match) ;for manifest->friendly-name + (ice-9 optargs) + (rnrs bytevectors) + (srfi srfi-1)) + + (define machine-type + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (_ #f))) + + (define name + (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define version + (or (and=> single-entry manifest-entry-version) "0.0.0")) + + (define lead + (generate-lead (string-append name "-" version) + #:target (or #$target %host-type))) + + (define payload-digest + (bytevector->hex-string (file-sha256 #$payload))) + + (let-keywords '#$extra-options #f ((relocatable? #f) + (prein-file #f) + (postin-file #f) + (preun-file #f) + (postun-file #f)) + + (let ((header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? relocatable? + #:prein-file prein-file + #:postin-file postin-file + #:preun-file preun-file + #:postun-file postun-file))) + + (define header-sha256 + (bytevector->hex-string (sha256 (u8-list->bytevector header)))) + + (define payload-size (stat:size (stat #$payload))) + + (define header+compressed-payload-size + (+ (length header) payload-size)) + + (define signature + (generate-signature header-sha256 + header+compressed-payload-size)) + + ;; Serialize the archive components to a file. + (call-with-input-file #$payload + (lambda (in) + (call-with-output-file #$output + (lambda (out) + (put-bytevector out (assemble-rpm-metadata lead + signature + header)) + (sendfile out in payload-size))))))))))) + + (gexp->derivation (string-append name ".rpm") build)) + + \f +;;; ;;; Compiling C programs. ;;; @@ -1187,7 +1348,8 @@ (define %formats `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) - (deb . ,debian-archive))) + (deb . ,debian-archive) + (rpm . ,rpm-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -1201,18 +1363,22 @@ (define (show-formats) docker Tarball ready for 'docker load'")) (display (G_ " deb Debian archive installable via dpkg/apt")) + (display (G_ " + rpm RPM archive installable via rpm/yum")) (newline)) +(define (required-option symbol) + "Return an SYMBOL option that requires a value." + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))) + (define %deb-format-options - (let ((required-option (lambda (symbol) - (option (list (symbol->string symbol)) #t #f - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest)))))) - (list (required-option 'control-file) - (required-option 'postinst-file) - (required-option 'triggers-file)))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file))) (define (show-deb-format-options) (display (G_ " @@ -1231,6 +1397,32 @@ (define (show-deb-format-options/detailed) (newline) (exit 0)) +(define %rpm-format-options + (list (required-option 'prein-file) + (required-option 'postin-file) + (required-option 'preun-file) + (required-option 'postun-file))) + +(define (show-rpm-format-options) + (display (G_ " + --help-rpm-format list options specific to the RPM format"))) + +(define (show-rpm-format-options/detailed) + (display (G_ " + --prein-file=FILE + Embed the provided prein script")) + (display (G_ " + --postin-file=FILE + Embed the provided postin script")) + (display (G_ " + --preun-file=FILE + Embed the provided preun script")) + (display (G_ " + --postun-file=FILE + Embed the provided postun script")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1307,7 +1499,12 @@ (define %options (lambda args (show-deb-format-options/detailed))) + (option '("help-rpm-format") #f #f + (lambda args + (show-rpm-format-options/detailed))) + (append %deb-format-options + %rpm-format-options %transformation-options %standard-build-options %standard-cross-build-options @@ -1325,6 +1522,7 @@ (define (show-help) (show-transformation-options-help) (newline) (show-deb-format-options) + (show-rpm-format-options) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) @@ -1483,6 +1681,16 @@ (define (process-file-arg opts name) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable? + #:prein-file + (process-file-arg opts 'prein-file) + #:postin-file + (process-file-arg opts 'postin-file) + #:preun-file + (process-file-arg opts 'preun-file) + #:postun-file + (process-file-arg opts 'postun-file))) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/tests/pack.scm b/tests/pack.scm index a02924b7d2..734ae1c69b 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,13 +28,16 @@ (define-module (test-pack) #:use-module (guix tests) #:use-module (guix gexp) #:use-module (guix modules) + #:use-module (guix utils) #:use-module (gnu packages) #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages package-management) #:select (rpm)) #:use-module ((gnu packages compression) #:select (squashfs-tools)) #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages linux) #:select (fakeroot)) #:use-module (srfi srfi-64)) (define %store @@ -59,6 +62,17 @@ (define %tar-bootstrap %bootstrap-coreutils&co) (define %ar-bootstrap %bootstrap-binutils) +;;; This is a variant of the RPM package configured so that its database can +;;; be created on a writable location readily available inside the build +;;; container ("/tmp"). +(define rpm-for-tests + (package + (inherit rpm) + (arguments (substitute-keyword-arguments (package-arguments rpm) + ((#:configure-flags flags '()) + #~(cons "--localstatedir=/tmp" + (delete "--localstatedir=/var" #$flags))))))) + \f (test-begin "pack") @@ -355,6 +369,47 @@ (define hard-links (stat "postinst")))))) (assert (file-exists? "triggers")) + (mkdir #$output)))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "rpm archive can be installed/uninstalled" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (rpm-pack (rpm-archive "rpm-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/bin/guile" -> "bin/guile")) + #:extra-options '(#:relocatable? #t))) + (check + (gexp->derivation "check-rpm-pack" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install the RPM package. This causes RPM to validate the + ;; signatures, header as well as the file digests, which + ;; makes it a rather thorough test. + (mkdir "test-prefix") + (invoke fakeroot rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; Invoke the installed Guile command. + (invoke "./test-prefix/bin/guile" "--version") + + ;; Uninstall the RPM package. + (invoke fakeroot rpm "--erase" "guile-bootstrap") + + ;; Required so the above is run. (mkdir #$output)))))) (built-derivations (list check))))) diff --git a/tests/rpm.scm b/tests/rpm.scm new file mode 100644 index 0000000000..f40b36fe60 --- /dev/null +++ b/tests/rpm.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-rpm) + #:use-module (guix rpm) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71)) + +;; For white-box testing. +(define-syntax-rule (expose-internal name) + (define name (@@ (guix rpm) name))) + +(expose-internal RPMTAG_ARCH) +(expose-internal RPMTAG_LICENSE) +(expose-internal RPMTAG_NAME) +(expose-internal RPMTAG_OS) +(expose-internal RPMTAG_RELEASE) +(expose-internal RPMTAG_SUMMARY) +(expose-internal RPMTAG_VERSION) +(expose-internal header-entry-count) +(expose-internal header-entry-tag) +(expose-internal header-entry-value) +(expose-internal header-entry?) +(expose-internal make-header) +(expose-internal make-header-entry) +(expose-internal make-header-index+data) + +(test-begin "rpm") + +(test-equal "lead must be 96 bytes long" + 96 + (length (generate-lead "hello-2.12.1"))) + +(define header-entries + (list (make-header-entry RPMTAG_NAME 1 "hello") + (make-header-entry RPMTAG_VERSION 1 "2.12.1") + (make-header-entry RPMTAG_RELEASE 1 "0") + (make-header-entry RPMTAG_SUMMARY 1 + "Hello, GNU world: An example GNU package") + (make-header-entry RPMTAG_LICENSE 1 "GPL 3 or later") + (make-header-entry RPMTAG_OS 1 "Linux") + (make-header-entry RPMTAG_ARCH 1 "x86_64"))) + +(define expected-header-index-length + (* 16 (length header-entries))) ;16 bytes per index entry + +(define expected-header-data-length + (+ (length header-entries) ;to account for null bytes + (fold + 0 (map (compose string-length (cut header-entry-value <>)) + header-entries)))) + +(let ((index data (make-header-index+data header-entries))) + (test-equal "header index" + expected-header-index-length + (length index)) + + ;; This test depends on the fact that only STRING entries are used, and that + ;; they are composed of single byte characters and the delimiting null byte. + (test-equal "header data" + expected-header-data-length + (length data))) + +(test-equal "complete header section" + (+ 16 ;leading magic + count bytes + expected-header-index-length expected-header-data-length) + (length (make-header header-entries))) + +(test-end) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 7/8] etc: Add a news entry snippet. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer ` (5 preceding siblings ...) 2023-02-17 1:49 ` [bug#61255] [PATCH v2 6/8] pack: Add RPM format Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format Maxim Cournoyer 7 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255; +Cc: ludo, Maxim Cournoyer * etc/snippets/yas/scheme-mode/guix-news-entry: New file. --- Changes in v2: - New commit etc/snippets/yas/scheme-mode/guix-news-entry | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 etc/snippets/yas/scheme-mode/guix-news-entry diff --git a/etc/snippets/yas/scheme-mode/guix-news-entry b/etc/snippets/yas/scheme-mode/guix-news-entry new file mode 100644 index 0000000000..7f5bb21c50 --- /dev/null +++ b/etc/snippets/yas/scheme-mode/guix-news-entry @@ -0,0 +1,9 @@ +# -*- mode: snippet -*- +# name: guix-news-entry +# key: entry... +# -- +(entry (commit "$1") + (title + (en "$2")) + (body + (en "$3"))) -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer ` (6 preceding siblings ...) 2023-02-17 1:49 ` [bug#61255] [PATCH v2 7/8] etc: Add a news entry snippet Maxim Cournoyer @ 2023-02-17 1:49 ` Maxim Cournoyer 2023-02-17 6:34 ` Julien Lepiller 2023-02-17 15:12 ` pelzflorian (Florian Pelz) 7 siblings, 2 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 1:49 UTC (permalink / raw) To: 61255 Cc: Julien Lepiller, ludo, Florian Pelz, Maxim Cournoyer, Thiago Jung Bauermann * etc/news.scm: Add entry. --- Changes in v2: - New commit etc/news.scm | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/etc/news.scm b/etc/news.scm index 211a176170..1eefdd1636 100644 --- a/etc/news.scm +++ b/etc/news.scm @@ -9,7 +9,7 @@ ;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org> ;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com> ;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> -;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;; Copyright © 2021 Leo Famulari <leo@famulari.name> ;; Copyright © 2021 Zhu Zihao <all_but_last@163.com> ;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> @@ -26,6 +26,21 @@ (channel-news (version 0) + (entry (commit "63622d2a234b707be5df07d8290a81b3247947e7") + (title + (en "New @samp{rpm} format for the @command{guix pack} command")) + (body + (en "RPM archives (with the .rpm file extension) can now be produced +via the @command{guix pack --format=rpm} command, providing an alternative +distribution path for software built with Guix. Here is a simple example that +generates an RPM archive for the @code{hello} package: + +@example +guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello +@end example + +See @command{info \"(guix) Invoking guix pack\"} for more information."))) + (entry (commit "137b91f03bbb7f1df71cf10c4f79ae57fbcea400") (title (en "New @option{--with-version} package transformation option") -- 2.39.1 ^ permalink raw reply related [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format Maxim Cournoyer @ 2023-02-17 6:34 ` Julien Lepiller 2023-02-17 17:32 ` Maxim Cournoyer 2023-02-17 15:12 ` pelzflorian (Florian Pelz) 1 sibling, 1 reply; 31+ messages in thread From: Julien Lepiller @ 2023-02-17 6:34 UTC (permalink / raw) To: Maxim Cournoyer, 61255; +Cc: ludo, Florian Pelz, Thiago Jung Bauermann French: Nouveau format @samp{rpm} pour la commande @command{guix pack} Vous pouvez désormais produire une archive RPM (avec l'extension .rpm) avec la commande @command{guix pack --format=rpm} qui propose donc une nouvelle manière de distribuer les logiciels construits avec Guix. Voici un exemple permettant de générer une archive RPM pour le paquet @code{hello} : @example guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello @end example Consultez @command{info \"(guix.fr) Invoquer guix pack\"} pour plus d'informations. Le 17 février 2023 02:49:37 GMT+01:00, Maxim Cournoyer <maxim.cournoyer@gmail.com> a écrit : >* etc/news.scm: Add entry. > >--- > >Changes in v2: >- New commit > > etc/news.scm | 17 ++++++++++++++++- > 1 file changed, 16 insertions(+), 1 deletion(-) > >diff --git a/etc/news.scm b/etc/news.scm >index 211a176170..1eefdd1636 100644 >--- a/etc/news.scm >+++ b/etc/news.scm >@@ -9,7 +9,7 @@ > ;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org> > ;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com> > ;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> >-;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> >+;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> > ;; Copyright © 2021 Leo Famulari <leo@famulari.name> > ;; Copyright © 2021 Zhu Zihao <all_but_last@163.com> > ;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> >@@ -26,6 +26,21 @@ > (channel-news > (version 0) > >+ (entry (commit "63622d2a234b707be5df07d8290a81b3247947e7") >+ (title >+ (en "New @samp{rpm} format for the @command{guix pack} command")) >+ (body >+ (en "RPM archives (with the .rpm file extension) can now be produced >+via the @command{guix pack --format=rpm} command, providing an alternative >+distribution path for software built with Guix. Here is a simple example that >+generates an RPM archive for the @code{hello} package: >+ >+@example >+guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello >+@end example >+ >+See @command{info \"(guix) Invoking guix pack\"} for more information."))) >+ > (entry (commit "137b91f03bbb7f1df71cf10c4f79ae57fbcea400") > (title > (en "New @option{--with-version} package transformation option") ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format. 2023-02-17 6:34 ` Julien Lepiller @ 2023-02-17 17:32 ` Maxim Cournoyer 0 siblings, 0 replies; 31+ messages in thread From: Maxim Cournoyer @ 2023-02-17 17:32 UTC (permalink / raw) To: Julien Lepiller; +Cc: ludo, Florian Pelz, 61255, Thiago Jung Bauermann Hi Julien! Julien Lepiller <julien@lepiller.eu> writes: > French: > > Nouveau format @samp{rpm} pour la commande @command{guix pack} > > > Vous pouvez désormais produire une archive RPM (avec l'extension .rpm) > avec la commande @command{guix pack --format=rpm} qui propose donc une > nouvelle manière de distribuer les logiciels construits avec > Guix. Voici un exemple permettant de générer une archive RPM pour le > paquet @code{hello} : > > @example > guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello > @end example > > Consultez @command{info \"(guix.fr) Invoquer guix pack\"} pour plus d'informations. Merci! Intégré comme suit dans ma branche locale: --8<---------------cut here---------------start------------->8--- 1 file changed, 16 insertions(+), 3 deletions(-) etc/news.scm | 19 ++++++++++++++++--- modified etc/news.scm @@ -4,7 +4,7 @@ ;; Copyright © 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr> ;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com> ;; Copyright © 2019, 2020 Konrad Hinsen <konrad.hinsen@fastmail.net> -;; Copyright © 2019, 2020, 2021 Julien Lepiller <julien@lepiller.eu> +;; Copyright © 2019, 2020, 2021, 2023 Julien Lepiller <julien@lepiller.eu> ;; Copyright © 2019–2023 Florian Pelz <pelzflorian@pelzflorian.de> ;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org> ;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com> @@ -28,7 +28,8 @@ (entry (commit "63622d2a234b707be5df07d8290a81b3247947e7") (title - (en "New @samp{rpm} format for the @command{guix pack} command")) + (en "New @samp{rpm} format for the @command{guix pack} command") + (fr "Nouveau format @samp{rpm} pour la commande @command{guix pack}")) (body (en "RPM archives (with the .rpm file extension) can now be produced via the @command{guix pack --format=rpm} command, providing an alternative @@ -39,7 +40,19 @@ guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello @end example -See @command{info \"(guix) Invoking guix pack\"} for more information."))) +See @command{info \"(guix) Invoking guix pack\"} for more information.") + (fr "Vous pouvez désormais produire une archive RPM (avec l'extension +.rpm) avec la commande @command{guix pack --format=rpm} qui propose +donc une nouvelle manière de distribuer les logiciels construits avec +Guix. Voici un exemple permettant de générer une archive RPM pour le +paquet @code{hello} : + +@example +guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello +@end example + +Consultez @command{info \"(guix.fr) Invoquer guix pack\"} pour plus +d'informations."))) (entry (commit "137b91f03bbb7f1df71cf10c4f79ae57fbcea400") (title --8<---------------cut here---------------end--------------->8--- -- Thanks, Maxim ^ permalink raw reply [flat|nested] 31+ messages in thread
* [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format. 2023-02-17 1:49 ` [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format Maxim Cournoyer 2023-02-17 6:34 ` Julien Lepiller @ 2023-02-17 15:12 ` pelzflorian (Florian Pelz) 1 sibling, 0 replies; 31+ messages in thread From: pelzflorian (Florian Pelz) @ 2023-02-17 15:12 UTC (permalink / raw) To: Maxim Cournoyer; +Cc: ludo, Julien Lepiller, 61255, Thiago Jung Bauermann Hi Maxim! Two things. First, could you include this German translation? > (title > (en "New @samp{rpm} format for the @command{guix pack} command")) (de "Neues Format @samp{rpm} für den Befehl @command{guix pack}") > (body > (en "RPM archives (with the .rpm file extension) can now be produced (de "Sie können jetzt auch RPM-Archive (mit der Dateinamenserweiterung .rpm) erzeugen mit dem Befehl @command{guix pack --format=rpm}. Damit haben Sie einen alternativen Distributionsweg für mit Guix erstellte Software. Hier sehen Sie ein einfaches Beispiel, wie Sie ein RPM-Archiv für das Paket @code{hello} erzeugen: @example guix pack --format=rpm --symlink=/usr/bin/hello=bin/hello hello @end example Siehe @command{info \"(guix.de) Aufruf von guix pack\"} für mehr Informationen.") —Other than that, I just tried using your patch to make hello.rpm as in the news example and to make another advent.rpm with open-adventure. To my surprise, I could install both (on a fresh install of Fedora Server x86_64 without Guix installed), even though hello and open-adventure both reference /gnu/store/5h2w4qi9hk1qzzgi1w83220ydslinr4s-glibc-2.33. From reading your documentation, I had not expected this. Perhaps you should mention that it is possible to both run `sudo rpm -i hello.rpm` and `sudo rpm -i advent.rpm` and it does not conflict? Regards, Florian ^ permalink raw reply [flat|nested] 31+ messages in thread
end of thread, other threads:[~2023-02-24 2:39 UTC | newest] Thread overview: 31+ messages (download: mbox.gz / follow: Atom feed) -- links below jump to the message on this page -- 2023-02-03 16:19 [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 1/5] pack: Extract keyword-ref procedure from debian-archive Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 2/5] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer 2023-02-04 1:11 ` Ludovic Courtès 2023-02-04 3:43 ` Maxim Cournoyer 2023-02-12 18:14 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès 2023-02-16 15:12 ` Maxim Cournoyer 2023-02-23 15:44 ` [bug#61255] (%guile-for-build) default in ‘computed-file’ Ludovic Courtès 2023-02-24 2:38 ` Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 3/5] pack: Extract populate-profile-root from self-contained-tarball/builder Maxim Cournoyer 2023-02-03 22:14 ` [bug#61255] [PATCH 4/5] tests: pack: Fix indentation Maxim Cournoyer 2023-02-12 18:20 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès 2023-02-16 15:22 ` Maxim Cournoyer 2023-02-23 15:47 ` Ludovic Courtès 2023-02-03 22:14 ` [bug#61255] [PATCH 5/5] pack: Add RPM format Maxim Cournoyer 2023-02-12 18:52 ` [bug#61255] [PATCH 0/5] Add support for the RPM format to "guix pack" Ludovic Courtès 2023-02-16 22:17 ` Maxim Cournoyer 2023-02-12 18:57 ` Ludovic Courtès 2023-02-16 15:25 ` Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 0/8] " Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 1/8] .dir-locals: Add let-keywords indentation rules Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 2/8] pack: Use let-keywords instead of keyword-ref Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 3/8] gexp: computed-file: Honor %guile-for-build Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 4/8] pack: Extract populate-profile-root from self-contained-tarball/builder Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 5/8] tests: pack: Fix indentation Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 6/8] pack: Add RPM format Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 7/8] etc: Add a news entry snippet Maxim Cournoyer 2023-02-17 1:49 ` [bug#61255] [PATCH v2 8/8] news: Add entry for the new 'rpm' guix pack format Maxim Cournoyer 2023-02-17 6:34 ` Julien Lepiller 2023-02-17 17:32 ` Maxim Cournoyer 2023-02-17 15:12 ` pelzflorian (Florian Pelz)
Code repositories for project(s) associated with this public inbox https://git.savannah.gnu.org/cgit/guix.git This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).