From 8548f995494d8d6358e6a8d7bc3b3bb5a0cbecb5 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Wed, 21 Nov 2018 16:45:08 +0300 Subject: describe: Use a procedure to format output. * guix/scripts/describe.scm (channel->sexp): New procedure. (display-checkout-info, display-profile-info): Use this. --- guix/scripts/describe.scm | 66 +++++++++++++++++++++++++++-------------------- 1 file changed, 38 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index d817d7f7ca..21b4c71526 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +19,7 @@ (define-module (guix scripts describe) #:use-module ((guix ui) #:hide (display-profile-content)) + #:use-module (guix channels) #:use-module (guix scripts) #:use-module (guix describe) #:use-module (guix profiles) @@ -84,6 +86,12 @@ Display information about the channels currently in use.\n")) (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%") string)))))) +(define (channel->sexp channel) + `(channel + (name ,(channel-name channel)) + (url ,(channel-url channel)) + (commit ,(channel-commit channel)))) + (define* (display-checkout-info fmt #:optional directory) "Display information about the current checkout according to FMT, a symbol denoting the requested format. Exit if the current directory does not lie @@ -104,10 +112,9 @@ within a Git checkout." (format #t (G_ " branch: ~a~%") (reference-shorthand head)) (format #t (G_ " commit: ~a~%") commit)) ('channels - (pretty-print `(list (channel - (name 'guix) - (url ,(dirname directory)) - (commit ,commit)))))) + (pretty-print `(list ,(channel->sexp (channel (name 'guix) + (url (dirname directory)) + (commit commit))))))) (display-package-search-path fmt))) (define (display-profile-info profile fmt) @@ -116,34 +123,37 @@ in the format specified by FMT." (define number (generation-number profile)) + (define channels + (map (lambda (entry) + (match (assq 'source (manifest-entry-properties entry)) + (('source ('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + _ ...)) + (channel (name (string->symbol (manifest-entry-name entry))) + (url url) + (commit commit))) + + ;; Pre-0.15.0 Guix does not provide that information, + ;; so there's not much we can do in that case. + (_ (channel (name 'guix) + (url "?") + (commit "?"))))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest + (if (zero? number) + profile + (generation-file-name profile number))))))) + (match fmt ('human (display-profile-content profile number)) ('channels - (pretty-print - `(list ,@(map (lambda (entry) - (match (assq 'source (manifest-entry-properties entry)) - (('source ('repository ('version 0) - ('url url) - ('branch branch) - ('commit commit) - _ ...)) - `(channel (name ',(string->symbol - (manifest-entry-name entry))) - (url ,url) - (commit ,commit))) - - ;; Pre-0.15.0 Guix does not provide that information, - ;; so there's not much we can do in that case. - (_ '???))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest - (if (zero? number) - profile - (generation-file-name profile number)))))))))) + (pretty-print `(list ,@(map channel->sexp channels))))) (display-package-search-path fmt)) -- cgit v1.2.3 From 81a40ee0cb925bc39e3044bddcfdd38ddb04f04d Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Wed, 21 Nov 2018 16:47:43 +0300 Subject: describe: Add json format. * guix/scripts/describe.scm (channel->json): New procedure. (display-checkout-info, display-profile-info): Use this. (%options): Add 'json' option. * doc/guix.texi (Invoking guix describe): Document this. --- doc/guix.texi | 5 ++++- guix/scripts/describe.scm | 19 ++++++++++++++++--- 2 files changed, 20 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 082e81bf7c..3413eb30f2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3273,7 +3273,10 @@ produce human-readable output; @item channels produce a list of channel specifications that can be passed to @command{guix pull -C} or installed as @file{~/.config/guix/channels.scm} (@pxref{Invoking -guix pull}). +guix pull}); +@item json +@cindex JSON +produce a list of channel specifications in JSON format. @end table @item --profile=@var{profile} diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 21b4c71526..0bfd983f1b 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -25,6 +25,7 @@ #:use-module (guix profiles) #:use-module ((guix scripts pull) #:select (display-profile-content)) #:use-module (git) + #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) #:use-module (ice-9 match) @@ -40,7 +41,7 @@ ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f (lambda (opt name arg result) - (unless (member arg '("human" "channels")) + (unless (member arg '("human" "channels" "json")) (leave (G_ "~a: unsupported output format~%") arg)) (alist-cons 'format (string->symbol arg) result))) (option '(#\p "profile") #t #f @@ -92,6 +93,11 @@ Display information about the channels currently in use.\n")) (url ,(channel-url channel)) (commit ,(channel-commit channel)))) +(define (channel->json channel) + (scm->json-string `((name . ,(channel-name channel)) + (url . ,(channel-url channel)) + (commit . ,(channel-commit channel))))) + (define* (display-checkout-info fmt #:optional directory) "Display information about the current checkout according to FMT, a symbol denoting the requested format. Exit if the current directory does not lie @@ -114,7 +120,12 @@ within a Git checkout." ('channels (pretty-print `(list ,(channel->sexp (channel (name 'guix) (url (dirname directory)) - (commit commit))))))) + (commit commit)))))) + ('json + (display (channel->json (channel (name 'guix) + (url (dirname directory)) + (commit commit)))) + (newline))) (display-package-search-path fmt))) (define (display-profile-info profile fmt) @@ -153,7 +164,9 @@ in the format specified by FMT." ('human (display-profile-content profile number)) ('channels - (pretty-print `(list ,@(map channel->sexp channels))))) + (pretty-print `(list ,@(map channel->sexp channels)))) + ('json + (format #t "[~a]~%" (string-join (map channel->json channels) ",")))) (display-package-search-path fmt)) -- cgit v1.2.3 From 85e9c4b91990008f2b6b07c5de6f14427d7c3a06 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Wed, 21 Nov 2018 16:35:38 +0300 Subject: describe: Add recutils format. * guix/scripts/describe.scm (channel->recutils): New procedure. (display-checkout-info, display-profile-info): Use this. (%options): Add 'recutils' option. * doc/guix.texi (Invoking guix describe): Document this. --- doc/guix.texi | 4 +++- guix/scripts/describe.scm | 23 ++++++++++++++++++++--- 2 files changed, 23 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 3413eb30f2..44594d1680 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3276,7 +3276,9 @@ pull -C} or installed as @file{~/.config/guix/channels.scm} (@pxref{Invoking guix pull}); @item json @cindex JSON -produce a list of channel specifications in JSON format. +produce a list of channel specifications in JSON format; +@item recutils +produce a list of channel specifications in Recutils format. @end table @item --profile=@var{profile} diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 0bfd983f1b..98be4ee89f 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -41,7 +41,7 @@ ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f (lambda (opt name arg result) - (unless (member arg '("human" "channels" "json")) + (unless (member arg '("human" "channels" "json" "recutils")) (leave (G_ "~a: unsupported output format~%") arg)) (alist-cons 'format (string->symbol arg) result))) (option '(#\p "profile") #t #f @@ -98,6 +98,11 @@ Display information about the channels currently in use.\n")) (url . ,(channel-url channel)) (commit . ,(channel-commit channel))))) +(define (channel->recutils channel port) + (format port "name: ~a~%" (channel-name channel)) + (format port "url: ~a~%" (channel-url channel)) + (format port "commit: ~a~%" (channel-commit channel))) + (define* (display-checkout-info fmt #:optional directory) "Display information about the current checkout according to FMT, a symbol denoting the requested format. Exit if the current directory does not lie @@ -125,7 +130,12 @@ within a Git checkout." (display (channel->json (channel (name 'guix) (url (dirname directory)) (commit commit)))) - (newline))) + (newline)) + ('recutils + (channel->recutils (channel (name 'guix) + (url (dirname directory)) + (commit commit)) + (current-output-port)))) (display-package-search-path fmt))) (define (display-profile-info profile fmt) @@ -166,7 +176,14 @@ in the format specified by FMT." ('channels (pretty-print `(list ,@(map channel->sexp channels)))) ('json - (format #t "[~a]~%" (string-join (map channel->json channels) ",")))) + (format #t "[~a]~%" (string-join (map channel->json channels) ","))) + ('recutils + (format #t "~{~a~%~}" + (map (lambda (channel) + (with-output-to-string + (lambda () + (channel->recutils channel (current-output-port))))) + channels)))) (display-package-search-path fmt)) -- cgit v1.2.3 From 60e1c1099fc3d73ed7d3235e71aae5d00ab7d773 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 Nov 2018 16:46:50 +0100 Subject: Update Guile-SQLite3 URL everywhere. * README: Update Guile-SQLite3 URL. * doc/guix.texi (Requirements): Likewise. * guix/store/database.scm (sqlite-exec): Likewise. * m4/guix.m4 (GUIX_CHECK_GUILE_SQLITE3): Likewise. --- README | 2 +- doc/guix.texi | 2 +- guix/store/database.scm | 2 +- m4/guix.m4 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/README b/README index 4c76c4bc43..a7a818c5c8 100644 --- a/README +++ b/README @@ -24,7 +24,7 @@ GNU Guix currently depends on the following packages: - [[https://notabug.org/cwebber/guile-gcrypt][Guile-Gcrypt]] 0.1.0 or later - [[https://www.gnu.org/software/make/][GNU Make]] - [[https://www.gnutls.org][GnuTLS]] compiled with guile support enabled - - [[https://notabug.org/civodul/guile-sqlite3][Guile-SQLite3]], version 0.1.0 or later + - [[https://notabug.org/guile-sqlite3/guile-sqlite3][Guile-SQLite3]], version 0.1.0 or later - [[https://gitlab.com/guile-git/guile-git][Guile-Git]] - [[http://www.zlib.net/][zlib]] - optionally [[https://savannah.nongnu.org/projects/guile-json/][Guile-JSON]], for the 'guix import pypi' command diff --git a/doc/guix.texi b/doc/guix.texi index 44594d1680..648f3e50bd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -641,7 +641,7 @@ later, including 2.2.x; (@pxref{Guile Preparations, how to install the GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}); @item -@uref{https://notabug.org/civodul/guile-sqlite3, Guile-SQLite3}, version 0.1.0 +@uref{https://notabug.org/guile-sqlite3/guile-sqlite3, Guile-SQLite3}, version 0.1.0 or later; @item @c FIXME: Specify a version number once a release has been made. diff --git a/guix/store/database.scm b/guix/store/database.scm index 38796910da..e6bfbe763e 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -53,7 +53,7 @@ (define sqlite-exec ;; XXX: This is was missing from guile-sqlite3 until - ;; . + ;; . (let ((exec (pointer->procedure int (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) diff --git a/m4/guix.m4 b/m4/guix.m4 index da3c65f8f7..5c846f7618 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -162,7 +162,7 @@ dnl Check whether a recent-enough Guile-Sqlite3 is available. AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [ dnl Check whether 'sqlite-bind-arguments' is available. It was introduced dnl in February 2018: - dnl . + dnl . AC_CACHE_CHECK([whether Guile-Sqlite3 is available and recent enough], [guix_cv_have_recent_guile_sqlite3], [GUILE_CHECK([retval], -- cgit v1.2.3 From 694e638e7811f363ee1438066f4beddea17981e6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 22 Nov 2018 16:51:45 +0100 Subject: status: Display 'build-remote' events. * guix/status.scm (print-build-event): Add clause for 'build-remote'. --- guix/status.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index ffa9d9e93c..2ceb56788a 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -393,6 +393,9 @@ addition to build events." expected hash: ~a actual hash: ~a~%")) expected actual)) + (('build-remote drv host _ ...) + (format port (info (G_ "offloading build of ~a to '~a'")) drv host) + (newline port)) (('build-log pid line) (if (multiplexed-output-supported?) (if (not pid) -- cgit v1.2.3 From 08f410834bffbe1e55633a0a4c87caba69d7fa92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 20 Oct 2018 19:28:05 +0200 Subject: pack: Add '--profile-name'. * guix/scripts/pack.scm (self-contained-tarball): Add #:profile-name and honor it. (squashfs-image, docker-image): Add #:profile-name. (%default-options): Add 'profile-name'. (%options, show-help): Add "--profile-name". (guix-pack): Honor it. * tests/guix-pack-localstatedir.sh: New file. * Makefile.am (SH_TESTS): Add it. * doc/guix.texi (Invoking guix pack): Document "--profile-name". --- Makefile.am | 1 + doc/guix.texi | 7 ++-- guix/scripts/pack.scm | 20 +++++++++++- tests/guix-pack-localstatedir.sh | 69 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 94 insertions(+), 3 deletions(-) create mode 100644 tests/guix-pack-localstatedir.sh (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index eda87f3124..70ec2e52ef 100644 --- a/Makefile.am +++ b/Makefile.am @@ -410,6 +410,7 @@ SH_TESTS = \ tests/guix-gc.sh \ tests/guix-hash.sh \ tests/guix-pack.sh \ + tests/guix-pack-localstatedir.sh \ tests/guix-pack-relocatable.sh \ tests/guix-package.sh \ tests/guix-package-net.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index 648f3e50bd..594aca731a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3488,8 +3488,11 @@ For instance, @code{-S /opt/gnu/bin=bin} creates a @file{/opt/gnu/bin} symlink pointing to the @file{bin} sub-directory of the profile. @item --localstatedir -Include the ``local state directory'', @file{/var/guix}, in the -resulting pack. +@itemx --profile-name=@var{name} +Include the ``local state directory'', @file{/var/guix}, in the resulting +pack, and notably the @file{/var/guix/profiles/per-user/root/@var{name}} +profile---by default @var{name} is @code{guix-profile}, which corresponds to +@file{~root/.guix-profile}. @file{/var/guix} contains the store database (@pxref{The Store}) as well as garbage-collector roots (@pxref{Invoking guix gc}). Providing it in diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a86b95dd38..ce46f549cc 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -149,6 +149,7 @@ dependencies are registered." (define* (self-contained-tarball name profile #:key target + (profile-name "guix-profile") deduplicate? (compressor (first %compressors)) localstatedir? @@ -221,6 +222,7 @@ added to the pack." ;; . (populate-single-profile-directory %root #:profile #$profile + #:profile-name #$profile-name #:closure "profile" #:database #+database) @@ -279,6 +281,7 @@ added to the pack." (define* (squashfs-image name profile #:key target + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -377,6 +380,7 @@ added to the pack." (define* (docker-image name profile #:key target + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -587,6 +591,7 @@ please email '~a'~%") (define %default-options ;; Alist of default option values. `((format . tarball) + (profile-name . "guix-profile") (system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) @@ -658,6 +663,13 @@ please email '~a'~%") (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) + (option '("profile-name") #t #f + (lambda (opt name arg result) + (match arg + ((or "guix-profile" "current-guix") + (alist-cons 'profile-name arg result)) + (_ + (leave (G_ "~a: unsupported profile name~%") arg))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -690,6 +702,9 @@ Create a bundle of PACKAGE.\n")) -m, --manifest=FILE create a pack with the manifest from FILE")) (display (G_ " --localstatedir include /var/guix in the resulting pack")) + (display (G_ " + --profile-name=NAME + populate /var/guix/profiles/.../NAME")) (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) @@ -779,7 +794,8 @@ Create a bundle of PACKAGE.\n")) (#f (leave (G_ "~a: unknown pack format~%") pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (profile-name (assoc-ref opts 'profile-name))) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest @@ -798,6 +814,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? + #:profile-name + profile-name #:archiver archiver))) (mbegin %store-monad diff --git a/tests/guix-pack-localstatedir.sh b/tests/guix-pack-localstatedir.sh new file mode 100644 index 0000000000..b734b0f7e3 --- /dev/null +++ b/tests/guix-pack-localstatedir.sh @@ -0,0 +1,69 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 Ludovic Courtès +# +# 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 . + +# +# Test the 'guix pack --localstatedir' command-line utility. +# + +guix pack --version + +# 'guix pack --localstatedir' produces derivations that depend on +# guile-sqlite3 and guile-gcrypt. To make that relatively inexpensive, run +# the test in the user's global store if possible, on the grounds that +# binaries may already be there or can be built or downloaded inexpensively. + +NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`" +localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`" +GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket" +export NIX_STORE_DIR GUIX_DAEMON_SOCKET + +if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))' +then + exit 77 +fi + +# Build a tarball with '--localstatedir' +the_pack="`guix pack -C none --localstatedir --profile-name=current-guix \ + guile-bootstrap`" +test_directory="`mktemp -d`" +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT + +cd "$test_directory" +tar -xf "$the_pack" + +profile="`find -name current-guix`" +test "`readlink $profile`" = "current-guix-1-link" +test -s "`dirname $profile`/../../../db/db.sqlite" +test -x ".`guix build guile-bootstrap`/bin/guile" +cd - + +# Make sure the store database is not completely bogus. +guile -c "(use-modules (sqlite3) (guix config) (ice-9 match)) + + (define db + (sqlite-open (string-append \"$test_directory\" + %localstatedir + \"/guix/db/db.sqlite\") + SQLITE_OPEN_READONLY)) + + (define stmt + (sqlite-prepare db \"SELECT * FROM ValidPaths;\")) + + (match (sqlite-fold cons '() stmt) + ((#(ids paths hashes times derivers sizes) ...) + (exit (member \"`guix build guile-bootstrap`\" paths))))" -- cgit v1.2.3