From a2b2070b679ff7e92d856c7d6775f5f67ce4792d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 9 Sep 2018 11:54:27 +0200 Subject: bootstrap: %bootstrap-inputs: Wrap input lists into thunks. * gnu/packages/bootstrap.scm (%bootstrap-inputs): Change to procedure. Update users; prepares for Mes bootstrap. * gnu/packages/commencement.scm (%boot0-inputs, %boot1-inputs, %boot2-inputs, %boot3-inputs, %boot4-inputs, %boot5-inputs, %boot-6-inputs): Change to procedure. Update users. * tests/builders.scm (%bootstrap-inputs, %bootstrap-search-paths): Make a procedure, filter on package?. Update users. --- guix/scripts/pack.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 1916f3b9d7..28462d9b8d 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -388,9 +388,9 @@ the image." "Return the C compiler that uses the bootstrap toolchain. This is used only by '--bootstrap', for testing purposes." (define bootstrap-toolchain - (list (first (assoc-ref %bootstrap-inputs "gcc")) - (first (assoc-ref %bootstrap-inputs "binutils")) - (first (assoc-ref %bootstrap-inputs "libc")))) + (list (first (assoc-ref (%bootstrap-inputs) "gcc")) + (first (assoc-ref (%bootstrap-inputs) "binutils")) + (first (assoc-ref (%bootstrap-inputs) "libc")))) (c-compiler bootstrap-toolchain #:guile %bootstrap-guile)) -- cgit v1.2.3 From efe3c5717dbb613dae9c99c2618ba326de50677c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 9 Sep 2018 11:43:23 +0200 Subject: guix: copy-linux-headers: Extract procedure, add headers. * guix/build/make-bootstrap.scm (copy-linux-headers): New procedure; extract from make-stripped-libc and add headers for Mes bootstrap. (make-stripped-libc): Use it. --- guix/build/make-bootstrap.scm | 72 +++++++++++++++++++++++++++++++------------ 1 file changed, 53 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 43b136248f..0c7b4ac6fd 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis ;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (guix build utils) - #:export (make-stripped-libc)) + #:export (copy-linux-headers + make-stripped-libc)) ;; Commentary: ;; @@ -31,6 +33,53 @@ ;; ;; Code: +(define (copy-linux-headers output kernel-headers) + "Copy to OUTPUT the subset of KERNEL-HEADERS that is needed when producing a +bootstrap libc." + + (let* ((incdir (string-append output "/include"))) + (mkdir-p incdir) + + ;; Copy some of the Linux-Libre headers that glibc headers + ;; refer to. + (mkdir (string-append incdir "/linux")) + (for-each (lambda (file) + (install-file (pk 'src (string-append kernel-headers "/include/linux/" file)) + (pk 'dest (string-append incdir "/linux")))) + '( + "a.out.h" ; for 2.2.5 + "atalk.h" ; for 2.2.5 + "errno.h" + "falloc.h" + "if_addr.h" ; for 2.16.0 + "if_ether.h" ; for 2.2.5 + "if_link.h" ; for 2.16.0 + "ioctl.h" + "kernel.h" + "limits.h" + "neighbour.h" ; for 2.16.0 + "netlink.h" ; for 2.16.0 + "param.h" + "prctl.h" ; for 2.16.0 + "posix_types.h" + "rtnetlink.h" ; for 2.16.0 + "socket.h" + "stddef.h" + "swab.h" ; for 2.2.5 + "sysctl.h" + "sysinfo.h" ; for 2.2.5 + "types.h" + "version.h" ; for 2.2.5 + )) + + (copy-recursively (string-append kernel-headers "/include/asm") + (string-append incdir "/asm")) + (copy-recursively (string-append kernel-headers "/include/asm-generic") + (string-append incdir "/asm-generic")) + (copy-recursively (string-append kernel-headers "/include/linux/byteorder") + (string-append incdir "/linux/byteorder")) + #t)) + (define (make-stripped-libc output libc kernel-headers) "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed when producing a bootstrap libc." @@ -43,25 +92,10 @@ when producing a bootstrap libc." (string-append incdir "/mach")) #t)) - (define (copy-linux-headers output kernel-headers) + (define (copy-libc+linux-headers output kernel-headers) (let* ((incdir (string-append output "/include"))) (copy-recursively (string-append libc "/include") incdir) - - ;; Copy some of the Linux-Libre headers that glibc headers - ;; refer to. - (mkdir (string-append incdir "/linux")) - (for-each (lambda (file) - (install-file (string-append kernel-headers "/include/linux/" file) - (string-append incdir "/linux"))) - '("limits.h" "errno.h" "socket.h" "kernel.h" - "sysctl.h" "param.h" "ioctl.h" "types.h" - "posix_types.h" "stddef.h" "falloc.h")) - - (copy-recursively (string-append kernel-headers "/include/asm") - (string-append incdir "/asm")) - (copy-recursively (string-append kernel-headers "/include/asm-generic") - (string-append incdir "/asm-generic")) - #t)) + (copy-linux-headers output kernel-headers))) (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ @@ -80,6 +114,6 @@ _nonshared\\.a)$") (if (directory-exists? (string-append kernel-headers "/include/mach")) (copy-mach-headers output kernel-headers) - (copy-linux-headers output kernel-headers))) + (copy-libc+linux-headers output kernel-headers))) -- cgit v1.2.3 From 89e7f90d0b40bc4f15f902cc3b82c3effa87dd02 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 11 Jul 2018 13:03:33 +0530 Subject: build-system: python: Do not double wrap executables. * guix/build/python-build-system.scm (wrap): Only wrap executables that have not already been wrapped. * guix/build/utils.scm (wrapper?): New function. --- guix/build/python-build-system.scm | 9 ++++----- guix/build/utils.scm | 9 +++++++++ 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 5bb0ba49d5..73b554c766 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015, 2018 Mark H Weaver ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -186,11 +187,9 @@ when running checks after installing the package." (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) - (map (cut string-append dir "/" <>) - (or (scandir dir (lambda (f) - (let ((s (stat (string-append dir "/" f)))) - (eq? 'regular (stat:type s))))) - '()))) + (find-files dir (lambda (file stat) + (and (eq? 'regular (stat:type stat)) + (not (wrapper? file)))))) (define bindirs (append-map (match-lambda diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 5fe3286843..cb5621a5a9 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver +;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -87,6 +88,7 @@ patch-/usr/bin/file fold-port-matches remove-store-references + wrapper? wrap-program invoke @@ -1003,6 +1005,13 @@ known as `nuke-refs' in Nixpkgs." (put-u8 out (char->integer char)) result)))))) +(define (wrapper? prog) + "Return #t if PROG is a wrapper as produced by 'wrap-program'." + (and (file-exists? prog) + (let ((base (basename prog))) + (and (string-prefix? "." base) + (string-suffix? "-real" base))))) + (define* (wrap-program prog #:rest vars) "Make a wrapper for PROG. VARS should look like this: -- cgit v1.2.3 From 782f1ea9f693639b8feb3152fa6a280356ab1167 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Jan 2019 09:49:33 +0100 Subject: utils: Switch to the new 'setvbuf' API. * guix/build/utils.scm (setvbuf) [(and guile-2 (not guile-2.2))]: New procedure. (remove-store-references): Use the 2.2 'setvbuf' API style. * guix/build/gnu-build-system.scm (gnu-build): Likewise. --- guix/build/gnu-build-system.scm | 6 +++--- guix/build/utils.scm | 26 +++++++++++++++++++++++--- 2 files changed, 26 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index e5f3197b0a..7d92b8d72e 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -784,8 +784,8 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." (+ (time-second diff) (/ (time-nanosecond diff) 1e9)))) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) ;; Encoding/decoding errors shouldn't be silent. (fluid-set! %default-port-conversion-strategy 'error) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index cb5621a5a9..a21dbb0128 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver @@ -101,7 +101,27 @@ locale-category->string)) + +;;; +;;; Guile 2.0 compatibility later. +;;; +;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer. +(cond-expand + ((and guile-2 (not guile-2.2)) + (define (setvbuf port mode . rest) + (apply (@ (guile) setvbuf) port + (match mode + ('line _IOLBF) + ('block _IOFBF) + ('none _IONBF) + (_ mode)) ;an _IO* integer + rest)) + + (module-replace! (current-module) '(setvbuf))) + (else #f)) + + ;;; ;;; Directories. ;;; @@ -989,8 +1009,8 @@ known as `nuke-refs' in Nixpkgs." ;; We cannot use `regexp-exec' here because it cannot deal with ;; strings containing NUL characters. (format #t "removing store references from `~a'...~%" file) - (setvbuf in _IOFBF 65536) - (setvbuf out _IOFBF 65536) + (setvbuf in 'block 65536) + (setvbuf out 'block 65536) (fold-port-matches (lambda (match result) (put-bytevector out (string->utf8 store)) (put-u8 out (char->integer #\/)) -- cgit v1.2.3 From f380f9d55e6757c242acf6c71c4a3ccfcdb066b2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Jan 2019 11:00:42 +0100 Subject: build-system/gnu: Report invocation errors in a human-friendly way. * guix/build/utils.scm (report-invoke-error): New procedure. * guix/build/gnu-build-system.scm (gnu-build): Guard against 'invoke-error?'. --- guix/build/gnu-build-system.scm | 43 ++++++++++++++++++++++------------------- guix/build/utils.scm | 17 ++++++++++++++++ 2 files changed, 40 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 7d92b8d72e..3f68ad52ed 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -790,28 +790,31 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." ;; Encoding/decoding errors shouldn't be silent. (fluid-set! %default-port-conversion-strategy 'error) - ;; The trick is to #:allow-other-keys everywhere, so that each procedure in - ;; PHASES can pick the keyword arguments it's interested in. - (every (match-lambda - ((name . proc) - (let ((start (current-time time-monotonic))) - (format #t "starting phase `~a'~%" name) - (let ((result (apply proc args)) - (end (current-time time-monotonic))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" - name result - (elapsed-time end start)) - - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ + (guard (c ((invoke-error? c) + (report-invoke-error c) + (exit 1))) + ;; The trick is to #:allow-other-keys everywhere, so that each procedure in + ;; PHASES can pick the keyword arguments it's interested in. + (every (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (format #t "starting phase `~a'~%" name) + (let ((result (apply proc args)) + (end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name result + (elapsed-time end start)) + + ;; Issue a warning unless the result is #t. + (unless (eqv? result #t) + (format (current-error-port) "\ ## WARNING: phase `~a' returned `~s'. Return values other than #t ## are deprecated. Please migrate this package so that its phase ## procedures report errors by raising an exception, and otherwise ## always return #t.~%" - name result)) + name result)) - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases)) + ;; Dump the environment variables as a shell script, for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables") + result)))) + phases))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index a21dbb0128..55d34b67e7 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -98,6 +98,7 @@ invoke-error-exit-status invoke-error-term-signal invoke-error-stop-signal + report-invoke-error locale-category->string)) @@ -622,6 +623,11 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and ((_ phases (add-after old-phase-name new-phase-name new-phase)) (alist-cons-after old-phase-name new-phase-name new-phase phases)))) + +;;; +;;; Program invocation. +;;; + (define-condition-type &invoke-error &error invoke-error? (program invoke-error-program) @@ -643,6 +649,17 @@ if the exit code is non-zero; otherwise return #t." (stop-signal (status:stop-sig code)))))) #t)) +(define* (report-invoke-error c #:optional (port (current-error-port))) + "Report to PORT about C, an '&invoke-error' condition, in a human-friendly +way." + (format port "command~{ ~s~} failed with ~:[signal~;status~] ~a~%" + (cons (invoke-error-program c) + (invoke-error-arguments c)) + (invoke-error-exit-status c) + (or (invoke-error-exit-status c) + (invoke-error-term-signal c) + (invoke-error-stop-signal c)))) + ;;; ;;; Text substitution (aka. sed). -- cgit v1.2.3 From 0fb9a8df429a7b9f40610ff15baaff0d8e31e8cf Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 2 Jan 2018 21:43:07 +0100 Subject: guix: Add wrap-script. * guix/build/utils.scm (wrap-script): New procedure. (&wrap-error): New condition. (wrap-error?, wrap-error-program, wrap-error-type): New procedures. * tests/build-utils.scm ("wrap-script, simple case", "wrap-script, with encoding declaration", "wrap-script, raises condition"): New tests. --- guix/build/utils.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/build-utils.scm | 102 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 227 insertions(+) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 55d34b67e7..b7cd748d81 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver ;;; Copyright © 2018 Arun Isaac +;;; Copyright © 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -90,6 +91,11 @@ remove-store-references wrapper? wrap-program + wrap-script + + wrap-error? + wrap-error-program + wrap-error-type invoke invoke-error? @@ -1042,6 +1048,11 @@ known as `nuke-refs' in Nixpkgs." (put-u8 out (char->integer char)) result)))))) +(define-condition-type &wrap-error &error + wrap-error? + (program wrap-error-program) + (type wrap-error-type)) + (define (wrapper? prog) "Return #t if PROG is a wrapper as produced by 'wrap-program'." (and (file-exists? prog) @@ -1146,6 +1157,120 @@ with definitions for VARS." (chmod prog-tmp #o755) (rename-file prog-tmp prog)))) +(define wrap-script + (let ((interpreter-regex + (make-regexp + (string-append "^#! ?(/[^ ]+/bin/(" + (string-join '("python[^ ]*" + "Rscript" + "perl" + "ruby" + "bash" + "sh") "|") + "))( ?.*)"))) + (coding-line-regex + (make-regexp + ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)"))) + (lambda* (prog #:key (guile (which "guile")) #:rest vars) + "Wrap the script PROG such that VARS are set first. The format of VARS +is the same as in the WRAP-PROGRAM procedure. This procedure differs from +WRAP-PROGRAM in that it does not create a separate shell script. Instead, +PROG is modified directly by prepending a Guile script, which is interpreted +as a comment in the script's language. + +Special encoding comments as supported by Python are recreated on the second +line. + +Note that this procedure can only be used once per file as Guile scripts are +not supported." + (define update-env + (match-lambda + ((var sep '= rest) + `(setenv ,var ,(string-join rest sep))) + ((var sep 'prefix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append ,(string-join rest sep) + ,sep current) + ,(string-join rest sep))))) + ((var sep 'suffix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append current ,sep + ,(string-join rest sep)) + ,(string-join rest sep))))) + ((var '= rest) + `(setenv ,var ,(string-join rest ":"))) + ((var 'prefix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append ,(string-join rest ":") + ":" current) + ,(string-join rest ":"))))) + ((var 'suffix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append current ":" + ,(string-join rest ":")) + ,(string-join rest ":"))))))) + (let-values (((interpreter args coding-line) + (call-with-ascii-input-file prog + (lambda (p) + (let ((first-match + (false-if-exception + (regexp-exec interpreter-regex (read-line p))))) + (values (and first-match (match:substring first-match 1)) + (and first-match (match:substring first-match 3)) + (false-if-exception + (and=> (regexp-exec coding-line-regex (read-line p)) + (lambda (m) (match:substring m 0)))))))))) + (if interpreter + (let* ((header (format #f "\ +#!~a --no-auto-compile +#!#; ~a +#\\-~s +#\\-~s +" + guile + (or coding-line "Guix wrapper") + (cons 'begin (map update-env + (match vars + ((#:guile _ . vars) vars) + (_ vars)))) + `(let ((cl (command-line))) + (apply execl ,interpreter + (car cl) + (cons (car cl) + (append + ',(string-split args #\space) + cl)))))) + (template (string-append prog ".XXXXXX")) + (out (mkstemp! template)) + (st (stat prog)) + (mode (stat:mode st))) + (with-throw-handler #t + (lambda () + (call-with-ascii-input-file prog + (lambda (p) + (format out header) + (dump-port p out) + (close out) + (chmod template mode) + (rename-file template prog) + (set-file-time prog st)))) + (lambda (key . args) + (format (current-error-port) + "wrap-script: ~a: error: ~a ~s~%" + prog key args) + (false-if-exception (delete-file template)) + (raise (condition + (&wrap-error (program prog) + (type key)))) + #f))) + (raise (condition + (&wrap-error (program prog) + (type 'no-interpreter-found))))))))) + ;;; ;;; Locales. diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 7d49446f66..1c9084514d 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2015, 2016 Ludovic Courtès +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -122,4 +123,105 @@ (and (zero? (close-pipe pipe)) str)))))) +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/sh + +echo hello world")) + + (test-equal "wrap-script, simple case" + (string-append + (format #f "\ +#!GUILE --no-auto-compile +#!#; Guix wrapper +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + '(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/sh" + (car cl) + (cons (car cl) + (append '("") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (mock ((guix build utils) which (const "GUILE")) + (wrap-script script-file-name + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path")))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args +# vim:fileencoding=utf-8 +print('hello world')")) + + (test-equal "wrap-script, with encoding declaration" + (string-append + (format #f "\ +#!MYGUILE --no-auto-compile +#!#; # vim:fileencoding=utf-8 +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + `(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/python3" + (car cl) + (cons (car cl) + (append '("" "-and" "-args") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path"))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(test-assert "wrap-script, raises condition" + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port "This is not a script"))) + (chmod script-file-name #o777) + (catch 'srfi-34 + (lambda () + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path")))) + (lambda (type obj) + (wrap-error? obj))))))) + (test-end) -- cgit v1.2.3 From 278409e7e9ad63b80afa0a40c220dedd78c0aa54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 9 Mar 2019 15:08:11 +0100 Subject: build-system/gnu: Always look for license files in the source tree. Fixes . * guix/build/gnu-build-system.scm (install-license-files): Add #:out-of-source?. [find-source-directory]: New procedure. Use it to Determine the source directory and look for license files there. --- guix/build/gnu-build-system.scm | 48 ++++++++++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 3f68ad52ed..f62e96112d 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -735,8 +735,29 @@ which cannot be found~%" (define* (install-license-files #:key outputs (license-file-regexp %license-file-regexp) + out-of-source? #:allow-other-keys) "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'." + (define (find-source-directory package) + ;; For an out-of-source build, guess the source directory location + ;; relative to the current directory. Return #f on failure. + (match (scandir ".." + (lambda (file) + (and (not (member file '("." ".." "build"))) + (file-is-directory? + (string-append "../" file))))) + (() ;hmm, no source + #f) + ((source) ;only one other file + (string-append "../" source)) + ((directories ...) ;pick the most likely one + ;; This happens for example with libstdc++, which lives within the GCC + ;; source tree. + (any (lambda (directory) + (and (string-prefix? package directory) + (string-append "../" directory))) + directories)))) + (let* ((regexp (make-regexp license-file-regexp)) (out (or (assoc-ref outputs "out") (match outputs @@ -744,14 +765,25 @@ which cannot be found~%" output)))) (package (strip-store-file-name out)) (directory (string-append out "/share/doc/" package)) - (files (scandir "." (lambda (file) - (regexp-exec regexp file))))) - (format #t "installing ~a license files~%" (length files)) - (for-each (lambda (file) - (if (file-is-directory? file) - (copy-recursively file directory) - (install-file file directory))) - files) + (source (if out-of-source? + (find-source-directory + (package-name->name+version package)) + ".")) + (files (and source + (scandir source + (lambda (file) + (regexp-exec regexp file)))))) + (if files + (begin + (format #t "installing ~a license files from '~a'~%" + (length files) source) + (for-each (lambda (file) + (if (file-is-directory? file) + (copy-recursively file directory) + (install-file file directory))) + (map (cut string-append source "/" <>) files))) + (format (current-error-port) + "failed to find license files~%")) #t)) (define %standard-phases -- cgit v1.2.3 From 6db044db45495aae471e1e8f537e267a0cb25cf5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 10 Mar 2019 22:16:14 +0100 Subject: build-system/gnu: Copy license files to all the outputs. Fixes . Reported by Leo Famulari . * guix/build/gnu-build-system.scm (install-license-files)[copy-to-directories]: New procedure. Call it to copy license files to all the outputs. --- guix/build/gnu-build-system.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index f62e96112d..afa1886ecd 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -758,13 +758,23 @@ which cannot be found~%" (string-append "../" directory))) directories)))) + (define (copy-to-directories directories sub-directory) + (lambda (file) + (for-each (if (file-is-directory? file) + (cut copy-recursively file <>) + (cut install-file file <>)) + (map (cut string-append <> "/" sub-directory) + directories)))) + (let* ((regexp (make-regexp license-file-regexp)) (out (or (assoc-ref outputs "out") (match outputs (((_ . output) _ ...) output)))) (package (strip-store-file-name out)) - (directory (string-append out "/share/doc/" package)) + (outputs (match outputs + (((_ . outputs) ...) + outputs))) (source (if out-of-source? (find-source-directory (package-name->name+version package)) @@ -777,10 +787,9 @@ which cannot be found~%" (begin (format #t "installing ~a license files from '~a'~%" (length files) source) - (for-each (lambda (file) - (if (file-is-directory? file) - (copy-recursively file directory) - (install-file file directory))) + (for-each (copy-to-directories outputs + (string-append "share/doc/" + package)) (map (cut string-append source "/" <>) files))) (format (current-error-port) "failed to find license files~%")) -- cgit v1.2.3 From ea89b62a18c988ead226cec542a5f4fdd3d58ac0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 10 Mar 2019 22:21:14 +0100 Subject: packages: 'patch-and-repack' specifies a 'type' property for the derivation. * guix/packages.scm (patch-and-repack): Pass #:properties to 'gexp->derivation'. --- guix/packages.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 8515bb7c6f..e5e568efab 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -645,7 +645,9 @@ specifies modules in scope when evaluating SNIPPET." #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild - #:guile-for-build guile-for-build)))) + #:guile-for-build guile-for-build + #:properties `((type . origin) + (patches . ,(length patches))))))) (define (transitive-inputs inputs) "Return the closure of INPUTS when considering the 'propagated-inputs' -- cgit v1.2.3 From 2f33a7321e5e37d37f57c229c8079cb4ffd10834 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 20 Mar 2019 21:38:19 -0400 Subject: cmake: Generate documentation. To prevent complicating the dependencies of a core tool, a new variant, CMAKE-MINIMAL is introduced and the CMake build system is configured to use it by default. The regular CMAKE package gains a manpage, info manual as well as HTML documentation. Fixes issue #33497 (https://bugs.gnu.org/33497). * gnu/packages/cmake.scm (gnu): Use modules (gnu packages python-xyz), (gnu packages texinfo) and (srfi srfi-1). (cmake-minimal): Rename the original cmake variable to this. [phases]{configure}: Extract the configure script arguments to... [configure-flags]: here. [properties]: Set the HIDDEN? property to #t. (cmake): New variable, which inherits from CMAKE-MINIMAL. [phases]{move-html-doc}: Add phase. [native-inputs]: Add PYTHON-SPHINX and TEXINFO. [outputs]: Add the "doc" output. [properties]: Clear the inherited HIDDEN? property. * guix/build-system/cmake.scm (default-cmake): Use CMAKE-MINIMAL instead of CMAKE. --- gnu/packages/cmake.scm | 94 +++++++++++++++++++++++++++++++++------------ guix/build-system/cmake.scm | 2 +- 2 files changed, 70 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/gnu/packages/cmake.scm b/gnu/packages/cmake.scm index 7772fbedb1..b999c0c170 100644 --- a/gnu/packages/cmake.scm +++ b/gnu/packages/cmake.scm @@ -8,6 +8,8 @@ ;;; Copyright © 2017, 2018 Marius Bakke ;;; Copyright © 2018 Arun Isaac ;;; Copyright © 2018 Tobias Geerinckx-Rice +;;; Copyright © 2019 Maxim Cournoyer + ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,11 +41,16 @@ #:use-module (gnu packages file) #:use-module (gnu packages libevent) #:use-module (gnu packages ncurses) - #:use-module (gnu packages xml)) + #:use-module (gnu packages python-xyz) + #:use-module (gnu packages texinfo) + #:use-module (gnu packages xml) + #:use-module (srfi srfi-1)) -(define-public cmake +;;; This minimal variant of CMake does not include the documentation. It is +;;; used by the cmake-build-system. +(define-public cmake-minimal (package - (name "cmake") + (name "cmake-minimal") (version "3.14.0") (source (origin (method url-fetch) @@ -72,6 +79,23 @@ (build-system gnu-build-system) (arguments `(#:test-target "test" + #:configure-flags + (let ((out (assoc-ref %outputs "out")) + (parallel-job-count (number->string (parallel-job-count)))) + (list "--verbose" + (string-append "--parallel=" parallel-job-count) + (string-append "--prefix=" out) + "--system-libs" + "--no-system-jsoncpp" ; FIXME: Circular dependency. + ;; By default, the man pages and other docs land + ;; in PREFIX/man and PREFIX/doc, but we want them + ;; in share/{man,doc}. Note that unlike + ;; autoconf-generated configure scripts, cmake's + ;; configure prepends "PREFIX/" to what we pass + ;; to --mandir and --docdir. + "--mandir=share/man" + ,(string-append "--docdir=share/doc/cmake-" + (version-major+minor version)))) #:make-flags (let ((skipped-tests (list "BundleUtilities" ; This test fails on Guix. @@ -119,25 +143,10 @@ (setenv "CMAKE_INCLUDE_PATH" (or (getenv "CPATH") (getenv "C_INCLUDE_PATH"))) #t))) + ;; CMake uses its own configure script. (replace 'configure - (lambda* (#:key outputs #:allow-other-keys) - (let ((out (assoc-ref outputs "out"))) - (invoke - "./configure" "--verbose" - (string-append "--parallel=" (number->string (parallel-job-count))) - (string-append "--prefix=" out) - "--system-libs" - "--no-system-jsoncpp" ; FIXME: Circular dependency. - ;; By default, the man pages and other docs land - ;; in PREFIX/man and PREFIX/doc, but we want them - ;; in share/{man,doc}. Note that unlike - ;; autoconf-generated configure scripts, cmake's - ;; configure prepends "PREFIX/" to what we pass - ;; to --mandir and --docdir. - "--mandir=share/man" - ,(string-append - "--docdir=share/doc/cmake-" - (version-major+minor version))))))))) + (lambda* (#:key (configure-flags '()) #:allow-other-keys) + (apply invoke "./configure" configure-flags)))))) (inputs `(("bzip2" ,bzip2) ("curl" ,curl) @@ -159,12 +168,47 @@ CMake is used to control the software compilation process using simple platform and compiler independent configuration files. CMake generates native makefiles and workspaces that can be used in the compiler environment of your choice.") - (license (list license:bsd-3 ; cmake - license:bsd-4 ; cmcompress - license:bsd-2 ; cmlibarchive - license:expat ; cmjsoncpp is dual MIT/public domain + (properties '((hidden? . #t))) + (license (list license:bsd-3 ; cmake + license:bsd-4 ; cmcompress + license:bsd-2 ; cmlibarchive + license:expat ; cmjsoncpp is dual MIT/public domain license:public-domain)))) ; cmlibarchive/archive_getdate.c +(define-public cmake + (package + (inherit cmake-minimal) + (name "cmake") + (arguments + (substitute-keyword-arguments (package-arguments cmake-minimal) + ((#:configure-flags configure-flags ''()) + `(append ,configure-flags + ;; Extra configure flags used to generate the documentation. + '("--sphinx-info" + "--sphinx-man" + "--sphinx-html"))) + ((#:phases phases) + `(modify-phases ,phases + (add-after 'install 'move-html-doc + (lambda* (#:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (doc (assoc-ref outputs "doc")) + (html (string-append "/share/doc/cmake-" + ,(version-major+minor + (package-version cmake-minimal)) + "/html"))) + (copy-recursively (string-append out html) + (string-append doc html)) + (delete-file-recursively (string-append out html)) + #t))))))) + ;; Extra inputs required to build the documentation. + (native-inputs + `(,@(package-native-inputs cmake-minimal) + ("python-sphinx" ,python-sphinx) + ("texinfo" ,texinfo))) + (outputs '("out" "doc")) + (properties (alist-delete 'hidden? (package-properties cmake-minimal))))) + (define-public emacs-cmake-mode (package (inherit cmake) diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index ee116c5a4c..ca88fadddf 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -48,7 +48,7 @@ ;; Do not use `@' to avoid introducing circular dependencies. (let ((module (resolve-interface '(gnu packages cmake)))) - (module-ref module 'cmake))) + (module-ref module 'cmake-minimal))) (define* (lower name #:key source inputs native-inputs outputs system target -- cgit v1.2.3 From 6bbb37a545912c6bb2513ee08587ee4fe39cc330 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 3 Apr 2019 00:09:20 -0400 Subject: build-system/python: Move the check phase after the install phase. A reproducibility problem was discovered while packaging python-pygithub where the bytecode produced by running the tests would interfere with the result of the install phase byte compilation. Moving the check phase after the install phase solves the problem. * guix/build/python-build-system.scm (%standard-phases): Add comment, move the check phase after the install phase. --- guix/build/python-build-system.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 73b554c766..7c00306b3e 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -250,16 +250,21 @@ installed with setuptools." #t) (define %standard-phases - ;; 'configure' phase is not needed. + ;; The build phase only builds C extensions and copies the Python sources, + ;; while the install phase byte-compiles and copies them to the prefix + ;; directory. The tests are run after the install phase because otherwise + ;; the cached .pyc generated during the tests execution seem to interfere + ;; with the byte compilation of the install phase. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) (add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism enable-bytecode-determinism) (delete 'bootstrap) - (delete 'configure) - (replace 'install install) - (replace 'check check) + (delete 'configure) ;not needed (replace 'build build) + (delete 'check) ;moved after the install phase + (replace 'install install) + (add-after 'install 'check check) (add-after 'install 'wrap wrap) (add-before 'strip 'rename-pth-file rename-pth-file))) -- cgit v1.2.3 From 267966f9111f4af905479fd01e7689912ccba026 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Jun 2019 15:04:09 +0200 Subject: download: Add 'url-fetch/executable'. * guix/download.scm (built-in-download): Add #:executable? parameter. Pass #:recursive? to 'raw-derivation' and add "executable" to the #:env-vars alist when EXECUTABLE? is true. (url-fetch): Add #:executable? and pass it to 'built-in-download'. (url-fetch/executable): New procedure. --- guix/download.scm | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index cd5d61cd13..7782693f23 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -36,6 +36,7 @@ #:use-module (srfi srfi-26) #:export (%mirrors url-fetch + url-fetch/executable url-fetch/tarbomb url-fetch/zipbomb download-to-store)) @@ -420,8 +421,10 @@ (define* (built-in-download file-name url #:key system hash-algo hash mirrors content-addressed-mirrors + executable? (guile 'unused)) - "Download FILE-NAME from URL using the built-in 'download' builder. + "Download FILE-NAME from URL using the built-in 'download' builder. When +EXECUTABLE? is true, make the downloaded file executable. This is an \"out-of-band\" download in that the returned derivation does not explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the @@ -433,6 +436,7 @@ download by itself using its own dependencies." #:system system #:hash-algo hash-algo #:hash hash + #:recursive? executable? #:inputs `((,mirrors) (,content-addressed-mirrors)) @@ -444,7 +448,10 @@ download by itself using its own dependencies." #:env-vars `(("url" . ,(object->string url)) ("mirrors" . ,mirrors) ("content-addressed-mirrors" - . ,content-addressed-mirrors)) + . ,content-addressed-mirrors) + ,@(if executable? + '(("executable" . "1")) + '())) ;; Do not offload this derivation because we cannot be ;; sure that the remote daemon supports the 'download' @@ -455,11 +462,13 @@ download by itself using its own dependencies." (define* (url-fetch url hash-algo hash #:optional name #:key (system (%current-system)) - (guile (default-guile))) + (guile (default-guile)) + executable?) "Return a fixed-output derivation that fetches URL (a string, or a list of strings denoting alternate URLs), which is expected to have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the base name of URL; -optionally, NAME can specify a different file name. +optionally, NAME can specify a different file name. When EXECUTABLE? is true, +make the downloaded file executable. When one of the URL starts with mirror://, then its host part is interpreted as the name of a mirror scheme, taken from %MIRROR-FILE. @@ -490,10 +499,21 @@ in the store." #:system system #:hash-algo hash-algo #:hash hash + #:executable? executable? #:mirrors %mirror-file #:content-addressed-mirrors %content-addressed-mirror-file))))) +(define* (url-fetch/executable url hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile))) + "Like 'url-fetch', but make the downloaded file executable." + (url-fetch url hash-algo hash name + #:system system + #:guile guile + #:executable? #t)) + (define* (url-fetch/tarbomb url hash-algo hash #:optional name #:key (system (%current-system)) -- cgit v1.2.3 From 836a85da0e8609d40716581be00802ee43463038 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Jun 2019 15:10:45 +0200 Subject: gnu: bootstrap: Download the bootstrap bash, mkdir, tar, and xz binaries. * gnu/packages/bootstrap.scm (%bootstrap-executables): New variable. (bootstrap-executable-url, bootstrap-executable): New procedure. (raw-build)[->store]: Use 'run-with-store' and 'origin->derivation'. Add calls to 'derivation->output-path', and remove the list of references passed to 'add-text-to-store' for BUILDER. Augment the list of #:inputs passed to 'derivation'. (package-from-tarball): Use 'bootstrap-executable' instead of 'search-bootstrap-binary'. (%bootstrap-glibc, %bootstrap-gcc, %bootstrap-mescc-tools) (%bootstrap-mes): Likewise. * guix/scripts/environment.scm (environment-bash): Use 'bootstrap-executable' instead of 'search-bootstrap-binary'. (guix-environment): Adjust CONTAINER? case accordingly. * po/guix/POTFILES.in: Add gnu/packages/bootstrap.scm. --- gnu/packages/bootstrap.scm | 123 +++++++++++++++++++++++++++++++++++-------- guix/scripts/environment.scm | 10 ++-- po/guix/POTFILES.in | 1 + 3 files changed, 107 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 50786d9f21..255141ae87 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2014, 2015, 2018 Mark H Weaver ;;; Copyright © 2017 Efraim Flashner ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen @@ -33,8 +33,11 @@ #:select (derivation derivation->output-path)) #:use-module ((guix utils) #:select (gnu-triplet->nix-system)) #:use-module (guix memoization) + #:use-module (guix i18n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (bootstrap-origin package-with-bootstrap-guile @@ -60,6 +63,82 @@ ;;; Code: + +;;; +;;; The bootstrap executables: 'bash', 'mkdir', 'tar', 'xz'. They allow us to +;;; extract the very first tarball. +;;; + +(define %bootstrap-executables + ;; List of bootstrap executables and their recursive hashes (as per 'guix + ;; hash -r'), taking their executable bit into account. + `(("aarch64-linux" + ("bash" + ,(base32 "13aqhqb8nydlwq1ah9974q0iadx1pb95v13wzzyf7vgv6nasrwzr")) + ("mkdir" + ,(base32 "1pxhdp7ldwavmm71xbh9wc197cb2nr66acjn26yjx3732cixh9ws")) + ("tar" + ,(base32 "1j51gv08sfg277yxj73xd564wjq3f8xwd6s9rbcg8v9gms47m4cx")) + ("xz" + ,(base32 "1d779rwsrasphg5g3r37qppcqy3p7ay1jb1y83w7x4i3qsc7zjy2"))) + ("armhf-linux" + ("bash" + ,(base32 "0s6f1s26g4dsrrkl39zblvwpxmbzi6n9mgqf6vxsqz42gik6bgyn")) + ("mkdir" + ,(base32 "1r5rcp35niyxfkrdf00y2ba8ifrq9bi76cr63lwjf2l655j1i5p7")) + ("tar" + ,(base32 "0dksx5im3fv8ximz7368bsax9f26nn47ds74298flm5lnvpv9xly")) + ("xz" + ,(base32 "1cqqavghjfr0iwxqf61lrssv27wfigysgq2rs4rm1gkmn04yn1k3"))) + ("i686-linux" + ("bash" + ,(base32 "0rjaxyzjdllfkf1abczvgaf3cdcc7mmahyvdbkjmjzhgz92pv23g")) + ("mkdir" + ,(base32 "133ybmfpkmsnysrzbngwvbysqnsmfi8is8zifs7i7n6n600h4s1w")) + ("tar" + ,(base32 "07830bx29ad5i0l1ykj0g0b1jayjdblf01sr3ww9wbnwdbzinqms")) + ("xz" + ,(base32 "0i9kxdi17bm5gxfi2xzm0y73p3ii0cqxli1sbljm6rh2fjgyn90k"))) + ("mips64el-linux" + ("bash" + ,(base32 "1aw046dhda240k9pb9iaj5aqkm23gkvxa9j82n4k7fk87nbrixw6")) + ("mkdir" + ,(base32 "0c9j6qgyw84zxbry3ypifzll13gy8ax71w40kdk1h11jbgla3f5k")) + ("tar" + ,(base32 "06gmqdjq3rl8lr47b9fyx4ifnm5x56ymc8lyryp1ax1j2s4y5jb4")) + ("xz" + ,(base32 "09j1d69qr0hhhx4k4ih8wp00dfc9y4rp01hfg3vc15yxd0jxabh5"))))) + +(define (bootstrap-executable-url program system) + "Return the URL where PROGRAM can be found for SYSTEM." + (string-append + "https://git.savannah.gnu.org/cgit/guix.git/plain/gnu/packages/bootstrap/" + system "/" program + "?id=44f07d1dc6806e97c4e9ee3e6be883cc59dc666e")) + +(define bootstrap-executable + (mlambda (program system) + "Return an origin for PROGRAM, a statically-linked bootstrap executable +built for SYSTEM." + (let ((system (if (string=? system "x86_64-linux") + "i686-linux" + system))) + (match (assoc-ref (assoc-ref %bootstrap-executables system) + program) + (#f + (raise (condition + (&message + (message + (format #f (G_ "could not find bootstrap binary '~a' \ +for system '~a'") + program system)))))) + ((sha256) + (origin + (method url-fetch/executable) + (uri (bootstrap-executable-url program system)) + (file-name program) + (sha256 sha256))))))) + ;;; ;;; Helper procedures. @@ -133,8 +212,8 @@ or false to signal an error." (invoke (string-append "bin/" ,program-to-test) "--version")))))))) (inputs - `(("tar" ,(search-bootstrap-binary "tar" (%current-system))) - ("xz" ,(search-bootstrap-binary "xz" (%current-system))) + `(("tar" ,(bootstrap-executable "tar" (%current-system))) + ("xz" ,(bootstrap-executable "xz" (%current-system))) ("tarball" ,(bootstrap-origin (source (%current-system)))))) (source #f) (synopsis description) @@ -258,11 +337,9 @@ or false to signal an error." #:key outputs system search-paths #:allow-other-keys) (define (->store file) - (add-to-store store file #t "sha256" - (or (search-bootstrap-binary file - system) - (error "bootstrap binary not found" - file system)))) + (run-with-store store + (origin->derivation (bootstrap-executable file system) + system))) (let* ((tar (->store "tar")) (xz (->store "xz")) @@ -312,14 +389,16 @@ $out/bin/guile -c ~s $out ~a # Sanity check. $out/bin/guile --version~%" - mkdir xz tar + (derivation->output-path mkdir) + (derivation->output-path xz) + (derivation->output-path tar) (format #f "~s" make-guile-wrapper) - bash) - (list mkdir xz tar bash)))) + (derivation->output-path bash))))) (derivation store name - bash `(,builder) + (derivation->output-path bash) `(,builder) #:system system - #:inputs `((,bash) (,builder) (,guile)) + #:inputs `((,bash) (,mkdir) (,tar) (,xz) + (,builder) (,guile)) #:env-vars `(("GUILE_TARBALL" . ,(derivation->output-path guile)))))) @@ -486,8 +565,8 @@ $out/bin/guile --version~%" #t)))))) (inputs - `(("tar" ,(search-bootstrap-binary "tar" (%current-system))) - ("xz" ,(search-bootstrap-binary "xz" (%current-system))) + `(("tar" ,(bootstrap-executable "tar" (%current-system))) + ("xz" ,(bootstrap-executable "xz" (%current-system))) ("tarball" ,(bootstrap-origin (origin (method url-fetch) @@ -570,9 +649,9 @@ exec ~a/bin/.gcc-wrapped -B~a/lib \ (chmod "gcc" #o555) #t)))))) (inputs - `(("tar" ,(search-bootstrap-binary "tar" (%current-system))) - ("xz" ,(search-bootstrap-binary "xz" (%current-system))) - ("bash" ,(search-bootstrap-binary "bash" (%current-system))) + `(("tar" ,(bootstrap-executable "tar" (%current-system))) + ("xz" ,(bootstrap-executable "xz" (%current-system))) + ("bash" ,(bootstrap-executable "bash" (%current-system))) ("libc" ,%bootstrap-glibc) ("tarball" ,(bootstrap-origin (origin @@ -644,8 +723,8 @@ exec ~a/bin/.gcc-wrapped -B~a/lib \ (invoke tar "xvf" (string-append builddir "/binaries.tar")))))))) (inputs - `(("tar" ,(search-bootstrap-binary "tar" (%current-system))) - ("xz" ,(search-bootstrap-binary "xz" (%current-system))) + `(("tar" ,(bootstrap-executable "tar" (%current-system))) + ("xz" ,(bootstrap-executable "xz" (%current-system))) ("tarball" ,(bootstrap-origin (origin @@ -693,8 +772,8 @@ exec ~a/bin/.gcc-wrapped -B~a/lib \ (invoke tar "xvf" (string-append builddir "/binaries.tar")))))))) (inputs - `(("tar" ,(search-bootstrap-binary "tar" (%current-system))) - ("xz" ,(search-bootstrap-binary "xz" (%current-system))) + `(("tar" ,(bootstrap-executable "tar" (%current-system))) + ("xz" ,(bootstrap-executable "xz" (%current-system))) ("tarball" ,(bootstrap-origin (origin diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c1341628a8..ac269083c8 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -29,7 +29,7 @@ #:use-module (guix search-paths) #:use-module (guix build utils) #:use-module (guix monads) - #:use-module ((guix gexp) #:select (lower-inputs)) + #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu build linux-container) @@ -40,7 +40,8 @@ #:use-module (gnu packages bash) #:use-module (gnu packages commencement) #:use-module (gnu packages guile) - #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) + #:use-module ((gnu packages bootstrap) + #:select (bootstrap-executable %bootstrap-guile)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -600,8 +601,7 @@ Otherwise, return the derivation for the Bash package." (package->derivation bash)) ;; Use the bootstrap Bash instead. ((and container? bootstrap?) - (interned-file - (search-bootstrap-binary "bash" system))) + (lower-object (bootstrap-executable "bash" system))) (else (return #f))))) @@ -730,7 +730,7 @@ message if any test fails." (container? (let ((bash-binary (if bootstrap? - bash + (derivation->output-path bash) (string-append (derivation->output-path bash) "/bin/sh")))) (launch-environment/container #:command command diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index ceee589b2e..5172345e5a 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -36,6 +36,7 @@ gnu/installer/steps.scm gnu/installer/timezone.scm gnu/installer/user.scm gnu/installer/utils.scm +gnu/packages/bootstrap.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm -- cgit v1.2.3 From 03d76577b96ba81c9921eb3a297d42db8644280b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Jun 2019 21:26:22 +0200 Subject: tests: Make builds less expensive. The switch to the reduced bootstrap broke build time assumptions made by tests, notably the assumption that GNU-MAKE-BOOT0 was cheap to build. This commit adjusts this to make these tests cheaper. * gnu/packages/bootstrap.scm (%bootstrap-inputs-for-tests): New variable. * guix/tests.scm (gnu-make-for-tests): New variable. * tests/guix-environment.sh: Use GNU-MAKE-FOR-TESTS instead of GNU-MAKE-BOOT0. Remove test with FINDUTILS-BOOT0. * tests/guix-package-net.sh (boot_make): Use GNU-MAKE-FOR-TESTS. * tests/packages.scm ("GNU Make, bootstrap"): Likewise. * tests/profiles.scm ("profile-derivation relative symlinks, two entries"): Likewise. * tests/union.scm (%bootstrap-inputs): Remove. ("union-build"): Use %BOOTSTRAP-INPUTS-FOR-TESTS instead of %BOOTSTRAP-INPUTS. --- gnu/packages/bootstrap.scm | 14 +++++++++++++- guix/tests.scm | 33 ++++++++++++++++++++++++++++++++- tests/guix-environment.sh | 27 ++++++--------------------- tests/guix-package-net.sh | 2 +- tests/packages.scm | 6 +++--- tests/profiles.scm | 7 +++---- tests/union.scm | 9 +++------ 7 files changed, 61 insertions(+), 37 deletions(-) (limited to 'guix') diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 255141ae87..c78aaa33d0 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -53,7 +53,9 @@ %bootstrap-glibc %bootstrap-inputs %bootstrap-mescc-tools - %bootstrap-mes)) + %bootstrap-mes + + %bootstrap-inputs-for-tests)) ;;; Commentary: ;;; @@ -809,4 +811,14 @@ exec ~a/bin/.gcc-wrapped -B~a/lib \ ;; In gnu-build-system.scm, we rely on the availability of Bash. ("bash" ,%bootstrap-coreutils&co))) +(define %bootstrap-inputs-for-tests + ;; These are bootstrap inputs that are cheap to produce (no compilation + ;; needed) and that are meant to be used for testing. (These are those we + ;; used before the Mes-based reduced bootstrap.) + `(("libc" ,%bootstrap-glibc) + ("gcc" ,%bootstrap-gcc) + ("binutils" ,%bootstrap-binutils) + ("coreutils&co" ,%bootstrap-coreutils&co) + ("bash" ,%bootstrap-coreutils&co))) + ;;; bootstrap.scm ends here diff --git a/guix/tests.scm b/guix/tests.scm index 66d60e964e..9df6353798 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -23,8 +23,10 @@ #:use-module (guix packages) #:use-module (guix base32) #:use-module (guix serialization) + #:use-module ((guix utils) #:select (substitute-keyword-arguments)) #:use-module (gcrypt hash) #:use-module (guix build-system gnu) + #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) @@ -50,7 +52,9 @@ with-derivation-narinfo with-derivation-substitute dummy-package - dummy-origin)) + dummy-origin + + gnu-make-for-tests)) ;;; Commentary: ;;; @@ -364,6 +368,33 @@ default values, and with EXTRA-FIELDS set as specified." (sha256 (base32 (make-string 52 #\x)))))) (origin (inherit o) extra-fields ...))) +(define gnu-make-for-tests + ;; This is a variant of 'gnu-make-boot0' that can be built with minimal + ;; resources. + (package-with-bootstrap-guile + (package + (inherit gnu-make) + (name "make-test-boot0") + (arguments + `(#:guile ,%bootstrap-guile + #:implicit-inputs? #f + #:tests? #f ;cannot run "make check" + ,@(substitute-keyword-arguments (package-arguments gnu-make) + ((#:phases phases) + `(modify-phases ,phases + (replace 'build + (lambda _ + (invoke "./build.sh") + #t)) + (replace 'install + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin"))) + (install-file "make" bin) + #t)))))))) + (native-inputs '()) ;no need for 'pkg-config' + (inputs %bootstrap-inputs-for-tests)))) + ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) ;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index a670db36be..fb1c1a022d 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -156,7 +156,7 @@ if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then # Compute the build environment for the initial GNU Make. guix environment --bootstrap --no-substitutes --search-paths --pure \ - -e '(@@ (gnu packages commencement) gnu-make-boot0)' > "$tmpdir/a" + -e '(@ (guix tests) gnu-make-for-tests)' > "$tmpdir/a" # Make sure bootstrap binaries are in the profile. profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` @@ -177,30 +177,15 @@ then # Make sure that the shell spawned with '--exec' sees the same environment # as returned by '--search-paths'. guix environment --bootstrap --no-substitutes --pure \ - -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ + -e '(@ (guix tests) gnu-make-for-tests)' \ -- /bin/sh -c 'echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" ( . "$tmpdir/a" ; echo $PATH $CPATH $LIBRARY_PATH ) > "$tmpdir/c" cmp "$tmpdir/b" "$tmpdir/c" rm "$tmpdir"/* - # Compute the build environment for the initial GNU Findutils. - guix environment --bootstrap --no-substitutes --search-paths --pure \ - -e '(@@ (gnu packages commencement) findutils-boot0)' > "$tmpdir/a" - profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` - - # Make sure the bootstrap binaries are all listed where they belong. - grep -E "^export PATH=\"$profile/bin\"" "$tmpdir/a" - grep -E "^export CPATH=\"$profile/include\"" "$tmpdir/a" - grep -E "^export LIBRARY_PATH=\"$profile/lib\"" "$tmpdir/a" - for dep in bootstrap-binaries-0 gcc-bootstrap-0 glibc-bootstrap-0 \ - make-boot0 - do - guix gc --references "$profile" | grep "$dep" - done - # The following test assumes 'make-boot0' has a "debug" output. - make_boot0_debug="`guix build -e '(@@ (gnu packages commencement) gnu-make-boot0)' | grep -e -debug`" + make_boot0_debug="`guix build -e '(@ (guix tests) gnu-make-for-tests)' | grep -e -debug`" test "x$make_boot0_debug" != "x" # Make sure the "debug" output is not listed. @@ -210,7 +195,7 @@ then # Compute the build environment for the initial GNU Make, but add in the # bootstrap Guile as an ad-hoc addition. guix environment --bootstrap --no-substitutes --search-paths --pure \ - -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ + -e '(@ (guix tests) gnu-make-for-tests)' \ --ad-hoc guile-bootstrap > "$tmpdir/a" profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` @@ -227,14 +212,14 @@ then # Make sure a package list with plain package objects and package+output # tuples can be used with -e. expr_list_test_code=" -(list (@@ (gnu packages commencement) gnu-make-boot0) +(list (@ (guix tests) gnu-make-for-tests) (list (@ (gnu packages bootstrap) %bootstrap-guile) \"out\"))" guix environment --bootstrap --ad-hoc --no-substitutes --search-paths \ --pure -e "$expr_list_test_code" > "$tmpdir/a" profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` - for dep in make-boot0 guile-bootstrap + for dep in make-test-boot0 guile-bootstrap do guix gc --references "$profile" | grep "$dep" done diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index 82c346dd4c..48a94865e1 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -57,7 +57,7 @@ test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" -boot_make="(@@ (gnu packages commencement) gnu-make-boot0)" +boot_make="(@ (guix tests) gnu-make-for-tests)" boot_make_drv="`guix build -e "$boot_make" | grep -v -e -debug`" guix package --bootstrap -p "$profile" -i "$boot_make_drv" test -L "$profile-2-link" diff --git a/tests/packages.scm b/tests/packages.scm index af1f76e36d..bd100bea5b 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -935,9 +935,9 @@ (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) (test-assert "GNU Make, bootstrap" - ;; GNU Make is the first program built during bootstrap; we choose it - ;; here so that the test doesn't last for too long. - (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0))) + ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the + ;; test doesn't last for too long. + (let ((gnu-make gnu-make-for-tests)) (and (package? gnu-make) (or (location? (package-location gnu-make)) (not (package-location gnu-make))) diff --git a/tests/profiles.scm b/tests/profiles.scm index eef93e24cf..a4e28672b5 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -239,11 +239,10 @@ (unless (network-reachable?) (test-skip 1)) (test-assertm "profile-derivation relative symlinks, two entries" (mlet* %store-monad - ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0)) - (manifest -> (packages->manifest - (list %bootstrap-guile gnu-make-boot0))) + ((manifest -> (packages->manifest + (list %bootstrap-guile gnu-make-for-tests))) (guile (package->derivation %bootstrap-guile)) - (make (package->derivation gnu-make-boot0)) + (make (package->derivation gnu-make-for-tests)) (drv (profile-derivation manifest #:relative-symlinks? #t #:hooks '() diff --git a/tests/union.scm b/tests/union.scm index 091895ff8e..a8387edf42 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. @@ -32,9 +32,6 @@ #:use-module (rnrs io ports) #:use-module (ice-9 match)) -(define %bootstrap-inputs - (@@ (gnu packages commencement) %bootstrap-inputs+toolchain)) - ;; Exercise the (guix build union) module. (define %store @@ -99,8 +96,8 @@ ;; Purposefully leave duplicate entries. (filter (compose package? cadr) - (append (%bootstrap-inputs) - (take (%bootstrap-inputs) 3))))) + (append %bootstrap-inputs-for-tests + (take %bootstrap-inputs-for-tests 3))))) (builder `(begin (use-modules (guix build union)) (union-build (assoc-ref %outputs "out") -- cgit v1.2.3 From 1ba0b1e6ec41afd94a3c5f907b1122204dcb5d9d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Jun 2019 21:35:08 +0200 Subject: packages: Remove 'search-bootstrap-binary'. * gnu/packages.scm (%bootstrap-binaries-path, search-bootstrap-binary): Remove. * gnu/packages/bootstrap.scm (bootstrap-executable): Export. * guix/tests.scm (bootstrap-binary-file, search-bootstrap-binary): Export. * tests/derivations.scm: Remove (gnu packages) import. * tests/grafts.scm: Likewise. * tests/guix-daemon.sh: Likewise. --- gnu/packages.scm | 25 +------------------------ gnu/packages/bootstrap.scm | 1 + guix/tests.scm | 35 +++++++++++++++++++++++++++++++++++ tests/derivations.scm | 1 - tests/grafts.scm | 3 +-- tests/guix-daemon.sh | 4 ++-- 6 files changed, 40 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/gnu/packages.scm b/gnu/packages.scm index 4742f49405..2d7622d397 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -46,10 +46,8 @@ #:export (search-patch search-patches search-auxiliary-file - search-bootstrap-binary %patch-path %auxiliary-files-path - %bootstrap-binaries-path %package-module-path %default-package-module-path @@ -75,18 +73,13 @@ ;;; ;;; Code: -;; By default, we store patches, auxiliary files and bootstrap binaries +;; By default, we store patches and auxiliary files ;; alongside Guile modules. This is so that these extra files can be ;; found without requiring a special setup, such as a specific ;; installation directory and an extra environment variable. One ;; advantage of this setup is that everything just works in an ;; auto-compilation setting. -(define %bootstrap-binaries-path - (make-parameter - (map (cut string-append <> "/gnu/packages/bootstrap") - %load-path))) - (define %auxiliary-files-path (make-parameter (map (cut string-append <> "/gnu/packages/aux-files") @@ -108,22 +101,6 @@ FILE-NAME found in %PATCH-PATH." (list (search-patch file-name) ...)) -(define (search-bootstrap-binary file-name system) - "Search the bootstrap binary FILE-NAME for SYSTEM. Raise an error if not -found." - ;; On x86_64 always use the i686 binaries. - (let ((system (match system - ("x86_64-linux" "i686-linux") - (_ system)))) - (or (search-path (%bootstrap-binaries-path) - (string-append system "/" file-name)) - (raise (condition - (&message - (message - (format #f (G_ "could not find bootstrap binary '~a' \ -for system '~a'") - file-name system)))))))) - (define %distro-root-directory ;; Absolute file name of the module hierarchy. Since (gnu packages …) might ;; live in a directory different from (guix), try to get the best match. diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index c78aaa33d0..428a89e927 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -43,6 +43,7 @@ package-with-bootstrap-guile glibc-dynamic-linker + bootstrap-executable bootstrap-guile-origin %bootstrap-guile diff --git a/guix/tests.scm b/guix/tests.scm index 9df6353798..ff31bcad44 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -23,14 +23,18 @@ #:use-module (guix packages) #:use-module (guix base32) #:use-module (guix serialization) + #:use-module (guix monads) #:use-module ((guix utils) #:select (substitute-keyword-arguments)) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (gcrypt hash) #:use-module (guix build-system gnu) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:use-module (web uri) #:export (open-connection-for-tests @@ -44,6 +48,8 @@ shebang-too-long? with-environment-variable + search-bootstrap-binary + mock %test-substitute-urls test-assertm @@ -87,6 +93,35 @@ store))) +(define (bootstrap-binary-file program system) + "Return the absolute file name where bootstrap binary PROGRAM for SYSTEM is +stored." + (string-append (dirname (search-path %load-path + "gnu/packages/bootstrap.scm")) + "/bootstrap/" system "/" program)) + +(define (search-bootstrap-binary file-name system) + "Search the bootstrap binary FILE-NAME for SYSTEM. Raise an error if not +found." + ;; Note: Keep bootstrap binaries on the local file system so that the 'guix' + ;; package can provide them as inputs and copy them to the right place. + (let* ((system (match system + ("x86_64-linux" "i686-linux") + (_ system))) + (file (bootstrap-binary-file file-name system))) + (if (file-exists? file) + file + (with-store store + (run-with-store store + (mlet %store-monad ((drv (origin->derivation + (bootstrap-executable file-name system)))) + (mbegin %store-monad + (built-derivations (list drv)) + (begin + (mkdir-p (dirname file)) + (copy-file (derivation->output-path drv) file) + (return file))))))))) + (define (call-with-external-store proc) "Call PROC with an open connection to the external store or #f it there is no external store to talk to." diff --git a/tests/derivations.scm b/tests/derivations.scm index c421d094a4..25ba4c9fa0 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -29,7 +29,6 @@ #:use-module (guix tests http) #:use-module ((guix packages) #:select (package-derivation base32)) #:use-module ((guix build utils) #:select (executable-file?)) - #:use-module ((gnu packages) #:select (search-bootstrap-binary)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages guile) #:select (guile-1.8)) #:use-module (srfi srfi-1) diff --git a/tests/grafts.scm b/tests/grafts.scm index f85f3c6913..e5356decc5 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,7 +24,6 @@ #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix tests) - #:use-module ((gnu packages) #:select (search-bootstrap-binary)) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index ce82cfd1e6..ca46e34ce9 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -141,7 +141,7 @@ daemon_pid=$! GUIX_DAEMON_SOCKET="$socket" \ guile -c ' - (use-modules (guix) (gnu packages) (guix tests)) + (use-modules (guix) (guix tests)) (with-store store (let* ((build (add-text-to-store store "build.sh" @@ -165,7 +165,7 @@ kill "$daemon_pid" # honored. client_code=' - (use-modules (guix) (gnu packages) (guix tests) (srfi srfi-34)) + (use-modules (guix) (guix tests) (srfi srfi-34)) (with-store store (let* ((build (add-text-to-store store "build.sh" -- cgit v1.2.3 From cfd4e4d06e3cda0f3eed8d6b9277ce53e55404b8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Jun 2019 23:02:28 +0200 Subject: build-system/gnu: Make 'first-subdirectory' deterministic. Fixes . Reported by Christopher Baines . * guix/build/gnu-build-system.scm (first-subdirectory): Rewrite using 'scandir' so that the result is deterministic. --- guix/build/gnu-build-system.scm | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index afa1886ecd..4df0bb4904 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:use-module (ice-9 ftw) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-34) @@ -58,19 +59,14 @@ See https://reproducible-builds.org/specs/source-date-epoch/." (setenv "SOURCE_DATE_EPOCH" "1") #t) -(define (first-subdirectory dir) - "Return the path of the first sub-directory of DIR." - (file-system-fold (lambda (path stat result) - (string=? path dir)) - (lambda (path stat result) result) ; leaf - (lambda (path stat result) result) ; down - (lambda (path stat result) result) ; up - (lambda (path stat result) ; skip - (or result path)) - (lambda (path stat errno result) ; error - (error "first-subdirectory" (strerror errno))) - #f - dir)) +(define (first-subdirectory directory) + "Return the file name of the first sub-directory of DIRECTORY." + (match (scandir directory + (lambda (file) + (and (not (member file '("." ".."))) + (file-is-directory? (string-append directory "/" + file))))) + ((first . _) first))) (define* (set-paths #:key target inputs native-inputs (search-paths '()) (native-search-paths '()) -- cgit v1.2.3 From 852d30a6b615c2306a398a8065e7e28d9ec6867d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Jun 2019 21:47:57 +0200 Subject: self: Don't build (guix tests …). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes a regression introduced in 03d76577b96ba81c9921eb3a297d42db8644280b whereby 'guix-extra.drv' would pull in (guix tests), which in turn would pull in a large number of (gnu packages …), which would fail to build due to missing .patch files. * guix/self.scm (compiled-guix)[*extra-modules*]: Exclude (guix tests …) from the list of modules. --- guix/self.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 69e2381a8c..f9e65cce31 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -732,6 +732,7 @@ Info manual." (filter-map (match-lambda (('guix 'scripts _ ..1) #f) (('guix 'man-db) #f) + (('guix 'tests _ ...) #f) (name name)) (scheme-modules* source "guix")) (list *core-modules*) -- cgit v1.2.3 From 3c6b9fb5d2627c9f23b58ce530025a8dc8cc3c3c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Jun 2019 15:54:17 +0200 Subject: gexp: Remove #:pre-load-modules? parameter. * guix/gexp.scm (gexp->derivation): Remove #:pre-load-modules?. (compiled-modules): Likewise. Inline the case correspoding to PRE-LOAD-MODULES? = #t. * guix/packages.scm (patch-and-repack): Remove #:pre-load-modules?. --- guix/gexp.scm | 68 ++++++++++++++++++++----------------------------------- guix/packages.scm | 3 --- 2 files changed, 24 insertions(+), 47 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 4f2adba90a..9bf68a91f4 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -633,12 +633,6 @@ names and file names suitable for the #:allowed-references argument to leaked-env-vars local-build? (substitutable? #t) (properties '()) - - ;; TODO: This parameter is transitional; it's here - ;; to avoid a full rebuild. Remove it on the next - ;; rebuild cycle. - (pre-load-modules? #t) - deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a @@ -743,8 +737,6 @@ The other arguments are as for 'derivation'." #:module-path module-path #:extensions extensions #:guile guile-for-build - #:pre-load-modules? - pre-load-modules? #:deprecation-warnings deprecation-warnings) (return #f))) @@ -1220,11 +1212,7 @@ last one is created from the given object." (guile (%guile-for-build)) (module-path %load-path) (extensions '()) - (deprecation-warnings #f) - - ;; TODO: This flag is here to prevent a full - ;; rebuild. Remove it on the next rebuild cycle. - (pre-load-modules? #t)) + (deprecation-warnings #f)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." @@ -1257,11 +1245,8 @@ they can refer to each other." (let* ((base (basename entry ".scm")) (output (string-append output "/" base ".go"))) (format #t "[~2@a/~2@a] Compiling '~a'...~%" - (+ 1 processed - (ungexp-splicing (if pre-load-modules? - (gexp ((ungexp total))) - (gexp ())))) - (ungexp (* total (if pre-load-modules? 2 1))) + (+ 1 processed (ungexp total)) + (ungexp (* total 2)) entry) (compile-file entry #:output-file output @@ -1275,6 +1260,26 @@ they can refer to each other." processed entries))) + (define* (load-from-directory directory + #:optional (loaded 0)) + "Load all the source files found in DIRECTORY." + ;; XXX: This works around . + (let ((entries (map (cut string-append directory "/" <>) + (scandir directory regular?)))) + (fold (lambda (file loaded) + (if (file-is-directory? file) + (load-from-directory file loaded) + (begin + (format #t "[~2@a/~2@a] Loading '~a'...~%" + (+ 1 loaded) (ungexp (* 2 total)) + file) + (save-module-excursion + (lambda () + (primitive-load file))) + (+ 1 loaded)))) + loaded + entries))) + (setvbuf (current-output-port) (cond-expand (guile-2.2 'line) (else _IOLBF))) @@ -1310,32 +1315,7 @@ they can refer to each other." (mkdir (ungexp output)) (chdir (ungexp modules)) - (ungexp-splicing - (if pre-load-modules? - (gexp ((define* (load-from-directory directory - #:optional (loaded 0)) - "Load all the source files found in DIRECTORY." - ;; XXX: This works around . - (let ((entries (map (cut string-append directory "/" <>) - (scandir directory regular?)))) - (fold (lambda (file loaded) - (if (file-is-directory? file) - (load-from-directory file loaded) - (begin - (format #t "[~2@a/~2@a] Loading '~a'...~%" - (+ 1 loaded) - (ungexp (* 2 total)) - file) - (save-module-excursion - (lambda () - (primitive-load file))) - (+ 1 loaded)))) - loaded - entries))) - - (load-from-directory "."))) - (gexp ()))) - + (load-from-directory ".") (process-directory "." (ungexp output) 0)))) ;; TODO: Pass MODULES as an environment variable. diff --git a/guix/packages.scm b/guix/packages.scm index 9cd4cbc416..92859be441 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -642,9 +642,6 @@ specifies modules in scope when evaluating SNIPPET." (let ((name (tarxz-name original-file-name))) (gexp->derivation name build - ;; TODO: Remove this on the next rebuild cycle. - #:pre-load-modules? #f - #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild -- cgit v1.2.3 From 25c639e2a3b96204950f1ac8a92cb518783f0d61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Jun 2019 15:55:36 +0200 Subject: packages: 'patch-and-repack' no longer uses #:deprecation-warnings. * guix/packages.scm (patch-and-repack): Remove #:deprecation-warnings argument passed to 'gexp->derivation'. --- guix/packages.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 92859be441..9d2ab5be0f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -644,7 +644,6 @@ specifies modules in scope when evaluating SNIPPET." (gexp->derivation name build #:graft? #f #:system system - #:deprecation-warnings #t ;to avoid a rebuild #:guile-for-build guile-for-build #:properties `((type . origin) (patches . ,(length patches))))))) -- cgit v1.2.3 From 45d46223f92b0933aaf9b1392a21d09eaa1e2881 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 17 Jun 2019 16:06:27 +0200 Subject: utils: Add 'invoke/quiet'. * gnu/build/bootloader.scm (G_): Remove. (open-pipe-with-stderr, invoke/quiet): Move to... * guix/build/utils.scm: ... here. Use 'let-values' instead of 'define-values' because Guile 2.0 (the bootstrap Guile) doesn't know about 'define-values'. * po/guix/POTFILES.in: Remove gnu/build/bootloader.scm, and add guix/build/utils.scm. * tests/build-utils.scm: Remove import of (gnu build bootloader). --- gnu/build/bootloader.scm | 62 +----------------------------------------------- guix/build/utils.scm | 53 +++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 3 +-- tests/build-utils.scm | 2 -- 4 files changed, 55 insertions(+), 65 deletions(-) (limited to 'guix') diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm index c5febcde1e..9570d6dd18 100644 --- a/gnu/build/bootloader.scm +++ b/gnu/build/bootloader.scm @@ -18,15 +18,8 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build bootloader) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (ice-9 binary-ports) - #:use-module (ice-9 popen) - #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 format) - #:export (write-file-on-device - invoke/quiet)) + #:export (write-file-on-device)) ;;; @@ -43,56 +36,3 @@ (seek output offset SEEK_SET) (put-bytevector output bv)) #:binary #t))))) - -(define-syntax-rule (G_ str) str) ;for xgettext - -(define (open-pipe-with-stderr program . args) - "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect -both its standard output and standard error to the pipe. Return two value: -the pipe to read PROGRAM's data from, and the PID of the child process running -PROGRAM." - ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why - ;; we need to roll our own. - (match (pipe) - ((input . output) - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (close-port input) - (dup2 (fileno output) 1) - (dup2 (fileno output) 2) - (apply execlp program program args)) - (lambda () - (primitive-exit 127)))) - (pid - (close-port output) - (values input pid)))))) - -;; TODO: Move to (guix build utils) on the next rebuild cycle. -(define (invoke/quiet program . args) - "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard -error. If PROGRAM succeeds, print nothing and return the unspecified value; -otherwise, raise a '&message' error condition that includes the status code -and the output of PROGRAM." - (define-values (pipe pid) - (apply open-pipe-with-stderr program args)) - - (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (close-port pipe) - (match (waitpid pid) - ((_ . status) - (unless (zero? status) - (raise (condition - (&message - (message (format #f (G_ "'~a~{ ~a~}' exited with status ~a; \ -output follows:~%~%~{ ~a~%~}") - program args - (or (status:exit-val status) - status) - (reverse lines)))))))))) - (line - (loop (cons line lines)))))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index b7cd748d81..b8be73ead4 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -106,6 +106,8 @@ invoke-error-stop-signal report-invoke-error + invoke/quiet + locale-category->string)) @@ -666,6 +668,57 @@ way." (invoke-error-term-signal c) (invoke-error-stop-signal c)))) +(define (open-pipe-with-stderr program . args) + "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect +both its standard output and standard error to the pipe. Return two value: +the pipe to read PROGRAM's data from, and the PID of the child process running +PROGRAM." + ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why + ;; we need to roll our own. + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port input) + (dup2 (fileno output) 1) + (dup2 (fileno output) 2) + (apply execlp program program args)) + (lambda () + (primitive-exit 127)))) + (pid + (close-port output) + (values input pid)))))) + +(define (invoke/quiet program . args) + "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard +error. If PROGRAM succeeds, print nothing and return the unspecified value; +otherwise, raise a '&message' error condition that includes the status code +and the output of PROGRAM." + (let-values (((pipe pid) + (apply open-pipe-with-stderr program args))) + (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (close-port pipe) + (match (waitpid pid) + ((_ . status) + (unless (zero? status) + (let-syntax ((G_ (syntax-rules () ;for xgettext + ((_ str) str)))) + (raise (condition + (&message + (message (format #f (G_ "'~a~{ ~a~}' exited \ +with status ~a; output follows:~%~%~{ ~a~%~}") + program args + (or (status:exit-val status) + status) + (reverse lines))))))))))) + (line + (loop (cons line lines))))))) + ;;; ;;; Text substitution (aka. sed). diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 5172345e5a..9c4b6dedb5 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -37,6 +37,7 @@ gnu/installer/timezone.scm gnu/installer/user.scm gnu/installer/utils.scm gnu/packages/bootstrap.scm +guix/build/utils.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm @@ -79,6 +80,4 @@ guix/channels.scm guix/profiles.scm guix/git.scm guix/deprecation.scm -gnu/build/bootloader.scm nix/nix-daemon/guix-daemon.cc - diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 5678bb6a22..61e6c44e63 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -21,8 +21,6 @@ (define-module (test-build-utils) #:use-module (guix tests) #:use-module (guix build utils) - #:use-module ((gnu build bootloader) - #:select (invoke/quiet)) #:use-module ((guix utils) #:select (%current-system call-with-temporary-directory)) #:use-module (gnu packages) -- cgit v1.2.3 From 814e12dc87a191718374d811c0a3024d38dffcbb Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sun, 16 Jun 2019 10:50:15 +0200 Subject: packages: Retain version in file name when repacking source checkouts. Fixes . * guix/packages.scm (patch-and-repack): If FILE-NAME is a source checkout, reuse the name without the '-checkout' part. --- guix/packages.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 9d2ab5be0f..ac965acd2f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2019 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -505,11 +506,17 @@ specifies modules in scope when evaluating SNIPPET." (and=> (file-extension file-name) (cut string-every char-set:hex-digit <>))) + (define (checkout? directory) + ;; Return true if DIRECTORY is a checkout (git, svn, etc). + (string-suffix? "-checkout" directory)) + (define (tarxz-name file-name) ;; Return a '.tar.xz' file name based on FILE-NAME. - (let ((base (if (numeric-extension? file-name) - original-file-name - (file-sans-extension file-name)))) + (let ((base (cond ((numeric-extension? file-name) + original-file-name) + ((checkout? file-name) + (string-drop-right file-name 9)) + (else (file-sans-extension file-name))))) (string-append base (if (equal? (file-extension base) "tar") ".xz" -- cgit v1.2.3 From 9c2563a80b6f1d8fb8677f5314e6180ea9916aa5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Jun 2019 18:11:25 +0200 Subject: build-system/python: Export 'python-version'. * guix/build/python-build-system.scm (get-python-version): Rename to... (python-version): ... this. Update callers. Make public. * gnu/packages/gstreamer.scm (python-gst)[arguments]: Adjust accordingly. * gnu/packages/machine-learning.scm (ghmm)[arguments]: Likewise. * gnu/packages/openldap.scm (389-ds-base)[arguments]: Import (guix build python-build-system). Use 'python-version'. * gnu/packages/package-management.scm (conda)[arguments]: Use 'python-version'. --- gnu/packages/gstreamer.scm | 4 +--- gnu/packages/machine-learning.scm | 3 +-- gnu/packages/openldap.scm | 13 +++++-------- gnu/packages/package-management.scm | 3 +-- guix/build/python-build-system.scm | 11 ++++++----- 5 files changed, 14 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/gnu/packages/gstreamer.scm b/gnu/packages/gstreamer.scm index 2a818e078c..39a4eb5fc0 100644 --- a/gnu/packages/gstreamer.scm +++ b/gnu/packages/gstreamer.scm @@ -447,9 +447,7 @@ compression formats through the use of the libav library.") (guix build python-build-system)) #:configure-flags (let* ((python (assoc-ref %build-inputs "python")) - (python-version ((@@ (guix build python-build-system) - get-python-version) - python)) + (python-version (python-version python)) (python-sitedir (string-append "lib/python" python-version "/site-packages"))) (list (string-append diff --git a/gnu/packages/machine-learning.scm b/gnu/packages/machine-learning.scm index ba7772f66b..e216b9474a 100644 --- a/gnu/packages/machine-learning.scm +++ b/gnu/packages/machine-learning.scm @@ -210,8 +210,7 @@ classification.") (assoc-ref %standard-phases 'check)) (add-before 'check 'fix-PYTHONPATH (lambda* (#:key inputs outputs #:allow-other-keys) - (let ((python-version ((@@ (guix build python-build-system) - get-python-version) + (let ((python-version (python-version (assoc-ref inputs "python")))) (setenv "PYTHONPATH" (string-append (getenv "PYTHONPATH") diff --git a/gnu/packages/openldap.scm b/gnu/packages/openldap.scm index 43f111cf40..2f80920ed4 100644 --- a/gnu/packages/openldap.scm +++ b/gnu/packages/openldap.scm @@ -211,7 +211,11 @@ servers from Python programs.") (arguments `(#:modules ((srfi srfi-1) (guix build gnu-build-system) + ((guix build python-build-system) + #:select (python-version)) (guix build utils)) + #:imported-modules ((guix build python-build-system) + ,@%gnu-build-system-modules) #:configure-flags (list (string-append "--with-db=" (assoc-ref %build-inputs "bdb")) @@ -263,16 +267,9 @@ servers from Python programs.") (add-after 'unpack 'fix-install-location-of-python-tools (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) - (get-python-version - ;; FIXME: copied from python-build-system - (lambda (python) - (let* ((version (last (string-split python #\-))) - (components (string-split version #\.)) - (major+minor (take components 2))) - (string-join major+minor ".")))) (pythondir (string-append out "/lib/python" - (get-python-version (assoc-ref inputs "python")) + (python-version (assoc-ref inputs "python")) "/site-packages/"))) ;; Install directory must be on PYTHONPATH. (setenv "PYTHONPATH" diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index e1e7d6a5a0..81b3c321e4 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -831,8 +831,7 @@ This package provides Conda as a library.") (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (target (string-append out "/lib/python" - ((@@ (guix build python-build-system) - get-python-version) + (python-version (assoc-ref inputs "python")) "/site-packages/"))) ;; The installer aborts if the target directory is not on diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 7c00306b3e..09bd8465c8 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès +;;; Copyright © 2013, 2015, 2016, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver @@ -32,6 +32,7 @@ #:export (%standard-phases add-installed-pythonpath site-packages + python-version python-build)) ;; Commentary: @@ -147,7 +148,7 @@ (format #t "test suite not run~%")) #t) -(define (get-python-version python) +(define (python-version python) (let* ((version (last (string-split python #\-))) (components (string-split version #\.)) (major+minor (take components 2))) @@ -158,7 +159,7 @@ (let* ((out (assoc-ref outputs "out")) (python (assoc-ref inputs "python"))) (string-append out "/lib/python" - (get-python-version python) + (python-version python) "/site-packages/"))) (define (add-installed-pythonpath inputs outputs) @@ -202,7 +203,7 @@ when running checks after installing the package." (python (assoc-ref inputs "python")) (var `("PYTHONPATH" prefix ,(cons (string-append out "/lib/python" - (get-python-version python) + (python-version python) "/site-packages") (search-path-as-string->list (or (getenv "PYTHONPATH") "")))))) @@ -222,7 +223,7 @@ installed with setuptools." (let* ((out (assoc-ref outputs "out")) (python (assoc-ref inputs "python")) (site-packages (string-append out "/lib/python" - (get-python-version python) + (python-version python) "/site-packages")) (easy-install-pth (string-append site-packages "/easy-install.pth")) (new-pth (string-append site-packages "/" name ".pth"))) -- cgit v1.2.3 From 25280065814aecd7ce56baf4866b0c05acf8028b Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sat, 29 Jun 2019 19:13:49 +0200 Subject: build-system/meson: Do not inherit the 'bootstrap' phase. * guix/build/meson-build-system.scm (%standard-phases): Remove 'bootstrap'. * gnu/packages/glib.scm (glib)[arguments]: Adjust accordingly. --- gnu/packages/glib.scm | 1 - guix/build/meson-build-system.scm | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm index 62543fe114..eae8297531 100644 --- a/gnu/packages/glib.scm +++ b/gnu/packages/glib.scm @@ -200,7 +200,6 @@ shared NFS home directories.") (arguments `(#:phases (modify-phases %standard-phases - (delete 'bootstrap) (add-before 'build 'pre-build (lambda* (#:key inputs outputs #:allow-other-keys) ;; For tests/gdatetime.c. diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index d0975fcab0..8043a84abb 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -108,6 +108,7 @@ for example libraries only needed for the tests." ;; from the gnu-build-system. If the glib-or-gtk? key is #f (the default) ;; then the extra phases will be removed again in (guix build-system meson). (modify-phases glib-or-gtk:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) -- cgit v1.2.3 From 209214aaefc4248173226a2664ae6dda698b85bb Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Fri, 21 Jun 2019 09:32:38 +0200 Subject: gnu: make-bootstrap: Remove obsolete header file. * guix/build/make-bootstrap.scm (copy-linux-headers): Do not install 'a.out.h'. --- guix/build/make-bootstrap.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index e5ef1d6d2b..0d29338ce3 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -47,7 +47,6 @@ bootstrap libc." (install-file (pk 'src (string-append kernel-headers "/include/linux/" file)) (pk 'dest (string-append incdir "/linux")))) '( - "a.out.h" ; for 2.2.5 "atalk.h" ; for 2.2.5 "errno.h" "falloc.h" -- cgit v1.2.3 From 1daca4f3e568e2b351bec38111368b759704bb5f Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Thu, 4 Jul 2019 09:57:30 +0200 Subject: import: hackage: Update list of ghc-included packages. It turns out the list in the release notes is incomplete. This updates the list from /gnu/store/-ghc-8.4.3/lib/ghc-8.4.3. * guix/import/hackage.scm (ghc-standard-libraries): Update list. Signed-off-by: Ricardo Wurmus --- guix/import/hackage.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 6f426af900..5fe3d85a7f 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Eric Bavier ;;; Copyright © 2016 ng0 ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019 Robert Vollmert ;;; ;;; This file is part of GNU Guix. ;;; @@ -52,7 +53,7 @@ (define ghc-standard-libraries ;; List of libraries distributed with ghc (8.4.3). - ;; https://downloads.haskell.org/~ghc/8.4.3/docs/html/users_guide/8.4.3-notes.html + ;; Contents of ...-ghc-8.4.3/lib/ghc-8.4.3. '("ghc" "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but ;; hackage-name->package-name takes this into account. @@ -65,7 +66,9 @@ "deepseq" "directory" "filepath" + "ghc" "ghc-boot" + "ghc-boot-th" "ghc-compact" "ghc-prim" "ghci" @@ -74,8 +77,11 @@ "integer-gmp" "mtl" "parsec" + "pretty" "process" + "stm" "template-haskell" + "terminfo" "text" "time" "transformers" -- cgit v1.2.3 From c43b090326d5d73b54cab7ae41b7d1119b402d65 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sun, 7 Jul 2019 19:14:04 +0200 Subject: build-system/meson: Enable compiler optimizations. * guix/build-system/meson.scm (meson-build)[#:build-type]: Set to 'debugoptimized'. --- guix/build-system/meson.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index 370d185545..b29f2f4ecf 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -90,7 +90,7 @@ (outputs '("out")) (configure-flags ''()) (search-paths '()) - (build-type "plain") + (build-type "debugoptimized") (tests? #t) (test-target "test") (glib-or-gtk? #f) -- cgit v1.2.3 From 6005440d988b331db5ea11a475973cee9a5acce6 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Sat, 13 Jul 2019 19:50:16 -0400 Subject: build-system/go: Fix typo. * guix/build/go-build-system.scm (install): Fix typo. --- guix/build/go-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 858068ba98..acaf06b7b8 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -234,7 +234,7 @@ unpacking." "Install the source code of IMPORT-PATH to the primary output directory. Compiled executable files (Go \"commands\") should have already been installed to the store based on $GOBIN in the build phase. -XXX We can't make us of compiled libraries (Go \"packages\")." +XXX We can't make use of compiled libraries (Go \"packages\")." (when install-source? (if (string-null? import-path) ((display "WARNING: The Go import path is unset.\n"))) -- cgit v1.2.3 From 96783ed6275cd2818ff56916274e6e4582f1dc9b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 19 Jul 2019 00:52:36 +0200 Subject: syscalls: 'define-as-needed' does not re-export local variables. Fixes . Reported by Timothy Sample . * guix/build/syscalls.scm (define-as-needed): Rewrite to use lower-level module primitives; define VARIABLE only if it's not already defined to avoid "re-exporting local variable" error. --- guix/build/syscalls.scm | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3c84d3893f..f2fdb4d9d1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -396,17 +396,11 @@ the returned procedure is called." ((_ (proc args ...) body ...) (define-as-needed proc (lambda* (args ...) body ...))) ((_ variable value) - (begin - (when (module-defined? the-scm-module 'variable) - (re-export variable)) - - (define variable - (if (module-defined? the-scm-module 'variable) - (module-ref the-scm-module 'variable) - value)) - - (unless (module-defined? the-scm-module 'variable) - (export variable)))))) + (if (module-defined? the-scm-module 'variable) + (module-re-export! (current-module) '(variable)) + (begin + (module-define! (current-module) 'variable value) + (module-export! (current-module) '(variable))))))) ;;; -- cgit v1.2.3 From 2c8e04f13670c8c7ad8c7195c305960dd1905363 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Fri, 9 Aug 2019 14:24:57 -0400 Subject: remote: Build derivations appropriate for the remote's * gnu/machine/ssh.scm (machine-ssh-configuration): Add 'system' field. (managed-host-remote-eval): Pass 'system' field to 'remote-eval'. (machine-check-building-for-appropriate-system): New variable. (check-deployment-sanity): Add call to 'machine-check-building-for-appropriate-system'. * doc/guix.texi (Invoking guix deploy): Describe new 'system' field. * guix/ssh.scm (remote-system): New variable. * guix/remote.scm (remote-eval): Use result of 'remote-system' when lowering the G-Expression. (remote-eval): Add 'system' keyword argument. (trampoline): Return a rather than a . --- doc/guix.texi | 3 +++ gnu/machine/ssh.scm | 31 +++++++++++++++++++++++++++---- guix/remote.scm | 14 +++++++++----- guix/ssh.scm | 7 +++++++ 4 files changed, 46 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 734206a4b2..a7facf4701 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25573,6 +25573,9 @@ with an @code{environment} of @code{managed-host-environment-type}. @table @asis @item @code{host-name} +@item @code{system} +The Nix system type describing the architecture of the machine being deployed +to. This should look something like ``x86_64-linux''. @item @code{port} (default: @code{22}) @item @code{user} (default: @code{"root"}) @item @code{identity} (default: @code{#f}) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index ba3e33c922..670990a633 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -36,6 +36,7 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (managed-host-environment-type @@ -68,6 +69,7 @@ machine-ssh-configuration? this-machine-ssh-configuration (host-name machine-ssh-configuration-host-name) ; string + (system machine-ssh-configuration-system) ; string (build-locally? machine-ssh-configuration-build-locally? (default #t)) (port machine-ssh-configuration-port ; integer @@ -103,10 +105,12 @@ one from the configuration's parameters if one was not provided." "Internal implementation of 'machine-remote-eval' for MACHINE instances with an environment type of 'managed-host." (maybe-raise-unsupported-configuration-error machine) - (remote-eval exp (machine-ssh-session machine) - #:build-locally? - (machine-ssh-configuration-build-locally? - (machine-configuration machine)))) + (let ((config (machine-configuration machine))) + (remote-eval exp (machine-ssh-session machine) + #:build-locally? + (machine-ssh-configuration-build-locally? config) + #:system + (machine-ssh-configuration-system config)))) ;;; @@ -240,10 +244,29 @@ MACHINE's 'system' declaration do not exist on the machine." device) (return #t))) +(define (machine-check-building-for-appropriate-system machine) + "Raise a '&message' error condition if MACHINE is configured to be built +locally and the 'system' field does not match the '%current-system' reported +by MACHINE." + (let ((config (machine-configuration machine)) + (system (remote-system (machine-ssh-session machine)))) + (when (and (machine-ssh-configuration-build-locally? config) + (not (string= system (machine-ssh-configuration-system config)))) + (raise (condition + (&message + (message (format #f (G_ "incorrect target system \ +('~a' was given, while the system reports that it is '~a')~%") + (machine-ssh-configuration-system config) + system))))))) + (with-monad %store-monad (return #t))) + (define (check-deployment-sanity machine) "Raise a '&message' error condition if it is clear that deploying MACHINE's 'system' declaration would fail." + ;; Order is important here -- an incorrect value for 'system' will cause + ;; invocations of 'remote-eval' to fail. (mbegin %store-monad + (machine-check-building-for-appropriate-system machine) (machine-check-file-system-availability machine) (machine-check-initrd-modules machine))) diff --git a/guix/remote.scm b/guix/remote.scm index 5fecd954e9..bcac64ea7a 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -24,6 +24,7 @@ #:use-module (guix monads) #:use-module (guix modules) #:use-module (guix derivations) + #:use-module (guix utils) #:use-module (ssh popen) #:use-module (srfi srfi-1) #:use-module (ice-9 match) @@ -71,7 +72,7 @@ prerequisites of EXP are already available on the host at SESSION." "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation result to the current output port using the (guix repl) protocol." (define program - (scheme-file "remote-exp.scm" exp)) + (program-file "remote-exp.scm" exp)) (with-imported-modules (source-module-closure '((guix repl))) #~(begin @@ -89,6 +90,7 @@ result to the current output port using the (guix repl) protocol." (define* (remote-eval exp session #:key (build-locally? #t) + (system (%current-system)) (module-path %load-path) (socket-name "/var/guix/daemon-socket/socket")) "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that @@ -96,10 +98,12 @@ all the elements EXP refers to are built and deployed to SESSION beforehand. When BUILD-LOCALLY? is true, said dependencies are built locally and sent to the remote store afterwards; otherwise, dependencies are built directly on the remote store." - (mlet %store-monad ((lowered (lower-gexp (trampoline exp) - #:module-path %load-path)) - (remote -> (connect-to-remote-daemon session - socket-name))) + (mlet* %store-monad ((lowered (lower-gexp (trampoline exp) + #:system system + #:guile-for-build #f + #:module-path %load-path)) + (remote -> (connect-to-remote-daemon session + socket-name))) (define inputs (cons (lowered-gexp-guile lowered) (lowered-gexp-inputs lowered))) diff --git a/guix/ssh.scm b/guix/ssh.scm index ede00133c8..9b5ca68894 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -39,6 +39,7 @@ remote-inferior remote-daemon-channel connect-to-remote-daemon + remote-system send-files retrieve-files retrieve-files* @@ -282,6 +283,12 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." ,(object->string (object->string export)))))) +(define (remote-system session) + "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of +the machine on the other end of SESSION." + (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system)) + session)) + (define* (send-files local files remote #:key recursive? -- cgit v1.2.3 From 03cbd94d4880f1bb55d98907b48396e5120c1733 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Fri, 9 Aug 2019 14:25:54 -0400 Subject: remote: Remove '--system' argument. * gnu/services.scm (activation-script): Return a rather than a . * gnu/deploy.scm (guix-deploy): Remove handling for '--system'. (show-help): Remove documentation for '--system'. (%default-options): Remove default setting for 'system'. --- gnu/services.scm | 56 ++++++++++++++++++++++++------------------------- guix/scripts/deploy.scm | 8 ++----- 2 files changed, 30 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/gnu/services.scm b/gnu/services.scm index 7de78105ff..6ee05d4580 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -430,34 +430,34 @@ ACTIVATION-SCRIPT-TYPE." (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." (define actions - (map (cut scheme-file "activate-service" <>) gexps)) - - (scheme-file "activate" - (with-imported-modules (source-module-closure - '((gnu build activation) - (guix build utils))) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If it - ;; does not exist, 'setutxent' does not create it and - ;; thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things this - ;; sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions))))) + (map (cut program-file "activate-service.scm" <>) gexps)) + + (program-file "activate.scm" + (with-imported-modules (source-module-closure + '((gnu build activation) + (guix build utils))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If it + ;; does not exist, 'setutxent' does not create it and + ;; thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things this + ;; sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ebc99e52cc..81f2b33260 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -43,8 +43,6 @@ (define (show-help) (display (G_ "Usage: guix deploy [OPTION] FILE... Perform the deployment specified by FILE.\n")) - (display (G_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (show-build-options-help) (newline) (display (G_ " @@ -66,8 +64,7 @@ Perform the deployment specified by FILE.\n")) %standard-build-options)) (define %default-options - `((system . ,(%current-system)) - (substitutes? . #t) + `((substitutes? . #t) (build-hook? . #t) (graft? . #t) (debug . 0) @@ -92,7 +89,6 @@ Perform the deployment specified by FILE.\n")) (set-build-options-from-command-line store opts) (for-each (lambda (machine) (info (G_ "deploying to ~a...") (machine-display-name machine)) - (parameterize ((%current-system (assq-ref opts 'system)) - (%graft? (assq-ref opts 'graft?))) + (parameterize ((%graft? (assq-ref opts 'graft?))) (run-with-store store (deploy-machine machine)))) machines)))) -- cgit v1.2.3 From 5ea7537b9a650cfa525401c19879080a9cf42e13 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 15 Aug 2019 04:05:04 -0400 Subject: machine: Allow non-root users to deploy. * doc/guix.texi (Invoking guix deploy): Add section describing prerequisites for deploying as a non-root user. * guix/remote.scm (remote-pipe-for-gexp): New optional 'become-command' argument. (%remote-eval): New optional 'become-command' argument. (remote-eval): New 'become-command' keyword argument. * guix/ssh.scm (remote-inferior): New optional 'become-command' argument. (inferior-remote-eval): New optional 'become-command' argument. (remote-authorize-signing-key): New optional 'become-command' argument. * gnu/machine/ssh.scm (machine-become-command): New variable. (managed-host-remote-eval): Invoke 'remote-eval' with the '#:become-command' keyword. (deploy-managed-host): Invoke 'remote-authorize-signing-key' with the '#:become-command' keyword. --- doc/guix.texi | 10 ++++++++++ gnu/machine/ssh.scm | 8 ++++++++ guix/remote.scm | 57 +++++++++++++++++++++++++++++++++-------------------- guix/ssh.scm | 25 ++++++++++++++++------- 4 files changed, 72 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a7facf4701..e5cec7ad25 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25514,6 +25514,7 @@ evaluates to. As an example, @var{file} might contain a definition like this: (environment managed-host-environment-type) (configuration (machine-ssh-configuration (host-name "localhost") + (user "alice") (identity "./id_rsa") (port 2222))))) @end example @@ -25546,6 +25547,15 @@ accepts store items it receives from the coordinator: # guix archive --authorize < coordinator-public-key.txt @end example +@code{user}, in this example, specifies the name of the user account to log in +as to perform the deployment. Its default value is @code{root}, but root +login over SSH may be forbidden in some cases. To work around this, +@command{guix deploy} can log in as an unprivileged user and employ +@code{sudo} to escalate privileges. This will only work if @code{sudo} is +currently installed on the remote and can be invoked non-interactively as +@code{user}. That is: the line in @code{sudoers} granting @code{user} the +ability to use @code{sudo} must contain the @code{NOPASSWD} tag. + @deftp {Data Type} machine This is the data type representing a single machine in a heterogeneous Guix deployment. diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 670990a633..fb15d39e61 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -101,6 +101,14 @@ one from the configuration's parameters if one was not provided." ;;; Remote evaluation. ;;; +(define (machine-become-command machine) + "Return as a list of strings the program and arguments necessary to run a +shell command with escalated privileges for MACHINE's configuration." + (if (string= "root" (machine-ssh-configuration-user + (machine-configuration machine))) + '() + '("/run/setuid-programs/sudo" "-n" "--"))) + (define (managed-host-remote-eval machine exp) "Internal implementation of 'machine-remote-eval' for MACHINE instances with an environment type of 'managed-host." diff --git a/guix/remote.scm b/guix/remote.scm index bcac64ea7a..d8124e41ab 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -27,6 +27,8 @@ #:use-module (guix utils) #:use-module (ssh popen) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (remote-eval)) @@ -41,29 +43,41 @@ ;;; ;;; Code: -(define (remote-pipe-for-gexp lowered session) - "Return a remote pipe for the given SESSION to evaluate LOWERED." +(define* (remote-pipe-for-gexp lowered session #:optional become-command) + "Return a remote pipe for the given SESSION to evaluate LOWERED. If +BECOME-COMMAND is given, use that to invoke the remote Guile REPL." (define shell-quote (compose object->string object->string)) - (apply open-remote-pipe* session OPEN_READ - (string-append (derivation-input-output-path - (lowered-gexp-guile lowered)) - "/bin/guile") - "--no-auto-compile" - (append (append-map (lambda (directory) - `("-L" ,directory)) - (lowered-gexp-load-path lowered)) - (append-map (lambda (directory) - `("-C" ,directory)) - (lowered-gexp-load-path lowered)) - `("-c" - ,(shell-quote (lowered-gexp-sexp lowered)))))) + (define repl-command + (append (or become-command '()) + (list + (string-append (derivation-input-output-path + (lowered-gexp-guile lowered)) + "/bin/guile") + "--no-auto-compile") + (append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + (append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-path lowered)) + `("-c" + ,(shell-quote (lowered-gexp-sexp lowered))))) -(define (%remote-eval lowered session) + (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) + (when (eof-object? (peek-char pipe)) + (raise (condition + (&message + (message (format #f (G_ "failed to run '~{~a~^ ~}'") + repl-command)))))) + pipe)) + +(define* (%remote-eval lowered session #:optional become-command) "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the -prerequisites of EXP are already available on the host at SESSION." - (let* ((pipe (remote-pipe-for-gexp lowered session)) +prerequisites of EXP are already available on the host at SESSION. If +BECOME-COMMAND is given, use that to invoke the remote Guile REPL." + (let* ((pipe (remote-pipe-for-gexp lowered session become-command)) (result (read-repl-response pipe))) (close-port pipe) result)) @@ -92,7 +106,8 @@ result to the current output port using the (guix repl) protocol." (build-locally? #t) (system (%current-system)) (module-path %load-path) - (socket-name "/var/guix/daemon-socket/socket")) + (socket-name "/var/guix/daemon-socket/socket") + (become-command #f)) "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that all the elements EXP refers to are built and deployed to SESSION beforehand. When BUILD-LOCALLY? is true, said dependencies are built locally and sent to @@ -119,7 +134,7 @@ remote store." (built-derivations inputs) ((store-lift send-files) to-send remote #:recursive? #t) (return (close-connection remote)) - (return (%remote-eval lowered session)))) + (return (%remote-eval lowered session become-command)))) (let ((to-send (append (map (compose derivation-file-name derivation-input-derivation) inputs) @@ -128,4 +143,4 @@ remote store." ((store-lift send-files) to-send remote #:recursive? #t) (return (build-derivations remote inputs)) (return (close-connection remote)) - (return (%remote-eval lowered session))))))) + (return (%remote-eval lowered session become-command))))))) diff --git a/guix/ssh.scm b/guix/ssh.scm index 9b5ca68894..90311127a1 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -98,16 +98,27 @@ specifies; otherwise use them. Throw an error on failure." (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") host (get-error session)))))))))) -(define (remote-inferior session) - "Return a remote inferior for the given SESSION." - (let ((pipe (open-remote-pipe* session OPEN_BOTH - "guix" "repl" "-t" "machine"))) +(define* (remote-inferior session #:optional become-command) + "Return a remote inferior for the given SESSION. If BECOME-COMMAND is +given, use that to invoke the remote Guile REPL." + (let* ((repl-command (append (or become-command '()) + '("guix" "repl" "-t" "machine"))) + (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command))) + ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the + ;; process does succeed. This doesn't reflect the documentation, so it's + ;; possible that it's a bug in guile-ssh. + (when (eof-object? (peek-char pipe)) + (raise (condition + (&message + (message (format #f (G_ "failed to run '~{~a~^ ~}'") + repl-command)))))) (port->inferior pipe))) -(define (inferior-remote-eval exp session) +(define* (inferior-remote-eval exp session #:optional become-command) "Evaluate EXP in a new inferior running in SESSION, and close the inferior -right away." - (let ((inferior (remote-inferior session))) +right away. If BECOME-COMMAND is given, use that to invoke the remote Guile +REPL." + (let ((inferior (remote-inferior session become-command))) (dynamic-wind (const #t) (lambda () -- cgit v1.2.3 From 9c70c460a05b2bc60f3f3602f0a2dba0f79ce86c Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 15 Aug 2019 04:05:57 -0400 Subject: machine: Implement 'roll-back-machine'. * gnu/machine.scm (roll-back-machine, &deploy-error, deploy-error?) (deploy-error-should-roll-back) (deploy-error-captured-args): New variable. * gnu/machine/ssh.scm (roll-back-managed-host): New variable. * guix/scripts/deploy.scm (guix-deploy): Roll-back systems when a deployment fails. --- gnu/machine.scm | 27 ++++++++++++++++++- gnu/machine/ssh.scm | 72 ++++++++++++++++++++++++++++++++++++++++++++++--- guix/scripts/deploy.scm | 17 ++++++++++-- 3 files changed, 110 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/gnu/machine.scm b/gnu/machine.scm index 30ae97f6ec..05b03b21d4 100644 --- a/gnu/machine.scm +++ b/gnu/machine.scm @@ -24,6 +24,7 @@ #:use-module (guix records) #:use-module (guix store) #:use-module ((guix utils) #:select (source-properties->location)) + #:use-module (srfi srfi-35) #:export (environment-type environment-type? environment-type-name @@ -40,7 +41,13 @@ machine-display-name deploy-machine - machine-remote-eval)) + roll-back-machine + machine-remote-eval + + &deploy-error + deploy-error? + deploy-error-should-roll-back + deploy-error-captured-args)) ;;; Commentary: ;;; @@ -66,6 +73,7 @@ ;; of the form '(machine-remote-eval machine exp)'. (machine-remote-eval environment-type-machine-remote-eval) ; procedure (deploy-machine environment-type-deploy-machine) ; procedure + (roll-back-machine environment-type-roll-back-machine) ; procedure ;; Metadata. (name environment-type-name) ; symbol @@ -105,3 +113,20 @@ are built and deployed to MACHINE beforehand." MACHINE, activating it on MACHINE and switching MACHINE to the new generation." (let ((environment (machine-environment machine))) ((environment-type-deploy-machine environment) machine))) + +(define (roll-back-machine machine) + "Monadic procedure rolling back to the previous system generation on +MACHINE. Return the number of the generation that was current before switching +and the new generation number." + (let ((environment (machine-environment machine))) + ((environment-type-roll-back-machine environment) machine))) + + +;;; +;;; Error types. +;;; + +(define-condition-type &deploy-error &error + deploy-error? + (should-roll-back deploy-error-should-roll-back) + (captured-args deploy-error-captured-args)) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index fb15d39e61..4b5d5fe3a2 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu machine ssh) + #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) #:use-module (gnu system) @@ -34,6 +35,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -341,6 +343,18 @@ of MACHINE's system profile, ordered from most recent to oldest." (boot-parameters-kernel-arguments params)))))))) generations)))) +(define-syntax-rule (with-roll-back should-roll-back? mbody ...) + "Catch exceptions that arise when binding MBODY, a monadic expression in +%STORE-MONAD, and collect their arguments in a &deploy-error condition, with +the 'should-roll-back' field set to SHOULD-ROLL-BACK?" + (catch #t + (lambda () + mbody ...) + (lambda args + (raise (condition (&deploy-error + (should-roll-back should-roll-back?) + (captured-args args))))))) + (define (deploy-managed-host machine) "Internal implementation of 'deploy-machine' for MACHINE instances with an environment type of 'managed-host." @@ -353,9 +367,60 @@ environment type of 'managed-host." (bootloader-configuration (operating-system-bootloader os)) (bootcfg (operating-system-bootcfg os menu-entries))) (mbegin %store-monad - (switch-to-system eval os) - (upgrade-shepherd-services eval os) - (install-bootloader eval bootloader-configuration bootcfg))))) + (with-roll-back #f + (switch-to-system eval os)) + (with-roll-back #t + (mbegin %store-monad + (upgrade-shepherd-services eval os) + (install-bootloader eval bootloader-configuration bootcfg))))))) + + +;;; +;;; Roll-back. +;;; + +(define (roll-back-managed-host machine) + "Internal implementation of 'roll-back-machine' for MACHINE instances with +an environment type of 'managed-host." + (define remote-exp + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure '((guix config) + (guix profiles))) + #~(begin + (use-modules (guix config) + (guix profiles)) + + (define %system-profile + (string-append %state-directory "/profiles/system")) + + (define target-generation + (relative-generation %system-profile -1)) + + (if target-generation + (switch-to-generation %system-profile target-generation) + 'error))))) + + (define roll-back-failure + (condition (&message (message (G_ "could not roll-back machine"))))) + + (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)) + (_ -> (if (< (length boot-parameters) 2) + (raise roll-back-failure))) + (entries -> (map boot-parameters->menu-entry + (list (second boot-parameters)))) + (old-entries -> (map boot-parameters->menu-entry + (drop boot-parameters 2))) + (bootloader -> (operating-system-bootloader + (machine-operating-system machine))) + (bootcfg (lower-object + ((bootloader-configuration-file-generator + (bootloader-configuration-bootloader + bootloader)) + bootloader entries + #:old-entries old-entries))) + (remote-result (machine-remote-eval machine remote-exp))) + (when (eqv? 'error remote-result) + (raise roll-back-failure)))) ;;; @@ -366,6 +431,7 @@ environment type of 'managed-host." (environment-type (machine-remote-eval managed-host-remote-eval) (deploy-machine deploy-managed-host) + (roll-back-machine roll-back-managed-host) (name 'managed-host-environment-type) (description "Provisioning for machines that are accessible over SSH and have a known host-name. This entails little more than maintaining an SSH diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 81f2b33260..6a67985c8b 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -28,6 +28,8 @@ #:use-module (guix grafts) #:use-module (ice-9 format) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:export (guix-deploy)) @@ -88,7 +90,18 @@ Perform the deployment specified by FILE.\n")) (with-store store (set-build-options-from-command-line store opts) (for-each (lambda (machine) - (info (G_ "deploying to ~a...") (machine-display-name machine)) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) (parameterize ((%graft? (assq-ref opts 'graft?))) - (run-with-store store (deploy-machine machine)))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: '~a'~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine))))) machines)))) -- cgit v1.2.3 From 3033d59ac9a747b42a1fa6ca6664d4fbc62ca117 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 15 Aug 2019 04:06:41 -0400 Subject: machine: Automatically authorize the coordinator's signing key. * guix/ssh.scm (remote-authorize-signing-key): New variable. * gnu/machine/ssh.scm (deploy-managed-host): Authorize coordinator's signing key before any invocations of 'remote-eval'. (deploy-managed-host): Display an error if a signing key does not exist. * doc/guix.texi (Invoking guix deploy): Remove section describing manual signing key authorization. (Invoking guix deploy): Add section describing the 'authorize?' field. --- doc/guix.texi | 3 +++ gnu/machine/ssh.scm | 33 ++++++++++++++++++++++++++------- guix/ssh.scm | 23 +++++++++++++++++++++++ 3 files changed, 52 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e5cec7ad25..d80f62970d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -25586,6 +25586,9 @@ with an @code{environment} of @code{managed-host-environment-type}. @item @code{system} The Nix system type describing the architecture of the machine being deployed to. This should look something like ``x86_64-linux''. +@item @code{authorize?} (default: @code{#t}) +If true, the coordinator's signing key will be added to the remote's ACL +keyring. @item @code{port} (default: @code{22}) @item @code{user} (default: @code{"root"}) @item @code{identity} (default: @code{#f}) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 4b5d5fe3a2..ac3aa3e370 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -28,13 +28,16 @@ #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix monads) + #:use-module (guix pki) #:use-module (guix records) #:use-module (guix remote) #:use-module (guix scripts system reconfigure) #:use-module (guix ssh) #:use-module (guix store) #:use-module (guix utils) + #:use-module (gcrypt pk-crypto) #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -48,6 +51,7 @@ machine-ssh-configuration-host-name machine-ssh-configuration-build-locally? + machine-ssh-configuration-authorize? machine-ssh-configuration-port machine-ssh-configuration-user machine-ssh-configuration-session)) @@ -70,17 +74,19 @@ make-machine-ssh-configuration machine-ssh-configuration? this-machine-ssh-configuration - (host-name machine-ssh-configuration-host-name) ; string - (system machine-ssh-configuration-system) ; string - (build-locally? machine-ssh-configuration-build-locally? + (host-name machine-ssh-configuration-host-name) ; string + (system machine-ssh-configuration-system) ; string + (build-locally? machine-ssh-configuration-build-locally? ; boolean (default #t)) - (port machine-ssh-configuration-port ; integer + (authorize? machine-ssh-configuration-authorize? ; boolean + (default #t)) + (port machine-ssh-configuration-port ; integer (default 22)) - (user machine-ssh-configuration-user ; string + (user machine-ssh-configuration-user ; string (default "root")) - (identity machine-ssh-configuration-identity ; path to a private key + (identity machine-ssh-configuration-identity ; path to a private key (default #f)) - (session machine-ssh-configuration-session ; session + (session machine-ssh-configuration-session ; session (default #f))) (define (machine-ssh-session machine) @@ -359,6 +365,19 @@ the 'should-roll-back' field set to SHOULD-ROLL-BACK?" "Internal implementation of 'deploy-machine' for MACHINE instances with an environment type of 'managed-host." (maybe-raise-unsupported-configuration-error machine) + (when (machine-ssh-configuration-authorize? + (machine-configuration machine)) + (unless (file-exists? %public-key-file) + (raise (condition + (&message + (message (format #f (G_ "no signing key '~a'. \ +have you run 'guix archive --generate-key?'") + %public-key-file)))))) + (remote-authorize-signing-key (call-with-input-file %public-key-file + (lambda (port) + (string->canonical-sexp + (get-string-all port)))) + (machine-ssh-session machine))) (mlet %store-monad ((_ (check-deployment-sanity machine)) (boot-parameters (machine-boot-parameters machine))) (let* ((os (machine-operating-system machine)) diff --git a/guix/ssh.scm b/guix/ssh.scm index 90311127a1..24834c6f68 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -21,6 +21,7 @@ #:use-module (guix inferior) #:use-module (guix i18n) #:use-module ((guix utils) #:select (&fix-hint)) + #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) #:use-module (ssh key) @@ -40,6 +41,7 @@ remote-daemon-channel connect-to-remote-daemon remote-system + remote-authorize-signing-key send-files retrieve-files retrieve-files* @@ -300,6 +302,27 @@ the machine on the other end of SESSION." (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system)) session)) +(define (remote-authorize-signing-key key session) + "Send KEY, a canonical sexp containing a public key, over SESSION and add it +to the system ACL file if it has not yet been authorized." + (inferior-remote-eval + `(begin + (use-modules (guix build utils) + (guix pki) + (guix utils) + (gcrypt pk-crypto) + (srfi srfi-26)) + + (define acl (current-acl)) + (define key (string->canonical-sexp ,(canonical-sexp->string key))) + + (unless (authorized-key? key) + (let ((acl (public-keys->acl (cons key (acl->public-keys acl))))) + (mkdir-p (dirname %acl-file)) + (with-atomic-file-output %acl-file + (cut write-acl acl <>))))) + session)) + (define* (send-files local files remote #:key recursive? -- cgit v1.2.3 From 5f32531770b532deafb79601ecff4913ec38d0b2 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 15 Aug 2019 04:08:22 -0400 Subject: remote: Use (%daemon-socket-uri) rather than hard-coded path. * guix/remote.scm (remote-eval): Use (%daemon-socket-uri) as the default value of 'socket-name' rather than hard-coded path. --- guix/remote.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/remote.scm b/guix/remote.scm index d8124e41ab..ae2fe17dd2 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -106,7 +106,7 @@ result to the current output port using the (guix repl) protocol." (build-locally? #t) (system (%current-system)) (module-path %load-path) - (socket-name "/var/guix/daemon-socket/socket") + (socket-name (%daemon-socket-uri)) (become-command #f)) "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that all the elements EXP refers to are built and deployed to SESSION beforehand. -- cgit v1.2.3 From 4f3811f6bbdfba817601eb3168f5b3e0d2f1c3f6 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 9 Sep 2018 11:42:29 +0200 Subject: guix: copy-linux-headers: Extract procedure, add headers. * guix/build/make-bootstrap.scm (copy-linux-headers): New procedure; extract from make-stripped-libc and add headers for Mes bootstrap. (make-stripped-libc): Use it. --- guix/build/make-bootstrap.scm | 72 +++++++++++++++++++++++++++++++------------ 1 file changed, 53 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 48799f7e90..e5ef1d6d2b 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis ;;; Copyright © 2015, 2019 Ludovic Courtès +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (guix build utils) - #:export (make-stripped-libc)) + #:export (copy-linux-headers + make-stripped-libc)) ;; Commentary: ;; @@ -31,6 +33,53 @@ ;; ;; Code: +(define (copy-linux-headers output kernel-headers) + "Copy to OUTPUT the subset of KERNEL-HEADERS that is needed when producing a +bootstrap libc." + + (let* ((incdir (string-append output "/include"))) + (mkdir-p incdir) + + ;; Copy some of the Linux-Libre headers that glibc headers + ;; refer to. + (mkdir (string-append incdir "/linux")) + (for-each (lambda (file) + (install-file (pk 'src (string-append kernel-headers "/include/linux/" file)) + (pk 'dest (string-append incdir "/linux")))) + '( + "a.out.h" ; for 2.2.5 + "atalk.h" ; for 2.2.5 + "errno.h" + "falloc.h" + "if_addr.h" ; for 2.16.0 + "if_ether.h" ; for 2.2.5 + "if_link.h" ; for 2.16.0 + "ioctl.h" + "kernel.h" + "limits.h" + "neighbour.h" ; for 2.16.0 + "netlink.h" ; for 2.16.0 + "param.h" + "prctl.h" ; for 2.16.0 + "posix_types.h" + "rtnetlink.h" ; for 2.16.0 + "socket.h" + "stddef.h" + "swab.h" ; for 2.2.5 + "sysctl.h" + "sysinfo.h" ; for 2.2.5 + "types.h" + "version.h" ; for 2.2.5 + )) + + (copy-recursively (string-append kernel-headers "/include/asm") + (string-append incdir "/asm")) + (copy-recursively (string-append kernel-headers "/include/asm-generic") + (string-append incdir "/asm-generic")) + (copy-recursively (string-append kernel-headers "/include/linux/byteorder") + (string-append incdir "/linux/byteorder")) + #t)) + (define (make-stripped-libc output libc kernel-headers) "Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed when producing a bootstrap libc." @@ -43,25 +92,10 @@ when producing a bootstrap libc." (string-append incdir "/mach")) #t)) - (define (copy-linux-headers output kernel-headers) + (define (copy-libc+linux-headers output kernel-headers) (let* ((incdir (string-append output "/include"))) (copy-recursively (string-append libc "/include") incdir) - - ;; Copy some of the Linux-Libre headers that glibc headers - ;; refer to. - (mkdir (string-append incdir "/linux")) - (for-each (lambda (file) - (install-file (string-append kernel-headers "/include/linux/" file) - (string-append incdir "/linux"))) - '("limits.h" "errno.h" "socket.h" "kernel.h" - "sysctl.h" "param.h" "ioctl.h" "types.h" - "posix_types.h" "stddef.h" "falloc.h")) - - (copy-recursively (string-append kernel-headers "/include/asm") - (string-append incdir "/asm")) - (copy-recursively (string-append kernel-headers "/include/asm-generic") - (string-append incdir "/asm-generic")) - #t)) + (copy-linux-headers output kernel-headers))) (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ @@ -80,6 +114,6 @@ _nonshared\\.a)$") (if (directory-exists? (string-append kernel-headers "/include/mach")) (copy-mach-headers output kernel-headers) - (copy-linux-headers output kernel-headers))) + (copy-libc+linux-headers output kernel-headers))) -- cgit v1.2.3 From ddef146b894a1b1158b56bad72ca265537a55764 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 15 Aug 2019 12:09:58 -0400 Subject: remote: Resolve missing 'G_'. * guix/remote.scm: Require (guix i18n). --- guix/remote.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/remote.scm b/guix/remote.scm index ae2fe17dd2..d0c3d04a25 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -19,6 +19,7 @@ (define-module (guix remote) #:use-module (guix ssh) #:use-module (guix gexp) + #:use-module (guix i18n) #:use-module (guix inferior) #:use-module (guix store) #:use-module (guix monads) -- cgit v1.2.3 From 4cc5e5204b503afb4536a1e93e2fd7a9f57f12bf Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Thu, 15 Aug 2019 12:09:11 -0400 Subject: machine: Use 'become-command'. * gnu/machine/ssh.scm (managed-host-remote-eval): Pass an appropriate 'become-command' to 'remote-eval'. * guix/ssh.scm (remote-authorize-signing-key): Add optional 'become-command' argument. All callers changed. --- gnu/machine/ssh.scm | 7 +++++-- guix/ssh.scm | 5 +++-- 2 files changed, 8 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index ac3aa3e370..aafe0ccf41 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -126,7 +126,9 @@ an environment type of 'managed-host." #:build-locally? (machine-ssh-configuration-build-locally? config) #:system - (machine-ssh-configuration-system config)))) + (machine-ssh-configuration-system config) + #:become-command + (machine-become-command machine)))) ;;; @@ -377,7 +379,8 @@ have you run 'guix archive --generate-key?'") (lambda (port) (string->canonical-sexp (get-string-all port)))) - (machine-ssh-session machine))) + (machine-ssh-session machine) + (machine-become-command machine))) (mlet %store-monad ((_ (check-deployment-sanity machine)) (boot-parameters (machine-boot-parameters machine))) (let* ((os (machine-operating-system machine)) diff --git a/guix/ssh.scm b/guix/ssh.scm index 24834c6f68..7bc499a2fe 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -302,7 +302,7 @@ the machine on the other end of SESSION." (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system)) session)) -(define (remote-authorize-signing-key key session) +(define* (remote-authorize-signing-key key session #:optional become-command) "Send KEY, a canonical sexp containing a public key, over SESSION and add it to the system ACL file if it has not yet been authorized." (inferior-remote-eval @@ -321,7 +321,8 @@ to the system ACL file if it has not yet been authorized." (mkdir-p (dirname %acl-file)) (with-atomic-file-output %acl-file (cut write-acl acl <>))))) - session)) + session + become-command)) (define* (send-files local files remote #:key -- cgit v1.2.3 From c586f427b4831b9b492e5b900b2226e898b8fcfa Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 16 Aug 2019 14:56:37 +0200 Subject: build-system/r: bioconductor-uri: Take optional package type. * guix/build-system/r.scm (bioconductor-uri): Take optional TYPE argument to return annotation or experiment URLs. --- guix/build-system/r.scm | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index e7214155be..dd2a9fe8de 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -47,14 +47,22 @@ available via the first URI, the second URI points to the archived version." (string-append "mirror://cran/src/contrib/Archive/" name "/" name "_" version ".tar.gz"))) -(define (bioconductor-uri name version) +(define* (bioconductor-uri name version #:optional type) "Return a URI string for the R package archive on Bioconductor for the release corresponding to NAME and VERSION." - (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" - name "_" version ".tar.gz") - ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.9/bioc/src/contrib/Archive/" - name "_" version ".tar.gz"))) + (let ((type-url-part (match type + ('annotation "/data/annotation") + ('experiment "/data/experiment") + (_ "/bioc")))) + (list (string-append "https://bioconductor.org/packages/release" + type-url-part + "/src/contrib/" + name "_" version ".tar.gz") + ;; TODO: use %bioconductor-version from (guix import cran) + (string-append "https://bioconductor.org/packages/3.9" + type-url-part + "/src/contrib/Archive/" + name "_" version ".tar.gz")))) (define %r-build-system-modules ;; Build-side modules imported by default. -- cgit v1.2.3 From 5063deab0800ca3f75fa4671dc544cc212326608 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 16 Aug 2019 14:59:23 +0200 Subject: import: cran: Support experiment and annotation packages. * guix/import/cran.scm (%bioconductor-packages-list-url): Replace variable... (bioconductor-packages-list-url): ...with this procedure. (bioconductor-packages-list): Accept optional TYPE argument. (latest-bioconductor-package-version): Same. (fetch-description): Determine package type and use it in calls to LATEST-BIOCONDUCTOR-PACKAGE-VERSION and BIOCONDUCTOR-URI. (description->package): Pass package type to URI helper procedure; include package type in annotation or experiment packages from Bioconducter. --- guix/import/cran.scm | 46 +++++++++++++++++++++++++++++++++------------- 1 file changed, 33 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 3240094444..9c964701b1 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -132,14 +132,19 @@ package definition." ;; updated together. (define %bioconductor-version "3.9") -(define %bioconductor-packages-list-url +(define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" - %bioconductor-version "/bioc/src/contrib/PACKAGES")) - -(define (bioconductor-packages-list) + %bioconductor-version + (match type + ('annotation "/data/annotation") + ('experiment "/data/experiment") + (_ "/bioc")) + "/src/contrib/PACKAGES")) + +(define* (bioconductor-packages-list #:optional type) "Return the latest version of package NAME for the current bioconductor release." - (let ((url (string->uri %bioconductor-packages-list-url))) + (let ((url (string->uri (bioconductor-packages-list-url type)))) (guard (c ((http-get-error? c) (format (current-error-port) "error: failed to retrieve list of packages from ~s: ~a (~s)~%" @@ -153,12 +158,12 @@ release." (description->alist (string-join chunk "\n"))) (chunk-lines (read-lines (http-fetch/cached url))))))) -(define (latest-bioconductor-package-version name) +(define* (latest-bioconductor-package-version name #:optional type) "Return the version string corresponding to the latest release of the bioconductor package NAME, or #F if the package is unknown." (and=> (find (lambda (meta) (string=? (assoc-ref meta "Package") name)) - (bioconductor-packages-list)) + (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) ;; Little helper to download URLs only once. @@ -187,8 +192,12 @@ from ~s: ~a (~s)~%" ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, ;; download the source tarball, and then extract the DESCRIPTION file. - (and-let* ((version (latest-bioconductor-package-version name)) - (url (car (bioconductor-uri name version))) + (and-let* ((type (or + (and (latest-bioconductor-package-version name) #t) + (and (latest-bioconductor-package-version name 'annotation) 'annotation) + (and (latest-bioconductor-package-version name 'experiment) 'experiment))) + (version (latest-bioconductor-package-version name type)) + (url (car (bioconductor-uri name version type))) (tarball (download url))) (call-with-temporary-directory (lambda (dir) @@ -198,8 +207,11 @@ from ~s: ~a (~s)~%" "--strip-components=1" "-C" dir "-f" tarball "*/DESCRIPTION")) - (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)))))))))) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (if (boolean? type) meta + (cons `(bioconductor-type . ,type) meta)))))))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -306,7 +318,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (home-page (match (listify meta "URL") ((url rest ...) url) (_ (string-append base-url name)))) - (source-url (match (uri-helper name version) + (source-url (match (apply uri-helper name version + (case repository + ((bioconductor) + (list (assoc-ref meta 'bioconductor-type))) + (else '()))) ((url rest ...) url) ((? string? url) url) (_ #f))) @@ -330,7 +346,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (version ,version) (source (origin (method url-fetch) - (uri (,(procedure-name uri-helper) ,name version)) + (uri (,(procedure-name uri-helper) ,name version + ,@(or (and=> (assoc-ref meta 'bioconductor-type) + (lambda (type) + (list (list 'quote type)))) + '()))) (sha256 (base32 ,(bytevector->nix-base32-string (file-sha256 tarball)))))) -- cgit v1.2.3 From a7c714d3983c746d14b759707ff9e3487d580dd2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 Aug 2019 14:57:06 +0200 Subject: channels: Add 'profile-channels'. * guix/channels.scm (profile-channels): New procedure. * guix/scripts/describe.scm (display-profile-info)[channels]: Define in terms of 'profile-channels'. --- guix/channels.scm | 28 +++++++++++++++++++++++++++- guix/scripts/describe.scm | 27 +++------------------------ 2 files changed, 30 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 415246cbd1..ebb2cacbc7 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -65,7 +65,9 @@ latest-channel-derivation channel-instances->manifest %channel-profile-hooks - channel-instances->derivation)) + channel-instances->derivation + + profile-channels)) ;;; Commentary: ;;; @@ -534,3 +536,27 @@ channel instances." latest instances of CHANNELS." (mlet %store-monad ((instances (latest-channel-instances* channels))) (channel-instances->derivation instances))) + +(define (profile-channels profile) + "Return the list of channels corresponding to entries in PROFILE. If +PROFILE is not a profile created by 'guix pull', return the empty list." + (filter-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))) + + ;; No channel information for this manifest entry. + ;; XXX: Pre-0.15.0 Guix did not provide that information, + ;; but there's not much we can do in that case. + (_ #f))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries (profile-manifest profile))))) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index fa6b6cae37..99a88c50fa 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -153,30 +153,9 @@ in the format specified by FMT." (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))))))) + (profile-channels (if (zero? number) + profile + (generation-file-name profile number)))) (match fmt ('human -- cgit v1.2.3 From 268896444bed7b958add74b2e1e86ff802c5f5cb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 Aug 2019 18:41:55 +0200 Subject: derivations: Delete duplicate inputs when computing derivation hash. Fixes . Reported by Carl Dong . * guix/derivations.scm (derivation/masked-inputs): Call 'delete-duplicates' on INPUTS. * tests/derivations.scm ("derivation with duplicate fixed-output inputs"): New test. --- guix/derivations.scm | 2 +- tests/derivations.scm | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 92d50503ce..b3928920e2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -685,7 +685,7 @@ name of each input with that input's hash." (make-derivation-input hash sub-drvs)))) inputs))) (make-derivation outputs - (sort inputs + (sort (delete-duplicates inputs) (lambda (drv1 drv2) (stringoutput-path final1) (derivation->output-path final2))))) +(test-assert "derivation with duplicate fixed-output inputs" + ;; Here we create a derivation that has two inputs, both of which are + ;; fixed-output leading to the same result. This test ensures the hash of + ;; that derivation is correctly computed, namely that duplicate inputs are + ;; coalesced. See . + (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh" + "echo -n hello > $out" '())) + (builder2 (add-text-to-store %store "fixed-builder2.sh" + "echo hey; echo -n hello > $out" '())) + (hash (sha256 (string->utf8 "hello"))) + (fixed1 (derivation %store "fixed" + %bash `(,builder1) + #:hash hash #:hash-algo 'sha256)) + (fixed2 (derivation %store "fixed" + %bash `(,builder2) + #:hash hash #:hash-algo 'sha256)) + (builder3 (add-text-to-store %store "builder.sh" + "echo fake builder")) + (final (derivation %store "final" + %bash `(,builder3) + #:sources (list %bash builder3) + #:inputs (list (derivation-input fixed1) + (derivation-input fixed2))))) + (and (derivation? final) + (match (derivation-inputs final) + (((= derivation-input-derivation one) + (= derivation-input-derivation two)) + (and (not (string=? (derivation-file-name one) + (derivation-file-name two))) + (string=? (derivation->output-path one) + (derivation->output-path two)))))))) + (test-assert "multiple-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo one > $out ; echo two > $second" -- cgit v1.2.3 From 23ab21fa9d4ed47035dc446b10e9110243d9cdf0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 Aug 2019 19:14:49 +0200 Subject: derivations: Fix typo in docstring. * guix/derivations.scm (derivation-build-plan): Fix typo in the docstring. --- guix/derivations.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index b3928920e2..e1073ea39b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -376,8 +376,8 @@ of SUBSTITUTABLES." (substitution-oracle store inputs #:mode mode))) "Given INPUTS, a list of derivation-inputs, return two values: the list of -derivation to build, and the list of substitutable items that, together, -allows INPUTS to be realized. +derivations to build, and the list of substitutable items that, together, +allow INPUTS to be realized. SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned by 'substitution-oracle'." -- cgit v1.2.3 From 8d64ef567f816d29a4b25fe1cfbeb8005dc7cc2e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 Aug 2019 22:13:30 +0200 Subject: import: gnome: Update for Guile-JSON 3.x. This is a followup to 81c3dc32244a17241d74eea9fa265edfcb326f6d. * guix/import/gnome.scm (jsonish->upstream-source): Use 'assoc-ref' instead of 'hash-ref'. (latest-gnome-release): Match a vector containing an alist, not a hash table. Use 'fold' instead of 'hash-fold' over RELEASES. --- guix/import/gnome.scm | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 1ade63e1af..436ec88ef9 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,7 +46,7 @@ source for metadata." (package name) (version version) (urls (filter-map (lambda (extension) - (match (hash-ref dictionary extension) + (match (assoc-ref dictionary extension) (#f #f) ((? string? relative-url) @@ -86,21 +86,22 @@ not be determined." (json (json->scm port))) (close-port port) (match json - ((4 (? hash-table? releases) _ ...) - (let* ((releases (hash-ref releases upstream-name)) - (latest (hash-fold (lambda (key value result) - (cond ((even-minor-version? key) - (match result - (#f - (cons key value)) - ((newest . _) - (if (version>? key newest) - (cons key value) - result)))) - (else - result))) - #f - releases))) + (#(4 releases _ ...) + (let* ((releases (assoc-ref releases upstream-name)) + (latest (fold (match-lambda* + (((key . value) result) + (cond ((even-minor-version? key) + (match result + (#f + (cons key value)) + ((newest . _) + (if (version>? key newest) + (cons key value) + result)))) + (else + result)))) + #f + releases))) (and latest (jsonish->upstream-source upstream-name latest)))))))) -- cgit v1.2.3 From 4496ea74aaf9d2497ac3eaf8f780a250bed24503 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 Aug 2019 22:48:26 +0200 Subject: refresh: Use the standard diagnostic procedures. * guix/scripts/refresh.scm (warn-no-updater): Use 'warning' instead of 'format'. (update-package): Use 'info' and 'warning' instead of 'format'. --- guix/scripts/refresh.scm | 45 ++++++++++++++++++++------------------------- 1 file changed, 20 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index dd7026a6a4..4591d0f308 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -285,10 +285,9 @@ update would trigger a complete rebuild." (exit 0)) (define (warn-no-updater package) - (format (current-error-port) - (G_ "~a: warning: no updater for ~a~%") - (location->string (package-location package)) - (package-name package))) + (warning (package-location package) + (G_ "no updater for ~a~%") + (package-name package))) (define* (update-package store package updaters #:key (key-download 'interactive) warn?) @@ -306,11 +305,10 @@ warn about packages that have no matching updater." (when version (if (and=> tarball file-exists?) (begin - (format (current-error-port) - (G_ "~a: ~a: updating from version ~a to version ~a...~%") - (location->string loc) - (package-name package) - (package-version package) version) + (info loc + (G_ "~a: updating from version ~a to version ~a...~%") + (package-name package) + (package-version package) version) (for-each (lambda (change) (format (current-error-port) @@ -350,27 +348,24 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (case (version-compare (upstream-source-version source) (package-version package)) ((>) - (format (current-error-port) - (G_ "~a: ~a would be upgraded from ~a to ~a~%") - (location->string loc) - (package-name package) (package-version package) - (upstream-source-version source))) + (info loc + (G_ "~a would be upgraded from ~a to ~a~%") + (package-name package) (package-version package) + (upstream-source-version source))) ((=) (when warn? - (format (current-error-port) - (G_ "~a: info: ~a is already the latest version of ~a~%") - (location->string loc) - (package-version package) - (package-name package)))) + (info loc + (G_ "~a is already the latest version of ~a~%") + (package-version package) + (package-name package)))) (else (when warn? - (format (current-error-port) - (G_ "~a: warning: ~a is greater than \ + (warning loc + (G_ "~a is greater than \ the latest known version of ~a (~a)~%") - (location->string loc) - (package-version package) - (package-name package) - (upstream-source-version source))))))) + (package-version package) + (package-name package) + (upstream-source-version source))))))) (#f (when warn? (warn-no-updater package))))) -- cgit v1.2.3 From 0ea009db9d3bf53e75be8faef77c18d39c87a16a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 17 Aug 2019 22:50:58 +0200 Subject: upstream: Gracefully handle archive type changes. Previously, if the currently used archive type (e.g., "bz2") was unavailable for the new version, 'guix refresh -u' would crash instead of updating to the archive with the new type. * guix/upstream.scm (package-update/url-fetch): When URL is #f, pick the first of URLS; likewise for SIGNATURE-URL. --- guix/upstream.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index 1326b3db95..d4f9c5bb45 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -362,6 +362,7 @@ SOURCE, an ." (_ "gz"))) ((url signature-url) + ;; Try to find a URL that matches ARCHIVE-TYPE. (find2 (lambda (url sig-url) ;; Some URIs lack a file extension, like ;; 'https://crates.io/???/0.1/download'. In that @@ -370,7 +371,13 @@ SOURCE, an ." (string-suffix? archive-type url))) urls (or signature-urls (circular-list #f))))) - (let ((tarball (download-tarball store url signature-url + ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case, + ;; pick up the first element of URLS. + (let ((tarball (download-tarball store + (or url (first urls)) + (and (pair? signature-urls) + (or signature-url + (first signature-urls))) #:key-download key-download))) (values version tarball source)))))) -- cgit v1.2.3 From 8a3b11d1eb21e54b4f3a3cbceffed8ce2c11512e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 6 Aug 2019 20:17:27 +0100 Subject: import: utils: Add hash-ref*. With the change to guile-json version 3, JSON objects are represented as hash tables, rather than alists. The cpan importer uses assoc-ref* on a hash table, so add an equivalent function for hash tables. * guix/import/utils.scm (hash-ref*): New procedure. --- guix/import/utils.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 2a3b7341fb..ed6c3ce6af 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -47,6 +47,7 @@ flatten assoc-ref* + hash-ref* url-fetch guix-hash-url @@ -116,6 +117,15 @@ recursively apply the procedure to the sub-list." (assoc-ref alist key) (apply assoc-ref* (assoc-ref alist key) rest))) +(define (hash-ref* hash-table key . rest) + "Return the value for KEY from HASH-TABLE. For each additional key specified, +recursively apply the procedure to the sub-hash-table." + (if (hash-table? hash-table) + (if (null? rest) + (hash-ref hash-table key) + (apply hash-ref* (hash-ref hash-table key) rest)) + #f)) ; For consistency with assoc-ref* + (define (url-fetch url file-name) "Save the contents of URL to FILE-NAME. Return #f on failure." (parameterize ((current-output-port (current-error-port))) -- cgit v1.2.3 From 01ce7af25add55514f737af48ea6c127bedfde67 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 6 Aug 2019 20:17:28 +0100 Subject: import: cpan: Adapt for the change to guile-json version 3. In guile-json version 3, JSON objects are represented as hash tables, rather than alists. * guix/import/cpan.scm (string->license): Change the match expression to match on lists, rather than vectors. (module->dist-name, cpan-source-url, cpan-version): Change assoc-ref to hash-ref. (cpan-module->sexp): Change assoc-ref to hash-ref, and assoc-ref* to hash-ref*. * tests/cpan.scm ("source-url-http", "source-url-https"): Convert the alist to a hash table. --- guix/import/cpan.scm | 30 ++++++++++++++++-------------- tests/cpan.scm | 13 ++++++++----- 2 files changed, 24 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index ec86f11743..0be37e715e 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -34,7 +34,7 @@ #:use-module (guix ui) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module ((guix import utils) #:select (factorize-uri - flatten assoc-ref*)) + flatten hash-ref*)) #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) @@ -76,8 +76,8 @@ ;; ssleay ;; sun ("zlib" 'zlib) - (#(x) (string->license x)) - (#(lst ...) `(list ,@(map string->license lst))) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) (_ #f))) (define (module->name module) @@ -88,11 +88,11 @@ "Return the base distribution module for a given module. E.g. the 'ok' module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would return \"Test-Simple\"" - (assoc-ref (json-fetch (string-append - "https://fastapi.metacpan.org/v1/module/" - module - "?fields=distribution")) - "distribution")) + (hash-ref (json-fetch (string-append + "https://fastapi.metacpan.org/v1/module/" + module + "?fields=distribution")) + "distribution")) (define (package->upstream-name package) "Return the CPAN name of PACKAGE." @@ -122,12 +122,12 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" (define (cpan-source-url meta) "Return the download URL for a module's source tarball." (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" - (assoc-ref meta "download_url") + (hash-ref meta "download_url") 'pre "mirror://cpan" 'post)) (define (cpan-version meta) "Return the version number from META." - (match (assoc-ref meta "version") + (match (hash-ref meta "version") ((? number? version) ;; version is sometimes not quoted in the module json, so it gets ;; imported into Guile as a number, so convert it to a string. @@ -183,7 +183,7 @@ depend on (gnu packages perl)." "Return the `package' s-expression for a CPAN module from the metadata in META." (define name - (assoc-ref meta "distribution")) + (hash-ref meta "distribution")) (define (guix-name name) (if (string-prefix? "perl-" name) @@ -198,7 +198,9 @@ META." (match (flatten (map (lambda (ph) (filter-map (lambda (t) - (assoc-ref* meta "metadata" "prereqs" ph t)) + (and=> (hash-ref* meta "metadata" "prereqs" ph t) + (lambda (h) + (hash-map->list cons h)))) '("requires" "recommends" "suggests"))) phases)) (#f @@ -251,9 +253,9 @@ META." ,@(maybe-inputs 'propagated-inputs (convert-inputs '("runtime"))) (home-page ,(cpan-home name)) - (synopsis ,(assoc-ref meta "abstract")) + (synopsis ,(hash-ref meta "abstract")) (description fill-in-yourself!) - (license ,(string->license (assoc-ref meta "license")))))) + (license ,(string->license (hash-ref meta "license")))))) (define (cpan->guix-package module-name) "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the diff --git a/tests/cpan.scm b/tests/cpan.scm index 189dd027e6..cdd6c0e76a 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -24,7 +24,8 @@ #:use-module (guix tests) #:use-module (guix grafts) #:use-module (srfi srfi-64) - #:use-module (ice-9 match)) + #:use-module (ice-9 match) + #:use-module (ice-9 hash-table)) ;; Globally disable grafts because they can trigger early builds. (%graft? #f) @@ -109,14 +110,16 @@ (test-equal "source-url-http" ((@@ (guix import cpan) cpan-source-url) - `(("download_url" . - "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) + (alist->hash-table + `(("download_url" . + "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") (test-equal "source-url-https" ((@@ (guix import cpan) cpan-source-url) - `(("download_url" . - "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) + (alist->hash-table + `(("download_url" . + "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") (test-end "cpan") -- cgit v1.2.3 From d020821c0bd2206a5f3d4db155f2a9a3de7dc670 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 22 Aug 2019 14:24:11 -0400 Subject: Revert "import: cpan: Adapt for the change to guile-json version 3." This reverts commit 01ce7af25add55514f737af48ea6c127bedfde67. --- guix/import/cpan.scm | 30 ++++++++++++++---------------- tests/cpan.scm | 13 +++++-------- 2 files changed, 19 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 0be37e715e..ec86f11743 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -34,7 +34,7 @@ #:use-module (guix ui) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module ((guix import utils) #:select (factorize-uri - flatten hash-ref*)) + flatten assoc-ref*)) #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) @@ -76,8 +76,8 @@ ;; ssleay ;; sun ("zlib" 'zlib) - ((x) (string->license x)) - ((lst ...) `(list ,@(map string->license lst))) + (#(x) (string->license x)) + (#(lst ...) `(list ,@(map string->license lst))) (_ #f))) (define (module->name module) @@ -88,11 +88,11 @@ "Return the base distribution module for a given module. E.g. the 'ok' module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would return \"Test-Simple\"" - (hash-ref (json-fetch (string-append - "https://fastapi.metacpan.org/v1/module/" - module - "?fields=distribution")) - "distribution")) + (assoc-ref (json-fetch (string-append + "https://fastapi.metacpan.org/v1/module/" + module + "?fields=distribution")) + "distribution")) (define (package->upstream-name package) "Return the CPAN name of PACKAGE." @@ -122,12 +122,12 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" (define (cpan-source-url meta) "Return the download URL for a module's source tarball." (regexp-substitute/global #f "http[s]?://cpan.metacpan.org" - (hash-ref meta "download_url") + (assoc-ref meta "download_url") 'pre "mirror://cpan" 'post)) (define (cpan-version meta) "Return the version number from META." - (match (hash-ref meta "version") + (match (assoc-ref meta "version") ((? number? version) ;; version is sometimes not quoted in the module json, so it gets ;; imported into Guile as a number, so convert it to a string. @@ -183,7 +183,7 @@ depend on (gnu packages perl)." "Return the `package' s-expression for a CPAN module from the metadata in META." (define name - (hash-ref meta "distribution")) + (assoc-ref meta "distribution")) (define (guix-name name) (if (string-prefix? "perl-" name) @@ -198,9 +198,7 @@ META." (match (flatten (map (lambda (ph) (filter-map (lambda (t) - (and=> (hash-ref* meta "metadata" "prereqs" ph t) - (lambda (h) - (hash-map->list cons h)))) + (assoc-ref* meta "metadata" "prereqs" ph t)) '("requires" "recommends" "suggests"))) phases)) (#f @@ -253,9 +251,9 @@ META." ,@(maybe-inputs 'propagated-inputs (convert-inputs '("runtime"))) (home-page ,(cpan-home name)) - (synopsis ,(hash-ref meta "abstract")) + (synopsis ,(assoc-ref meta "abstract")) (description fill-in-yourself!) - (license ,(string->license (hash-ref meta "license")))))) + (license ,(string->license (assoc-ref meta "license")))))) (define (cpan->guix-package module-name) "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the diff --git a/tests/cpan.scm b/tests/cpan.scm index cdd6c0e76a..189dd027e6 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -24,8 +24,7 @@ #:use-module (guix tests) #:use-module (guix grafts) #:use-module (srfi srfi-64) - #:use-module (ice-9 match) - #:use-module (ice-9 hash-table)) + #:use-module (ice-9 match)) ;; Globally disable grafts because they can trigger early builds. (%graft? #f) @@ -110,16 +109,14 @@ (test-equal "source-url-http" ((@@ (guix import cpan) cpan-source-url) - (alist->hash-table - `(("download_url" . - "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))) + `(("download_url" . + "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") (test-equal "source-url-https" ((@@ (guix import cpan) cpan-source-url) - (alist->hash-table - `(("download_url" . - "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")))) + `(("download_url" . + "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"))) "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz") (test-end "cpan") -- cgit v1.2.3 From 888e477bf82452028fb188ec94e793bd04f98d55 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 22 Aug 2019 14:24:37 -0400 Subject: Revert "import: utils: Add hash-ref*." This reverts commit 8a3b11d1eb21e54b4f3a3cbceffed8ce2c11512e. --- guix/import/utils.scm | 10 ---------- 1 file changed, 10 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index ed6c3ce6af..2a3b7341fb 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -47,7 +47,6 @@ flatten assoc-ref* - hash-ref* url-fetch guix-hash-url @@ -117,15 +116,6 @@ recursively apply the procedure to the sub-list." (assoc-ref alist key) (apply assoc-ref* (assoc-ref alist key) rest))) -(define (hash-ref* hash-table key . rest) - "Return the value for KEY from HASH-TABLE. For each additional key specified, -recursively apply the procedure to the sub-hash-table." - (if (hash-table? hash-table) - (if (null? rest) - (hash-ref hash-table key) - (apply hash-ref* (hash-ref hash-table key) rest)) - #f)) ; For consistency with assoc-ref* - (define (url-fetch url file-name) "Save the contents of URL to FILE-NAME. Return #f on failure." (parameterize ((current-output-port (current-error-port))) -- cgit v1.2.3 From b908fcd8c02c26b1e6cdc636b63306a01a21b994 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 Aug 2019 17:45:17 +0200 Subject: pack: '-R' honors the requested output. Fixes . Reported by Jesse Gibbons . * guix/scripts/pack.scm (wrapped-package): Add 'output*' parameter. [build]: Define 'input' and 'target'; use them instead of #$package and #$output, respectively. (wrapped-manifest-entry): New procedure. (map-manifest-entries): Call PROC directly. (guix-pack): Pass WRAPPED-MANIFEST-ENTRY to 'map-manifest-entries'. --- guix/scripts/pack.scm | 49 ++++++++++++++++++++++++++++-------------- tests/guix-pack-relocatable.sh | 6 ++++++ 2 files changed, 39 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index fdb98983bf..794d2ee390 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -611,8 +611,13 @@ please email '~a'~%") ;;; (define* (wrapped-package package - #:optional (compiler (c-compiler)) + #:optional + (output* "out") + (compiler (c-compiler)) #:key proot?) + "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are +relocatable. When PROOT? is true, include PRoot in the result and use it as a +last resort for relocation." (define runner (local-file (search-auxiliary-file "run-in-namespace.c"))) @@ -629,6 +634,14 @@ please email '~a'~%") (ice-9 ftw) (ice-9 match)) + (define input + ;; The OUTPUT* output of PACKAGE. + (ungexp package output*)) + + (define target + ;; The output we are producing. + (ungexp output output*)) + (define (strip-store-prefix file) ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return ;; "/bin/foo". @@ -648,7 +661,7 @@ please email '~a'~%") (("@STORE_DIRECTORY@") (%store-directory))) (let* ((base (strip-store-prefix program)) - (result (string-append #$output "/" base)) + (result (string-append target "/" base)) (proot #$(and proot? #~(string-drop #$(file-append (proot) "/bin/proot") @@ -667,18 +680,18 @@ please email '~a'~%") ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. - (mkdir #$output) + (mkdir target) (for-each (lambda (file) (unless (member file '("." ".." "bin" "sbin" "libexec")) - (let ((file* (string-append #$package "/" file))) - (symlink (relative-file-name #$output file*) - (string-append #$output "/" file))))) - (scandir #$package)) + (let ((file* (string-append input "/" file))) + (symlink (relative-file-name target file*) + (string-append target "/" file))))) + (scandir input)) (for-each build-wrapper - (append (find-files #$(file-append package "/bin")) - (find-files #$(file-append package "/sbin")) - (find-files #$(file-append package "/libexec"))))))) + (append (find-files (string-append input "/bin")) + (find-files (string-append input "/sbin")) + (find-files (string-append input "/libexec"))))))) (computed-file (string-append (cond ((package? package) @@ -691,14 +704,18 @@ please email '~a'~%") "R") build)) +(define (wrapped-manifest-entry entry . args) + (manifest-entry + (inherit entry) + (item (apply wrapped-package + (manifest-entry-item entry) + (manifest-entry-output entry) + args)))) + (define (map-manifest-entries proc manifest) "Apply PROC to all the entries of MANIFEST and return a new manifest." (make-manifest - (map (lambda (entry) - (manifest-entry - (inherit entry) - (item (proc (manifest-entry-item entry))))) - (manifest-entries manifest)))) + (map proc (manifest-entries manifest)))) ;;; @@ -960,7 +977,7 @@ Create a bundle of PACKAGE.\n")) ;; 'glibc-bootstrap' lacks 'libc.a'. (if relocatable? (map-manifest-entries - (cut wrapped-package <> #:proot? proot?) + (cut wrapped-manifest-entry <> #:proot? proot?) manifest) manifest))) (pack-format (assoc-ref opts 'format)) diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index ebada62c01..e93610eedc 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -78,3 +78,9 @@ else "$test_directory/Bin/sed" --version > "$test_directory/output" fi grep 'GNU sed' "$test_directory/output" +chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* + +# Ensure '-R' works with outputs other than "out". +tarball="`guix pack -R -S /share=share groff:doc`" +(cd "$test_directory"; tar xvf "$tarball") +test -d "$test_directory/share/doc/groff/html" -- cgit v1.2.3 From 90c98b5a89038c41a0db0add9e2a3d4d1a1b6102 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 Aug 2019 18:16:13 +0200 Subject: swh: 'swh-download' checks return value of 'vault-fetch'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by Björn Höfling in . * guix/swh.scm (swh-download): Check whether 'vault-fetch' return false before calling 'dump-port'. --- guix/swh.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index df2a138f04..1c416c8dd5 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -547,19 +547,22 @@ wait until it becomes available, which could take several minutes." ((? revision? revision) (call-with-temporary-directory (lambda (directory) - (let ((input (vault-fetch (revision-directory revision) 'directory)) - (tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) - (dump-port input tar) - (close-port input) - (let ((status (close-pipe tar))) - (unless (zero? status) - (error "tar extraction failure" status))) - - (match (scandir directory) - (("." ".." sub-directory) - (copy-recursively (string-append directory "/" sub-directory) - output - #:log (%make-void-port "w")) - #t)))))) + (match (vault-fetch (revision-directory revision) 'directory) + (#f + #f) + ((? port? input) + (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) + (dump-port input tar) + (close-port input) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + + (match (scandir directory) + (("." ".." sub-directory) + (copy-recursively (string-append directory "/" sub-directory) + output + #:log (%make-void-port "w")) + #t)))))))) (#f #f))) -- cgit v1.2.3 From 6cef554be8926b026226b4bfd0bb2f37bd24aeae Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 1 Aug 2019 08:46:13 -0400 Subject: packages: Apply target triplet in bag-transitive-host-inputs. Fixes a bug where propagated inputs that should be cross-compiled are instead compiled for the host system. * guix/packages.scm (bag-transitive-host-inputs): Call transitive-inputs in the context of the bag's target system triplet. --- guix/packages.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index c94a651f27..143417b861 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -796,7 +796,8 @@ dependencies are known to build on SYSTEM." (define (bag-transitive-host-inputs bag) "Same as 'package-transitive-target-inputs', but applied to a bag." - (transitive-inputs (bag-host-inputs bag))) + (parameterize ((%current-target-system (bag-target bag))) + (transitive-inputs (bag-host-inputs bag)))) (define (bag-transitive-target-inputs bag) "Return the \"target inputs\" of BAG, recursively." -- cgit v1.2.3 From dd6976dd75ca97572e0e88a6be2e550fb0824c68 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Aug 2019 21:34:40 +0200 Subject: import: github: 'github-package?' uses 'package-upstream-name'. * guix/import/github.scm (updated-github-url): Use 'package-upstream-name' instead of 'package-name'. This allows 'github-package?' to match more packages, given an appropriate upstream name. --- guix/import/github.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index fa23fa4c06..55e1f72a42 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -49,7 +49,7 @@ false if none is recognized" (define (updated-url url) (if (string-prefix? "https://github.com/" url) (let ((ext (or (find-extension url) "")) - (name (package-name old-package)) + (name (package-upstream-name old-package)) (version (package-version old-package)) (prefix (string-append "https://github.com/" (github-user-slash-repository url))) -- cgit v1.2.3 From 2b7c89f4fcc5e1607e153939d54d32aeaf494ca9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 11:02:14 +0200 Subject: docker: Take a list of directives instead of a list of symlinks. * guix/docker.scm (symlink-source, topmost-component): Remove. (directive-file): New procedure. (build-docker-image): Remove #:symlinks and add #:extra-files. Make a sub-directory "extra" and call 'evaluate-populate-directive' for EXTRA-FILES in that directory. * guix/scripts/pack.scm (docker-image)[build](symlink->directives, directives): New procedures. Pass #:extra-files instead of #:symlinks to 'build-docker-image'. --- guix/docker.scm | 68 ++++++++++++++++++++++++--------------------------- guix/scripts/pack.scm | 20 +++++++++++++-- 2 files changed, 50 insertions(+), 38 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index c598a073f6..757bdeb458 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -28,11 +28,13 @@ invoke)) #:use-module (gnu build install) #:use-module (json) ;guile-json + #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module ((texinfo string-utils) #:select (escape-special-chars)) #:use-module (rnrs bytevectors) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (build-docker-image)) @@ -99,21 +101,18 @@ '("--sort=name" "--mtime=@1" "--owner=root:0" "--group=root:0")) -(define symlink-source +(define directive-file + ;; Return the file or directory created by a 'evaluate-populate-directive' + ;; directive. (match-lambda ((source '-> target) - (string-trim source #\/)))) - -(define (topmost-component file) - "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", -return \"a\"." - (match (string-tokenize file (char-set-complement (char-set #\/))) - ((first rest ...) - first))) + (string-trim source #\/)) + (('directory name _ ...) + (string-trim name #\/)))) (define* (build-docker-image image paths prefix #:key - (symlinks '()) + (extra-files '()) (transformations '()) (system (utsname:machine (uname))) database @@ -133,8 +132,9 @@ entry point in the Docker image JSON structure. ENVIRONMENT must be a list of name/value pairs. It specifies the environment variables that must be defined in the resulting image. -SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be -created in the image, where each TARGET is relative to PREFIX. +EXTRA-FILES must be a list of directives for 'evaluate-populate-directive' +describing non-store files that must be created in the image. + TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to transform the PATHS. Any path in PATHS that begins with OLD will be rewritten in the Docker image so that it begins with NEW instead. If a path is a @@ -199,25 +199,27 @@ SRFI-19 time-utc object, as the creation time in metadata." (with-output-to-file "json" (lambda () (scm->json (image-description id time)))) - ;; Create SYMLINKS. - (for-each (match-lambda - ((source '-> target) - (let ((source (string-trim source #\/))) - (mkdir-p (dirname source)) - (symlink (string-append prefix "/" target) - source)))) - symlinks) + ;; Create a directory for the non-store files that need to go into the + ;; archive. + (mkdir "extra") + + (with-directory-excursion "extra" + ;; Create non-store files. + (for-each (cut evaluate-populate-directive <> "./") + extra-files) - (when database - ;; Initialize /var/guix, assuming PREFIX points to a profile. - (install-database-and-gc-roots "." database prefix)) + (when database + ;; Initialize /var/guix, assuming PREFIX points to a profile. + (install-database-and-gc-roots "." database prefix)) + + (apply invoke "tar" "-cf" "../layer.tar" + `(,@transformation-options + ,@%tar-determinism-options + ,@paths + ,@(scandir "." + (lambda (file) + (not (member file '("." "..")))))))) - (apply invoke "tar" "-cf" "layer.tar" - `(,@transformation-options - ,@%tar-determinism-options - ,@paths - ,@(if database '("var") '()) - ,@(map symlink-source symlinks))) ;; It is possible for "/" to show up in the archive, especially when ;; applying transformations. For example, the transformation ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform @@ -231,13 +233,7 @@ SRFI-19 time-utc object, as the creation time in metadata." (lambda () (system* "tar" "--delete" "/" "-f" "layer.tar"))) - (for-each delete-file-recursively - (map (compose topmost-component symlink-source) - symlinks)) - - ;; Delete /var/guix. - (when database - (delete-file-recursively "var"))) + (delete-file-recursively "extra")) (with-output-to-file "config.json" (lambda () diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 794d2ee390..a15530ad70 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -490,7 +490,8 @@ the image." #~(begin (use-modules (guix docker) (guix build store-copy) (guix profiles) (guix search-paths) - (srfi srfi-19) (ice-9 match)) + (srfi srfi-1) (srfi srfi-19) + (ice-9 match)) (define environment (map (match-lambda @@ -499,6 +500,21 @@ the image." value))) (profile-search-paths #$profile))) + (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))) + `((directory ,parent) + (,source -> ,target)))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + (setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output @@ -513,7 +529,7 @@ the image." #$(and entry-point #~(list (string-append #$profile "/" #$entry-point))) - #:symlinks '#$symlinks + #:extra-files directives #:compressor '#$(compressor-command compressor) #:creation-time (make-time time-utc 0 1)))))) -- cgit v1.2.3 From 7979a287f8eb84cbbfa44629951572408939a756 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 11:27:02 +0200 Subject: pack: Create /tmp in Docker images. Fixes . * guix/scripts/pack.scm (docker-image)[build]: Add a 'directory' entry for "/tmp" to DIRECTIVES. * tests/pack.scm ("docker-image + localstatedir"): Test the presence of /tmp. * gnu/tests/docker.scm (run-docker-test)["Load docker image and run it"]: Test the presence and permission bits of "/tmp". --- gnu/tests/docker.scm | 13 ++++++++++--- guix/scripts/pack.scm | 6 ++++-- tests/pack.scm | 1 + 3 files changed, 15 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 3ec5c3d6ee..3f98a1e316 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -100,7 +100,7 @@ inside %DOCKER-OS." marionette)) (test-equal "Load docker image and run it" - '("hello world" "hi!" "JSON!") + '("hello world" "hi!" "JSON!" #o1777) (marionette-eval `(begin (define slurp @@ -131,8 +131,15 @@ inside %DOCKER-OS." ,(string-append #$docker-cli "/bin/docker") "run" repository&tag "-c" "(use-modules (json)) - (display (json-string->scm (scm->json-string \"JSON!\")))"))) - (list response1 response2 response3))) + (display (json-string->scm (scm->json-string \"JSON!\")))")) + + ;; Check whether /tmp exists. + (response4 (slurp + ,(string-append #$docker-cli "/bin/docker") + "run" repository&tag "-c" + "(display (stat:perms (lstat \"/tmp\")))"))) + (list response1 response2 response3 + (string->number response4)))) marionette)) (test-end) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a15530ad70..dd91a24284 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -511,8 +511,10 @@ the image." (,source -> ,target)))))) (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + ;; Create a /tmp directory, as some programs expect it, and + ;; create SYMLINKS. + `((directory "/tmp" ,(getuid) ,(getgid) #o1777) + ,@(append-map symlink->directives '#$symlinks))) (setenv "PATH" (string-append #$archiver "/bin")) diff --git a/tests/pack.scm b/tests/pack.scm index ea88cd89f2..71ff5aec18 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -169,6 +169,7 @@ (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") -- cgit v1.2.3 From 58d5f280a36e1cfddfa999d320c285726d8a8bc1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Aug 2019 23:59:48 +0200 Subject: lint: Correct use of 'with-networking-fail-safe'. Fixes . Reported by Jonathan Brielmaier . * guix/lint.scm (check-for-updates): Make sure the first argument to 'with-networking-fail-safe' is the whole error message. --- guix/lint.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 7a2bf5a347..212ff70d54 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1008,8 +1008,8 @@ the NIST server non-fatal." (define (check-for-updates package) "Check if there is an update available for PACKAGE." (match (with-networking-fail-safe - (G_ "while retrieving upstream info for '~a'") - (list (package-name package)) + (format #f (G_ "while retrieving upstream info for '~a'") + (package-name package)) #f (package-latest-release* package (force %updaters))) ((? upstream-source? source) -- cgit v1.2.3 From 3762e31b6c8089928aad3186f70f157502950e3b Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 22 Aug 2019 16:21:26 +0300 Subject: build/cargo-build-system: Remove 'update-cargo-lock phase. * guix/build/cargo-build-system.scm (update-cargo-lock): Remove procedure. (configure): Delete Cargo.lock file if it exists. (%standard-phases): Remove 'update-cargo-lock. * doc/guix.texi (Build System)[cargo-build-system]: Remove references to the 'update-cargo-lock phase. --- doc/guix.texi | 9 ++++----- guix/build/cargo-build-system.scm | 19 ++++--------------- 2 files changed, 8 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 90b2deb251..707c2ba700 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5854,11 +5854,10 @@ should be added to the package definition via the In its @code{configure} phase, this build system will make any source inputs specified in the @code{#:cargo-inputs} and @code{#:cargo-development-inputs} -parameters available to cargo. The @code{update-cargo-lock} phase will, -when there is a @code{Cargo.lock} file, update the @code{Cargo.lock} file -with the inputs and their versions available at build time. The -@code{install} phase installs any crate the binaries if they are defined by -the crate. +parameters available to cargo. It will also remove an included +@code{Cargo.lock} file to be recreated by @code{cargo} during the +@code{build} phase. The @code{install} phase installs any crate the binaries +if they are defined by the crate. @end defvr @cindex Clojure (programming language) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 7d363a18a5..06ed14b89f 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -134,22 +134,12 @@ directory = '" port) ;; upgrading the compiler for example. (setenv "RUSTFLAGS" "--cap-lints allow") (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc")) - #t) -;; The Cargo.lock file tells the build system which crates are required for -;; building and hardcodes their version and checksum. In order to build with -;; the inputs we provide, we need to recreate the file with our inputs. -(define* (update-cargo-lock #:key - (vendor-dir "guix-vendor") - #:allow-other-keys) - "Regenerate the Cargo.lock file with the current build inputs." + ;; We don't use the Cargo.lock file to determine the package versions we use + ;; during building, and in any case if one is not present it is created + ;; during the 'build phase by cargo. (when (file-exists? "Cargo.lock") - (begin - ;; Unfortunately we can't generate a Cargo.lock file until the checksums - ;; are generated, so we have an extra round of generate-all-checksums here. - (generate-all-checksums vendor-dir) - (delete-file "Cargo.lock") - (invoke "cargo" "generate-lockfile"))) + (delete-file "Cargo.lock")) #t) ;; After the 'patch-generated-file-shebangs phase any vendored crates who have @@ -203,7 +193,6 @@ directory = '" port) (replace 'build build) (replace 'check check) (replace 'install install) - (add-after 'configure 'update-cargo-lock update-cargo-lock) (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) -- cgit v1.2.3 From b8815c5ec4ee70c535693031072447671c1b781f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 11:10:55 +0200 Subject: swh: 'swh-download' prints debugging info. * guix/git-download.scm (git-fetch): Print a message before calling 'swh-download'. * guix/swh.scm (swh-download): Add #:log-port. Write debugging messages to LOG-PORT. --- guix/git-download.scm | 7 +++++-- guix/swh.scm | 12 ++++++++++-- 2 files changed, 15 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 8f84681d46..c62bb8ad0f 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -139,8 +139,11 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; As a last resort, attempt to download from Software Heritage. ;; XXX: Currently recursive checkouts are not supported. (and (not recursive?) - (swh-download (getenv "git url") (getenv "git commit") - #$output))))))) + (begin + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (swh-download (getenv "git url") (getenv "git commit") + #$output)))))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build diff --git a/guix/swh.scm b/guix/swh.scm index 1c416c8dd5..b72d1c311e 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -533,7 +533,8 @@ delete it when leaving the dynamic extent of this call." (lambda () (false-if-exception (delete-file-recursively tmp-dir)))))) -(define (swh-download url reference output) +(define* (swh-download url reference output + #:key (log-port (current-error-port))) "Download from Software Heritage a checkout of the Git tag or commit REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success and #f on failure. @@ -545,10 +546,17 @@ wait until it becomes available, which could take several minutes." (lookup-revision reference) (lookup-origin-revision url reference)) ((? revision? revision) + (format log-port "SWH: found revision ~a with directory at '~a'~%" + (revision-id revision) + (swh-url (revision-directory-url revision))) (call-with-temporary-directory (lambda (directory) - (match (vault-fetch (revision-directory revision) 'directory) + (match (vault-fetch (revision-directory revision) 'directory + #:log-port log-port) (#f + (format log-port + "SWH: directory ~a could not be fetched from the vault~%" + (revision-directory revision)) #f) ((? port? input) (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) -- cgit v1.2.3 From 8146c48632d39670afa7a8ec08a8891cc78d2b38 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 11:31:18 +0200 Subject: swh: Correctly handle visits without a snapshot. As discussed at . * guix/swh.scm (string*): New procedure. ()[snapshot-url]: Pass 'string*' as the conversion procedure. [status]: Pass 'string->symbol' as the conversion procedure. (visit-snapshot): Return #f when 'visit-snapshot-url' returns #f. (lookup-origin-revision): Filter to visits for which 'visit-snapshot-url' is true. --- guix/swh.scm | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index b72d1c311e..c253e217da 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -190,6 +190,12 @@ Software Heritage." (ref 10)))))) str)) ;oops! +(define string* + ;; Converts "string or #nil" coming from JSON to "string or #f". + (match-lambda + ((? string? str) str) + ((? null?) #f))) + (define* (call url decode #:optional (method http-get) #:key (false-if-404? #t)) "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body @@ -239,8 +245,8 @@ FALSE-IF-404? is true, return #f upon 404 responses." (date visit-date "date" string->date*) (origin visit-origin) (url visit-url "origin_visit_url") - (snapshot-url visit-snapshot-url "snapshot_url") - (status visit-status) + (snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f + (status visit-status "status" string->symbol) ;'full | 'partial | 'ongoing (number visit-number "visit")) ;; @@ -378,9 +384,11 @@ FALSE-IF-404? is true, return #f upon 404 responses." (map json->visit (vector->list (json->scm port)))))) (define (visit-snapshot visit) - "Return the snapshot corresponding to VISIT." - (call (swh-url (visit-snapshot-url visit)) - json->snapshot)) + "Return the snapshot corresponding to VISIT or #f if no snapshot is +available." + (and (visit-snapshot-url visit) + (call (swh-url (visit-snapshot-url visit)) + json->snapshot))) (define (branch-target branch) "Return the target of BRANCH, either a or a ." @@ -396,7 +404,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." "Return a corresponding to the given TAG for the repository coming from URL. Example: - (lookup-origin-release \"https://github.com/guix-mirror/guix/\" \"v0.8\") + (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\") => #< id: \"44941…\" …> The information is based on the latest visit of URL available. Return #f if @@ -404,7 +412,7 @@ URL could not be found." (match (lookup-origin url) (#f #f) (origin - (match (origin-visits origin) + (match (filter visit-snapshot-url (origin-visits origin)) ((visit . _) (let ((snapshot (visit-snapshot visit))) (match (and=> (find (lambda (branch) -- cgit v1.2.3 From 8f67a76a544a9ff7b60de64d5619a63296c9553e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 17:38:45 +0200 Subject: lint: Log diagnostics with 'info', not 'warning'. * guix/scripts/lint.scm (emit-warnings): Use 'info', not 'warning'. This removes the unhelpful "warning:" prefix that commit 3d33c93cef67d88bdc9409959f3c1f3857af09cf introduced. --- guix/scripts/lint.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index ee1c826d2e..1668d02992 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -46,9 +46,9 @@ (lambda (lint-warning) (let ((package (lint-warning-package lint-warning)) (loc (lint-warning-location lint-warning))) - (warning loc (G_ "~a@~a: ~a~%") - (package-name package) (package-version package) - (lint-warning-message lint-warning)))) + (info loc (G_ "~a@~a: ~a~%") + (package-name package) (package-version package) + (lint-warning-message lint-warning)))) warnings)) (define (run-checkers package checkers) -- cgit v1.2.3 From d229215051b87bfc4657e8416f0e7b87c3ed620e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 18:00:42 +0200 Subject: diagnostics: Avoid highlighting complete messages. * guix/diagnostics.scm (%highlight-argument): Don't highlight ARG if it contains white space. --- guix/diagnostics.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 380cfbb613..6c0753aef4 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -71,7 +71,12 @@ is a trivial format string." (define* (%highlight-argument arg #:optional (port (guix-warning-port))) "Highlight ARG, a format string argument, if PORT supports colors." (cond ((string? arg) - (highlight arg port)) + ;; If ARG contains white space, don't highlight it, on the grounds + ;; that it may be a complete message in its own, like those produced + ;; by 'guix lint. + (if (string-any char-set:whitespace arg) + arg + (highlight arg port))) ((symbol? arg) (highlight (symbol->string arg) port)) (else arg))) -- cgit v1.2.3 From e09c7f4ae4e1c634975874cc18fd65ae4c4af091 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 18:51:12 +0200 Subject: remote, ssh: Show the command exit status upon failure. * guix/remote.scm (remote-pipe-for-gexp): Show the exit status in error message. * guix/ssh.scm (remote-inferior): Likewise. --- guix/remote.scm | 12 ++++++++---- guix/ssh.scm | 14 +++++++------- 2 files changed, 15 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/remote.scm b/guix/remote.scm index d0c3d04a25..c00585de74 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -27,6 +27,7 @@ #:use-module (guix derivations) #:use-module (guix utils) #:use-module (ssh popen) + #:use-module (ssh channel) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -68,10 +69,13 @@ BECOME-COMMAND is given, use that to invoke the remote Guile REPL." (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) (when (eof-object? (peek-char pipe)) - (raise (condition - (&message - (message (format #f (G_ "failed to run '~{~a~^ ~}'") - repl-command)))))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) + (raise (condition + (&message + (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ +with status ~a") + repl-command status))))))) pipe)) (define* (%remote-eval lowered session #:optional become-command) diff --git a/guix/ssh.scm b/guix/ssh.scm index 7bc499a2fe..b6b55bdfcb 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -106,14 +106,14 @@ given, use that to invoke the remote Guile REPL." (let* ((repl-command (append (or become-command '()) '("guix" "repl" "-t" "machine"))) (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command))) - ;; XXX: 'channel-get-exit-status' would be better here, but hangs if the - ;; process does succeed. This doesn't reflect the documentation, so it's - ;; possible that it's a bug in guile-ssh. (when (eof-object? (peek-char pipe)) - (raise (condition - (&message - (message (format #f (G_ "failed to run '~{~a~^ ~}'") - repl-command)))))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) + (raise (condition + (&message + (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ +with status ~a") + repl-command status))))))) (port->inferior pipe))) (define* (inferior-remote-eval exp session #:optional become-command) -- cgit v1.2.3 From dae950ca50bca57c6d8c5fd8946de5eece614f0a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 18:51:49 +0200 Subject: deploy: Do not quote error messages. * guix/scripts/deploy.scm (guix-deploy): Do not quote the message. --- guix/scripts/deploy.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 6a67985c8b..329de41143 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -94,7 +94,7 @@ Perform the deployment specified by FILE.\n")) (machine-display-name machine)) (parameterize ((%graft? (assq-ref opts 'graft?))) (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: '~a'~%") + (report-error (G_ "failed to deploy ~a: ~a~%") (machine-display-name machine) (condition-message c))) ((deploy-error? c) -- cgit v1.2.3 From 54ddd852209a0bd8500dc7dd5775d5dd87a9a017 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 28 Aug 2019 16:48:55 +0200 Subject: import: cran: guix-import-cran: Use (guix import utils). * guix/scripts/import/cran.scm (guix-import-cran): Use PACKAGE->DEFINITION from (guix import utils) instead of custom procedure. --- guix/scripts/import/cran.scm | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 794fb710cd..b6592f78a9 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Eric Bavier -;;; Copyright © 2015, 2017 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import cran) + #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -96,11 +97,7 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) ((package-name) (if (assoc-ref opts 'recursive) ;; Recursive import - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) + (map package->definition (reverse (stream->list (cran-recursive-import package-name -- cgit v1.2.3 From ad553ec4b12f24a0bbd25b547bac885ddb84776a Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 28 Aug 2019 00:38:31 +0200 Subject: import: cran: Add support for git repositories. * guix/import/cran.scm (vcs-file?): New procedure. (download): Support downloading from git. (fetch-description): Add a clause for the 'git repository type. (files-match-pattern?): New procedure. (tarball-files-match-pattern?): Implement in terms of FILES-MATCH-PATTERN?. (directory-needs-fortran?, directory-needs-zlib?, directory-needs-pkg-config?): New procedures. (needs-fortran?, needs-zlib?, needs-pkg-config?): Rename these procedures... (tarball-needs-fortran?, tarball-needs-zlib?, tarball-needs-pkg-config?): ...to this, and use them. (file-hash): New procedure. (description->package): Handle the 'git repository type. * guix/import/utils.scm (package->definition): Handle package expression inside of a let. * guix/scripts/import.scm (guix-import): Handle let expressions. * doc/guix.texi (Invoking guix import): Document it. --- doc/guix.texi | 8 ++ guix/import/cran.scm | 254 ++++++++++++++++++++++++++++++++++-------------- guix/import/utils.scm | 5 +- guix/scripts/import.scm | 4 +- 4 files changed, 198 insertions(+), 73 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5a64b89086..a87a8a3d9a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8638,6 +8638,14 @@ R package: guix import cran --archive=bioconductor GenomicRanges @end example +Finally, you can also import R packages that have not yet been published on +CRAN or Bioconductor as long as they are in a git repository. Use +@code{--archive=git} followed by the URL of the git repository: + +@example +guix import cran --archive=git https://github.com/immunogenomics/harmony +@end example + @item texlive @cindex TeX Live @cindex CTAN diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9c964701b1..51c7ea7b2f 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -24,6 +24,7 @@ #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 receive) @@ -32,11 +33,13 @@ #:use-module (guix http-client) #:use-module (gcrypt hash) #:use-module (guix store) + #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module ((guix build utils) #:select (find-files)) #:use-module (guix utils) + #:use-module (guix git) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) #:use-module (guix upstream) #:use-module (guix packages) @@ -166,11 +169,25 @@ bioconductor package NAME, or #F if the package is unknown." (bioconductor-packages-list type)) (cut assoc-ref <> "Version"))) +;; XXX taken from (guix scripts hash) +(define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) + (else + #f))) + ;; Little helper to download URLs only once. (define download (memoize - (lambda (url) - (with-store store (download-to-store store url))))) + (lambda* (url #:optional git) + (with-store store + (if git + (latest-repository-commit store url) + (download-to-store store url)))))) (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package @@ -211,7 +228,18 @@ from ~s: ~a (~s)~%" (string-append dir "/DESCRIPTION") read-string)) (lambda (meta) (if (boolean? type) meta - (cons `(bioconductor-type . ,type) meta)))))))))))) + (cons `(bioconductor-type . ,type) meta)))))))))) + ((git) + ;; Download the git repository at "NAME" + (call-with-values + (lambda () (download name #t)) + (lambda (dir commit) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (cons* `(git . ,name) + `(git-commit . ,commit) + meta)))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -256,7 +284,7 @@ empty list when the FIELD cannot be found." (define cran-guix-name (cut guix-name "r-" <>)) -(define (needs-fortran? tarball) +(define (tarball-needs-fortran? tarball) "Check if the TARBALL contains Fortran source files." (define (check pattern) (parameterize ((current-error-port (%make-void-port "rw+")) @@ -266,69 +294,127 @@ empty list when the FIELD cannot be found." (check "*.f95") (check "*.f"))) +(define (directory-needs-fortran? dir) + "Check if the directory DIR contains Fortran source files." + (match (find-files dir "\\.f(90|95)?") + (() #f) + (_ #t))) + +(define (needs-fortran? thing tarball?) + "Check if the THING contains Fortran source files." + (if tarball? + (tarball-needs-fortran? thing) + (directory-needs-fortran? thing))) + +(define (files-match-pattern? directory regexp . file-patterns) + "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match +the given REGEXP." + (let ((pattern (make-regexp regexp))) + (any (lambda (file) + (call-with-input-file file + (lambda (port) + (let loop () + (let ((line (read-line port))) + (cond + ((eof-object? line) #f) + ((regexp-exec pattern line) #t) + (else (loop)))))))) + (apply find-files directory file-patterns)))) + (define (tarball-files-match-pattern? tarball regexp . file-patterns) "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL match the given REGEXP." (call-with-temporary-directory (lambda (dir) - (let ((pattern (make-regexp regexp))) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (apply system* "tar" - "xf" tarball "-C" dir - `("--wildcards" ,@file-patterns))) - (any (lambda (file) - (call-with-input-file file - (lambda (port) - (let loop () - (let ((line (read-line port))) - (cond - ((eof-object? line) #f) - ((regexp-exec pattern line) #t) - (else (loop)))))))) - (find-files dir)))))) - -(define (needs-zlib? tarball) + (parameterize ((current-error-port (%make-void-port "rw+"))) + (apply system* "tar" + "xf" tarball "-C" dir + `("--wildcards" ,@file-patterns))) + (files-match-pattern? dir regexp)))) + +(define (directory-needs-zlib? dir) + "Return #T if any of the Makevars files in the src directory DIR contain a +zlib linker flag." + (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)")) + +(define (tarball-needs-zlib? tarball) "Return #T if any of the Makevars files in the src directory of the TARBALL contain a zlib linker flag." (tarball-files-match-pattern? tarball "-lz" "*/src/Makevars*" "*/src/configure*" "*/configure*")) -(define (needs-pkg-config? tarball) +(define (needs-zlib? thing tarball?) + "Check if the THING contains files indicating a dependency on zlib." + (if tarball? + (tarball-needs-zlib? thing) + (directory-needs-zlib? thing))) + +(define (directory-needs-pkg-config? dir) + "Return #T if any of the Makevars files in the src directory DIR reference +the pkg-config tool." + (files-match-pattern? dir "pkg-config" + "(Makevars.*|configure.*)")) + +(define (tarball-needs-pkg-config? tarball) "Return #T if any of the Makevars files in the src directory of the TARBALL reference the pkg-config tool." (tarball-files-match-pattern? tarball "pkg-config" "*/src/Makevars*" "*/src/configure*" "*/configure*")) +(define (needs-pkg-config? thing tarball?) + "Check if the THING contains files indicating a dependency on pkg-config." + (if tarball? + (tarball-needs-pkg-config? thing) + (directory-needs-pkg-config? thing))) + +;; XXX adapted from (guix scripts hash) +(define (file-hash file select? recursive?) + ;; Compute the hash of FILE. + (if recursive? + (let-values (((port get-hash) (open-sha256-port))) + (write-file file port #:select? select?) + (force-output port) + (get-hash)) + (call-with-input-file file port-sha256))) + (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." (let* ((base-url (case repository ((cran) %cran-url) - ((bioconductor) %bioconductor-url))) + ((bioconductor) %bioconductor-url) + ((git) #f))) (uri-helper (case repository ((cran) cran-uri) - ((bioconductor) bioconductor-uri))) + ((bioconductor) bioconductor-uri) + ((git) #f))) (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) (license (string->license (assoc-ref meta "License"))) ;; Some packages have multiple home pages. Some have none. - (home-page (match (listify meta "URL") - ((url rest ...) url) - (_ (string-append base-url name)))) - (source-url (match (apply uri-helper name version - (case repository - ((bioconductor) - (list (assoc-ref meta 'bioconductor-type))) - (else '()))) - ((url rest ...) url) - ((? string? url) url) - (_ #f))) - (tarball (download source-url)) + (home-page (case repository + ((git) (assoc-ref meta 'git)) + (else (match (listify meta "URL") + ((url rest ...) url) + (_ (string-append base-url name)))))) + (source-url (case repository + ((git) (assoc-ref meta 'git)) + (else + (match (apply uri-helper name version + (case repository + ((bioconductor) + (list (assoc-ref meta 'bioconductor-type))) + (else '()))) + ((url rest ...) url) + ((? string? url) url) + (_ #f))))) + (git? (assoc-ref meta 'git)) + (source (download source-url git?)) (sysdepends (append - (if (needs-zlib? tarball) '("zlib") '()) + (if (needs-zlib? source (not git?)) '("zlib") '()) (filter (lambda (name) (not (member name invalid-packages))) (map string-downcase (listify meta "SystemRequirements"))))) @@ -339,41 +425,67 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (listify meta "Imports") (listify meta "LinkingTo") (delete "R" - (listify meta "Depends")))))) + (listify meta "Depends"))))) + (package + `(package + (name ,(cran-guix-name name)) + (version ,(case repository + ((git) + `(git-version ,version revision commit)) + (else version))) + (source (origin + (method ,(if git? + 'git-fetch + 'url-fetch)) + (uri ,(case repository + ((git) + `(git-reference + (url ,(assoc-ref meta 'git)) + (commit commit))) + (else + `(,(procedure-name uri-helper) ,name version + ,@(or (and=> (assoc-ref meta 'bioconductor-type) + (lambda (type) + (list (list 'quote type)))) + '()))))) + ,@(if git? + '((file-name (git-file-name name version))) + '()) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (case repository + ((git) + (file-hash source (negate vcs-file?) #t)) + (else (file-sha256 source)))))))) + ,@(if (not (and git? + (equal? (string-append "r-" name) + (cran-guix-name name)))) + `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) + '()) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) + ,@(maybe-inputs + `(,@(if (needs-fortran? source (not git?)) + '("gfortran") '()) + ,@(if (needs-pkg-config? source (not git?)) + '("pkg-config") '())) + 'native-inputs) + (home-page ,(if (string-null? home-page) + (string-append base-url name) + home-page)) + (synopsis ,synopsis) + (description ,(beautify-description (or (assoc-ref meta "Description") + ""))) + (license ,license)))) (values - `(package - (name ,(cran-guix-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (,(procedure-name uri-helper) ,name version - ,@(or (and=> (assoc-ref meta 'bioconductor-type) - (lambda (type) - (list (list 'quote type)))) - '()))) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - ,@(if (not (equal? (string-append "r-" name) - (cran-guix-name name))) - `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) - '()) - (build-system r-build-system) - ,@(maybe-inputs sysdepends) - ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) - ,@(maybe-inputs - `(,@(if (needs-fortran? tarball) - '("gfortran") '()) - ,@(if (needs-pkg-config? tarball) - '("pkg-config") '())) - 'native-inputs) - (home-page ,(if (string-null? home-page) - (string-append base-url name) - home-page)) - (synopsis ,synopsis) - (description ,(beautify-description (or (assoc-ref meta "Description") - ""))) - (license ,license)) + (case repository + ((git) + `(let ((commit ,(assoc-ref meta 'git-commit)) + (revision "1")) + ,package)) + (else package)) propagate))) (define cran->guix-package diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 2a3b7341fb..252875eeab 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2019 Ricardo Wurmus ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2019 Robert Vollmert ;;; @@ -251,6 +251,9 @@ package definition." (define (package->definition guix-package) (match guix-package (('package ('name (? string? name)) _ ...) + `(define-public ,(string->symbol name) + ,guix-package)) + (('let anything ('package ('name (? string? name)) _ ...)) `(define-public ,(string->symbol name) ,guix-package)))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 0b326e1049..c6cc93fad8 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2014 David Thompson ;;; Copyright © 2018 Kyle Meyer +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -113,7 +114,8 @@ Run IMPORTER with ARGS.\n")) (pretty-print expr (newline-rewriting-port (current-output-port)))))) (match (apply (resolve-importer importer) args) - ((and expr ('package _ ...)) + ((and expr (or ('package _ ...) + ('let _ ...))) (print expr)) ((? list? expressions) (for-each (lambda (expr) -- cgit v1.2.3 From 7d09f2e85faa03fd017fef2774c2aa9807c70f43 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 Aug 2019 12:15:09 +0200 Subject: lint: formatting: Reporters return #f or a warning. * guix/lint.scm (report-tabulations, report-trailing-white-space) (report-long-line, report-lone-parentheses): Return #f instead of *unspecified* when there are no warnings. (report-formatting-issues): Use 'filter-map' instead of 'map' + 'filter'. --- guix/lint.scm | 60 +++++++++++++++++++++++++++++------------------------------ 1 file changed, 29 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 212ff70d54..2bf5097403 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1031,7 +1031,7 @@ the NIST server non-fatal." (define (report-tabulations package line line-number) "Warn about tabulations found in LINE." (match (string-index line #\tab) - (#f #t) + (#f #f) (index (make-warning package (G_ "tabulation on line ~a, column ~a") @@ -1043,44 +1043,44 @@ the NIST server non-fatal." (define (report-trailing-white-space package line line-number) "Warn about trailing white space in LINE." - (unless (or (string=? line (string-trim-right line)) - (string=? line (string #\page))) - (make-warning package - (G_ "trailing white space on line ~a") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) + (and (not (or (string=? line (string-trim-right line)) + (string=? line (string #\page)))) + (make-warning package + (G_ "trailing white space on line ~a") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) (define (report-long-line package line line-number) "Emit a warning if LINE is too long." ;; Note: We don't warn at 80 characters because sometimes hashes and URLs ;; make it hard to fit within that limit and we want to avoid making too ;; much noise. - (when (> (string-length line) 90) - (make-warning package - (G_ "line ~a is way too long (~a characters)") - (list line-number (string-length line)) - #:location - (location (package-file package) - line-number - 0)))) + (and (> (string-length line) 90) + (make-warning package + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) + #:location + (location (package-file package) + line-number + 0)))) (define %hanging-paren-rx (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) (define (report-lone-parentheses package line line-number) "Emit a warning if LINE contains hanging parentheses." - (when (regexp-exec %hanging-paren-rx line) - (make-warning package - (G_ "parentheses feel lonely, \ + (and (regexp-exec %hanging-paren-rx line) + (make-warning package + (G_ "parentheses feel lonely, \ move to the previous or next line") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) (define %formatting-reporters ;; List of procedures that report formatting issues. These are not separate @@ -1130,11 +1130,9 @@ them for PACKAGE." warnings (if (< line-number starting-line) '() - (filter - lint-warning? - (map (lambda (report) - (report package line line-number)) - reporters)))))))))))) + (filter-map (lambda (report) + (report package line line-number)) + reporters))))))))))) (define (check-formatting package) "Check the formatting of the source code of PACKAGE." -- cgit v1.2.3 From c3e59de9b1340f1a0ef7e30dd2e4e7bf7b484ee9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 23:31:28 +0200 Subject: guix system: Reinstalling the bootloader preserves extra menu entries. Fixes . Reported by Jesse Gibbons . Previously 'guix system delete-generations' or 'switch-generation' would lose the extra bootloader menu entries specified in the current system's configuration. This fixes that. * guix/scripts/system.scm (reinstall-bootloader): Turn PARAMS into a single . Adjust ENTRIES to include extra menu entries specified in PARAMS. --- guix/scripts/system.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9fc3a10e98..27b014db68 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -384,12 +384,14 @@ STORE is an open connection to the store." (bootloader bootloader))) ;; Make the specified system generation the default entry. - (params (profile-boot-parameters %system-profile (list number))) + (params (first (profile-boot-parameters %system-profile + (list number)))) (old-generations (delv number (reverse (generation-numbers %system-profile)))) (old-params (profile-boot-parameters %system-profile old-generations)) - (entries (map boot-parameters->menu-entry params)) + (entries (cons (boot-parameters->menu-entry params) + (boot-parameters-bootloader-menu-entries params))) (old-entries (map boot-parameters->menu-entry old-params))) (run-with-store store (mlet* %store-monad -- cgit v1.2.3 From 900e0fbcc4626bdf57e455836f86367e3ec36d69 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 31 Aug 2019 21:03:16 +0200 Subject: lint: Gracefully handle errors from 'connect' & co. * guix/lint.scm (call-with-networking-fail-safe): Add case for 'system-error' as typically raised by 'connect' & co. --- guix/lint.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 2bf5097403..254f4e2830 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -950,6 +950,16 @@ display a message including MESSAGE and return ERROR-VALUE." message (tls-certificate-error-string args)) error-value) + ((and ('system-error _ ...) args) + (let ((errno (system-error-errno args))) + (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED)) + (let ((details (call-with-output-string + (lambda (port) + (print-exception port #f (car args) + (cdr args)))))) + (warning (G_ "~a: ~a~%") message details) + error-value) + (apply throw args)))) (args (apply throw args)))))) -- cgit v1.2.3 From 2f43e5db1c36ec93a80ed1e3cbe763a8d64adcb5 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 2 Sep 2019 11:07:53 +0300 Subject: build/cargo-build-system: Use invoke. * guix/build/cargo-build-system.scm (crate-src?, build, check, install): Use 'invoke'. --- guix/build/cargo-build-system.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 06ed14b89f..f173b64c83 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -81,10 +81,10 @@ Cargo.toml file present at its root." ;; archive, but not nested anywhere else). We do this by cutting up ;; each output line and only looking at the second component. We then ;; check if it matches Cargo.toml exactly and short circuit if it does. - (zero? (apply system* (list "sh" "-c" - (string-append "tar -tf " path - " | cut -d/ -f2" - " | grep -q '^Cargo.toml$'")))))) + (apply invoke (list "sh" "-c" + (string-append "tar -tf " path + " | cut -d/ -f2" + " | grep -q '^Cargo.toml$'"))))) (define* (configure #:key inputs (vendor-dir "guix-vendor") @@ -157,7 +157,7 @@ directory = '" port) #:allow-other-keys) "Build a given Cargo package." (or skip-build? - (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))) + (apply invoke `("cargo" "build" ,@cargo-build-flags)))) (define* (check #:key tests? @@ -165,7 +165,7 @@ directory = '" port) #:allow-other-keys) "Run tests for a given Cargo package." (if tests? - (zero? (apply system* `("cargo" "test" ,@cargo-test-flags))) + (apply invoke `("cargo" "test" ,@cargo-test-flags)) #t)) (define (touch file-name) @@ -184,7 +184,7 @@ directory = '" port) ;; otherwise cargo will raise an error. (or skip-build? (not (has-executable-target?)) - (zero? (system* "cargo" "install" "--path" "." "--root" out))))) + (invoke "cargo" "install" "--path" "." "--root" out)))) (define %standard-phases (modify-phases gnu:%standard-phases -- cgit v1.2.3 From c7358ac4fc6369cdf87f95ec8600a21e809a22eb Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 2 Sep 2019 14:45:17 +0200 Subject: import: cran: Retry failed git imports on Bioconductor. * guix/import/cran.scm (cran->guix-package): Retry failed git imports on Bioconductor. --- guix/import/cran.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 51c7ea7b2f..b5321b44ef 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -494,12 +494,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file." "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." (let ((description (fetch-description repo package-name))) - (if (and (not description) - (eq? repo 'bioconductor)) - ;; Retry import from CRAN - (cran->guix-package package-name 'cran) - (and description - (description->package repo description))))))) + (if description + (description->package repo description) + (case repo + ((git) + ;; Retry import from Bioconductor + (cran->guix-package package-name 'bioconductor)) + ((bioconductor) + ;; Retry import from CRAN + (cran->guix-package package-name 'cran)) + (else #f))))))) (define* (cran-recursive-import package-name #:optional (repo 'cran)) (recursive-import package-name repo -- cgit v1.2.3 From 8786fec4859f36aeb2e6b5d136b4507088d2b5a1 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 2 Sep 2019 14:46:04 +0200 Subject: import: cran: Only use the git import with what looks like a URL. * guix/import/cran.scm (fetch-description): Abort if the argument does not look like a URL. --- guix/import/cran.scm | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index b5321b44ef..35caa3e463 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -230,16 +230,17 @@ from ~s: ~a (~s)~%" (if (boolean? type) meta (cons `(bioconductor-type . ,type) meta)))))))))) ((git) - ;; Download the git repository at "NAME" - (call-with-values - (lambda () (download name #t)) - (lambda (dir commit) - (and=> (description->alist (with-input-from-file - (string-append dir "/DESCRIPTION") read-string)) - (lambda (meta) - (cons* `(git . ,name) - `(git-commit . ,commit) - meta)))))))) + (and (string-prefix? "http" name) + ;; Download the git repository at "NAME" + (call-with-values + (lambda () (download name #t)) + (lambda (dir commit) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (cons* `(git . ,name) + `(git-commit . ,commit) + meta))))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated -- cgit v1.2.3 From 9323ab550f3bcb75fcaefbb20847595974702d5b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 Aug 2019 16:01:32 +0200 Subject: tests: 'with-http-server' accepts multiple responses. * guix/tests/http.scm (call-with-http-server): Replace 'code' and 'data' parameters with 'responses+data'. Compute RESPONSES as a function of that. Remove #:headers parameter. [http-write]: Quit only when RESPONSES is empty. [server-body]: Get the response and data from RESPONSES, and set it to point to the rest. (with-http-server): Adjust accordingly. * tests/derivations.scm ("'download' built-in builder") ("'download' built-in builder, invalid hash") ("'download' built-in builder, not found") ("'download' built-in builder, check mode"): Adjust to new 'with-http-server' interface. * tests/lint.scm ("home-page: 200") ("home-page: 200 but short length") ("home-page: 404", "home-page: 301, invalid"): ("home-page: 301 -> 200", "home-page: 301 -> 404") ("source: 200", "source: 200 but short length") ("source: 404", "source: 404 and 200") ("source: 301 -> 200", "source: 301 -> 404"): ("github-url", github-url): Likewise. * tests/swh.scm (with-json-result) ("lookup-origin, not found"): Likewise. --- guix/tests/http.scm | 39 ++++++++++++-------- tests/derivations.scm | 12 +++---- tests/lint.scm | 98 ++++++++++++++++++++++++++++++--------------------- tests/swh.scm | 5 +-- 4 files changed, 91 insertions(+), 63 deletions(-) (limited to 'guix') diff --git a/guix/tests/http.scm b/guix/tests/http.scm index a56d6f213d..05ce39bca2 100644 --- a/guix/tests/http.scm +++ b/guix/tests/http.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (web server http) #:use-module (web response) #:use-module (srfi srfi-39) + #:use-module (ice-9 match) #:export (with-http-server call-with-http-server %http-server-port @@ -69,10 +70,20 @@ needed." (string-append "http://localhost:" (number->string (%http-server-port)) "/foo/bar")) -(define* (call-with-http-server code data thunk - #:key (headers '())) - "Call THUNK with an HTTP server running and returning CODE and DATA (a -string) on HTTP requests." +(define* (call-with-http-server responses+data thunk) + "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP +requests. Each elements of RESPONSES+DATA must be a tuple containing a +response and a string, or an HTTP response code and a string." + (define responses + (map (match-lambda + (((? response? response) data) + (list response data)) + (((? integer? code) data) + (list (build-response #:code code + #:reason-phrase "Such is life") + data))) + responses+data)) + (define (http-write server client response body) "Write RESPONSE." (let* ((response (write-response response client)) @@ -82,7 +93,8 @@ string) on HTTP requests." (else (write-response-body response body))) (close-port port) - (quit #t) ;exit the server thread + (when (null? responses) + (quit #t)) ;exit the server thread (values))) ;; Mutex and condition variable to synchronize with the HTTP server. @@ -105,10 +117,10 @@ string) on HTTP requests." (define (server-body) (define (handle request body) - (values (build-response #:code code - #:reason-phrase "Such is life" - #:headers headers) - data)) + (match responses + (((response data) rest ...) + (set! responses rest) + (values response data)))) (let ((socket (open-http-server-socket))) (catch 'quit @@ -126,10 +138,7 @@ string) on HTTP requests." (define-syntax with-http-server (syntax-rules () - ((_ (code headers) data body ...) - (call-with-http-server code data (lambda () body ...) - #:headers headers)) - ((_ code data body ...) - (call-with-http-server code data (lambda () body ...))))) + ((_ responses+data body ...) + (call-with-http-server responses+data (lambda () body ...))))) ;;; http.scm ends here diff --git a/tests/derivations.scm b/tests/derivations.scm index db73d19b3a..00cedef32c 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -210,7 +210,7 @@ (test-skip 1)) (test-assert "'download' built-in builder" (let ((text (random-text))) - (with-http-server 200 text + (with-http-server `((200 ,text)) (let* ((drv (derivation %store "world" "builtin:download" '() #:env-vars `(("url" @@ -225,7 +225,7 @@ (unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, invalid hash" - (with-http-server 200 "hello, world!" + (with-http-server `((200 "hello, world!")) (let* ((drv (derivation %store "world" "builtin:download" '() #:env-vars `(("url" @@ -240,7 +240,7 @@ (unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, not found" - (with-http-server 404 "not found" + (with-http-server '((404 "not found")) (let* ((drv (derivation %store "will-never-be-found" "builtin:download" '() #:env-vars `(("url" @@ -275,9 +275,9 @@ . ,(object->string (%local-url)))) #:hash-algo 'sha256 #:hash (sha256 (string->utf8 text))))) - (and (with-http-server 200 text + (and (with-http-server `((200 ,text)) (build-derivations %store (list drv))) - (with-http-server 200 text + (with-http-server `((200 ,text)) (build-derivations %store (list drv) (build-mode check))) (string=? (call-with-input-file (derivation->output-path drv) @@ -1264,5 +1264,5 @@ (test-end) ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 2) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; End: diff --git a/tests/lint.scm b/tests/lint.scm index db6dd6dbe1..c8b88136f4 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -390,7 +390,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -399,7 +399,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200 but short length" "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" - (with-http-server 200 "This is too small." + (with-http-server `((200 "This is too small.")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -410,7 +410,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 404" "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -420,7 +420,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301, invalid" "invalid permanent redirect from http://localhost:9999/foo/bar" - (with-http-server 301 %long-string + (with-http-server `((301 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -430,12 +430,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301 -> 200" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -445,12 +447,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) + (with-http-server '((404 "booh!")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -583,7 +587,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -595,7 +599,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200 but short length" "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" - (with-http-server 200 "This is too small." + (with-http-server '((200 "This is too small.")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -610,7 +614,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 404" "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -625,10 +629,10 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 404 and 200" '() - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((bad-url (%local-url))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -642,11 +646,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 200" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -661,11 +668,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) + (with-http-server '((404 "booh!")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -697,7 +707,7 @@ (test-equal "github-url" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (check-github-url (dummy-package "x" (source (origin @@ -709,17 +719,25 @@ (test-equal "github-url: one suggestion" (string-append "URL should be '" github-url "'") - (with-http-server (301 `((location . ,(string->uri github-url)))) "" - (let ((initial-uri (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" - (single-lint-warning-message - (check-github-url - (dummy-package "x" (source - (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256))))))))))) + (let ((redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri github-url)))))) + (with-http-server `((,redirect "")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 302 + #:headers + `((location + . ,(string->uri initial-url)))))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server `((,redirect "")) + (single-lint-warning-message + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))))))))) (test-equal "github-url: already the correct github url" '() (check-github-url @@ -844,6 +862,6 @@ (test-end "lint") ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 2) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; eval: (put 'with-warnings 'scheme-indent-function 0) ;; End: diff --git a/tests/swh.scm b/tests/swh.scm index 07f0fda37b..9a0da07ae1 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -40,7 +40,7 @@ \"dir_id\": 2 } ]") (define-syntax-rule (with-json-result str exp ...) - (with-http-server 200 str + (with-http-server `((200 ,str)) (parameterize ((%swh-base-url (%local-url))) exp ...))) @@ -56,7 +56,7 @@ (test-equal "lookup-origin, not found" #f - (with-http-server 404 "Nope." + (with-http-server `((404 "Nope.")) (parameterize ((%swh-base-url (%local-url))) (lookup-origin "http://example.org/whatever")))) @@ -72,5 +72,6 @@ ;; Local Variables: ;; eval: (put 'with-json-result 'scheme-indent-function 1) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; End: -- cgit v1.2.3 From ba1c1853a79a5930ca7db7a6b368859f805df98d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 Aug 2019 15:59:16 +0200 Subject: swh: Add hooks for rate limiting handling. * guix/swh.scm (%allow-request?, %save-rate-limit-reset-time) (%general-rate-limit-reset-time): New variables. (request-rate-limit-reached?, update-rate-limit-reset-time!): New procedures. (call): Call '%allow-request?'. Change 'swh-error' protocol to pass METHOD in addition to URL. * tests/swh.scm ("rate limit reached") ("%allow-request? and request-rate-limit-reached?"): New tests. --- guix/swh.scm | 84 +++++++++++++++++++++++++++++++++++++++++++++-------------- tests/swh.scm | 36 +++++++++++++++++++++++++ 2 files changed, 100 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index c253e217da..42f38ee048 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -20,6 +20,7 @@ #:use-module (guix base16) #:use-module (guix build utils) #:use-module ((guix build syscalls) #:select (mkdtemp!)) + #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (json) @@ -32,6 +33,9 @@ #:use-module (ice-9 popen) #:use-module ((ice-9 ftw) #:select (scandir)) #:export (%swh-base-url + %allow-request? + + request-rate-limit-reached? origin? origin-id @@ -196,31 +200,71 @@ Software Heritage." ((? string? str) str) ((? null?) #f))) +(define %allow-request? + ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true + ;; to keep going. This can be used to disallow a requests when + ;; 'request-rate-limit-reached?' returns true, for instance. + (make-parameter (const #t))) + +;; The time when the rate limit for "/origin/save" POST requests and that of +;; other requests will be reset. +;; See . +(define %save-rate-limit-reset-time 0) +(define %general-rate-limit-reset-time 0) + +(define (request-rate-limit-reached? url method) + "Return true if the rate limit has been reached for URI." + (define uri + (string->uri url)) + + (define reset-time + (if (and (eq? method http-post) + (string-prefix? "/api/1/origin/save/" (uri-path uri))) + %save-rate-limit-reset-time + %general-rate-limit-reset-time)) + + (< (car (gettimeofday)) reset-time)) + +(define (update-rate-limit-reset-time! url method response) + "Update the rate limit reset time for URL and METHOD based on the headers in +RESPONSE." + (let ((uri (string->uri url))) + (match (assq-ref (response-headers response) 'x-ratelimit-reset) + ((= string->number (? number? reset)) + (if (and (eq? method http-post) + (string-prefix? "/api/1/origin/save/" (uri-path uri))) + (set! %save-rate-limit-reset-time reset) + (set! %general-rate-limit-reset-time reset))) + (_ + #f)))) + (define* (call url decode #:optional (method http-get) #:key (false-if-404? #t)) "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body using DECODE, a one-argument procedure that takes an input port. When FALSE-IF-404? is true, return #f upon 404 responses." - (let*-values (((response port) - (method url #:streaming? #t))) - ;; See . - (match (assq-ref (response-headers response) 'x-ratelimit-remaining) - (#f #t) - ((? (compose zero? string->number)) - (throw 'swh-error url response)) - (_ #t)) - - (cond ((= 200 (response-code response)) - (let ((result (decode port))) - (close-port port) - result)) - ((and false-if-404? - (= 404 (response-code response))) - (close-port port) - #f) - (else - (close-port port) - (throw 'swh-error url response))))) + (and ((%allow-request?) url method) + (let*-values (((response port) + (method url #:streaming? #t))) + ;; See . + (match (assq-ref (response-headers response) 'x-ratelimit-remaining) + (#f #t) + ((? (compose zero? string->number)) + (update-rate-limit-reset-time! url method response) + (throw 'swh-error url method response)) + (_ #t)) + + (cond ((= 200 (response-code response)) + (let ((result (decode port))) + (close-port port) + result)) + ((and false-if-404? + (= 404 (response-code response))) + (close-port port) + #f) + (else + (close-port port) + (throw 'swh-error url method response)))))) (define-syntax define-query (syntax-rules (path) diff --git a/tests/swh.scm b/tests/swh.scm index 9a0da07ae1..e36c54e5fb 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -19,6 +19,7 @@ (define-module (test-swh) #:use-module (guix swh) #:use-module (guix tests http) + #:use-module (web response) #:use-module (srfi srfi-64)) ;; Test the JSON mapping machinery used in (guix swh). @@ -68,6 +69,41 @@ (directory-entry-length entry))) (lookup-directory "123")))) +(test-equal "rate limit reached" + 3000000000 + (let ((too-many (build-response + #:code 429 + #:reason-phrase "Too many requests" + + ;; Pretend we've reached the limit and it'll be reset in + ;; June 2065. + #:headers '((x-ratelimit-remaining . "0") + (x-ratelimit-reset . "3000000000"))))) + (with-http-server `((,too-many "Too bad.")) + (parameterize ((%swh-base-url (%local-url))) + (catch 'swh-error + (lambda () + (lookup-origin "http://example.org/guix.git")) + (lambda (key url method response) + ;; Ensure the reset time was recorded. + (@@ (guix swh) %general-rate-limit-reset-time))))))) + +(test-assert "%allow-request? and request-rate-limit-reached?" + ;; Here we test two things: that the rate limit set above is in effect and + ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?' + ;; returns true. + (let* ((key (gensym "skip-request")) + (skip-if-limit-reached + (lambda (url method) + (or (not (request-rate-limit-reached? url method)) + (throw key #t))))) + (parameterize ((%allow-request? skip-if-limit-reached)) + (catch key + (lambda () + (lookup-origin "http://example.org/guix.git") + #f) + (const #t))))) + (test-end "swh") ;; Local Variables: -- cgit v1.2.3 From d370cc73193f42fb86f08237b4ebb612ef822ae7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 Aug 2019 16:02:29 +0200 Subject: swh: Make 'commit-id?' public. * guix/swh.scm (commit-id?): Make public. --- guix/swh.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 42f38ee048..01648a1ebe 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -105,6 +105,8 @@ request-cooking vault-fetch + commit-id? + swh-download)) ;;; Commentary: @@ -568,7 +570,7 @@ requested bundle cooking, waiting for completion...~%")) (define (commit-id? reference) "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if -it is a tag name." +it is a tag name. This is based on a simple heuristic so use with care!" (and (= (string-length reference) 40) (string-every char-set:hex-digit reference))) -- cgit v1.2.3 From 55549c7b9b778a79d3e1f3d085861ef36aabdca6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 30 Aug 2019 00:54:15 +0200 Subject: lint: Add 'archival' checker. * guix/lint.scm (check-archival): New procedure. (%network-dependent-checkers): Add 'archival' checker. * tests/lint.scm ("archival: missing content") ("archival: content available") ("archival: missing revision") ("archival: revision available") ("archival: rate limit reached"): New tests. * doc/guix.texi (Invoking guix lint): Document it. --- doc/guix.texi | 25 +++++++++++++++ guix/lint.scm | 96 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- tests/lint.scm | 81 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 201 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 0510f57c23..de02ad8687 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9249,6 +9249,31 @@ Parse the @code{source} URL to determine if a tarball from GitHub is autogenerated or if it is a release tarball. Unfortunately GitHub's autogenerated tarballs are sometimes regenerated. +@item archival +@cindex Software Heritage, source code archive +@cindex archival of source code, Software Heritage +Checks whether the package's source code is archived at +@uref{https://www.softwareheritage.org, Software Heritage}. + +When the source code that is not archived comes from a version-control system +(VCS)---e.g., it's obtained with @code{git-fetch}, send Software Heritage a +``save'' request so that it eventually archives it. This ensures that the +source will remain available in the long term, and that Guix can fall back to +Software Heritage should the source code disappear from its original host. +The status of recent ``save'' requests can be +@uref{https://archive.softwareheritage.org/save/#requests, viewed on-line}. + +When source code is a tarball obtained with @code{url-fetch}, simply print a +message when it is not archived. As of this writing, Software Heritage does +not allow requests to save arbitrary tarballs; we are working on ways to +ensure that non-VCS source code is also archived. + +Software Heritage +@uref{https://archive.softwareheritage.org/api/#rate-limiting, limits the +request rate per IP address}. When the limit is reached, @command{guix lint} +prints a message and the @code{archival} checker stops doing anything until +that limit has been reset. + @item cve @cindex security vulnerabilities @cindex CVE, Common Vulnerabilities and Exposures diff --git a/guix/lint.scm b/guix/lint.scm index 254f4e2830..ba38bef806 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -44,6 +44,8 @@ #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph)) #:use-module (guix gnu-maintenance) #:use-module (guix cve) + #:use-module ((guix swh) #:hide (origin?)) + #:autoload (guix git-download) (git-reference?) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) @@ -80,6 +82,7 @@ check-vulnerabilities check-for-updates check-formatting + check-archival lint-warning lint-warning? @@ -1033,6 +1036,93 @@ the NIST server non-fatal." '())) (#f '()))) ; cannot find newer upstream release + +(define (check-archival package) + "Check whether PACKAGE's source code is archived on Software Heritage. If +it's not, and if its source code is a VCS snapshot, then send a \"save\" +request to Software Heritage. + +Software Heritage imposes limits on the request rate per client IP address. +This checker prints a notice and stops doing anything once that limit has been +reached." + (define (response->warning url method response) + (if (request-rate-limit-reached? url method) + (list (make-warning package + (G_ "Software Heritage rate limit reached; \ +try again later") + #:field 'source)) + (list (make-warning package + (G_ "'~a' returned ~a") + (list url (response-code response)) + #:field 'source)))) + + (define skip-key (gensym "skip-archival-check")) + + (define (skip-when-limit-reached url method) + (or (not (request-rate-limit-reached? url method)) + (throw skip-key #t))) + + (parameterize ((%allow-request? skip-when-limit-reached)) + (catch #t + (lambda () + (match (and (origin? (package-source package)) + (package-source package)) + (#f ;no source + '()) + ((= origin-uri (? git-reference? reference)) + (define url + (git-reference-url reference)) + (define commit + (git-reference-commit reference)) + + (match (if (commit-id? commit) + (or (lookup-revision commit) + (lookup-origin-revision url commit)) + (lookup-origin-revision url commit)) + ((? revision? revision) + '()) + (#f + ;; Revision is missing from the archive, attempt to save it. + (catch 'swh-error + (lambda () + (save-origin (git-reference-url reference) "git") + (list (make-warning + package + ;; TRANSLATORS: "Software Heritage" is a proper noun + ;; that must remain untranslated. See + ;; . + (G_ "scheduled Software Heritage archival") + #:field 'source))) + (lambda (key url method response . _) + (cond ((= 429 (response-code response)) + (list (make-warning + package + (G_ "archival rate limit exceeded; \ +try again later") + #:field 'source))) + (else + (response->warning url method response)))))))) + ((? origin? origin) + ;; Since "save" origins are not supported for non-VCS source, all + ;; we can do is tell whether a given tarball is available or not. + (if (origin-sha256 origin) ;XXX: for ungoogled-chromium + (match (lookup-content (origin-sha256 origin) "sha256") + (#f + (list (make-warning package + (G_ "source not archived on Software \ +Heritage") + #:field 'source))) + ((? content?) + '())) + '())))) + (match-lambda* + ((key url method response) + (response->warning url method response)) + ((key . args) + (if (eq? key skip-key) + '() + (apply throw key args))))))) + ;;; ;;; Source code formatting. @@ -1237,7 +1327,11 @@ or a list thereof") (lint-checker (name 'refresh) (description "Check the package for new upstream releases") - (check check-for-updates)))) + (check check-for-updates)) + (lint-checker + (name 'archival) + (description "Ensure source code archival on Software Heritage") + (check check-archival)))) (define %all-checkers (append %local-checkers diff --git a/tests/lint.scm b/tests/lint.scm index c8b88136f4..1b92f02b85 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -35,6 +35,7 @@ #:use-module (guix packages) #:use-module (guix lint) #:use-module (guix ui) + #:use-module (guix swh) #:use-module (gnu packages) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) @@ -47,6 +48,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 getopt-long) #:use-module (ice-9 pretty-print) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) @@ -859,6 +861,85 @@ '() (check-formatting (dummy-package "x"))) +(test-assert "archival: missing content" + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + (warnings (with-http-server '((404 "Not archived.")) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" + (source origin))))))) + (warning-contains? "not archived" warnings))) + +(test-equal "archival: content available" + '() + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/content/ + (content "{ \"checksums\": {}, \"data_url\": \"xyz\", + \"length\": 42 }")) + (with-http-server `((200 ,content)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-assert "archival: missing revision" + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/origin/save/ + (save "{ \"origin_url\": \"http://example.org/foo.git\", + \"save_request_date\": \"2014-11-17T22:09:38+01:00\", + \"save_request_status\": \"accepted\", + \"save_task_status\": \"scheduled\" }") + (warnings (with-http-server `((404 "No revision.") ;lookup-revision + (404 "No origin.") ;lookup-origin + (200 ,save)) ;save-origin + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + (warning-contains? "scheduled" warnings))) + +(test-equal "archival: revision available" + '() + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/revision/ + (revision "{ \"author\": {}, \"parents\": [], + \"date\": \"2014-11-17T22:09:38+01:00\" }")) + (with-http-server `((200 ,revision)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-assert "archival: rate limit reached" + ;; We should get a single warning stating that the rate limit was reached, + ;; and nothing more, in particular no other HTTP requests. + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + (too-many (build-response + #:code 429 + #:reason-phrase "Too many requests" + #:headers '((x-ratelimit-remaining . "0") + (x-ratelimit-reset . "3000000000")))) + (warnings (with-http-server `((,too-many "Rate limit reached.")) + (parameterize ((%swh-base-url (%local-url))) + (append-map (lambda (name) + (check-archival + (dummy-package name (source origin)))) + '("x" "y" "z")))))) + (string-contains (single-lint-warning-message warnings) + "rate limit reached"))) + (test-end "lint") ;; Local Variables: -- cgit v1.2.3 From 91300526b7d9d775bd98a700ed3758420ef9eac6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Sep 2019 12:36:34 +0200 Subject: deploy: Add missing store options. * guix/scripts/deploy.scm (%default-options): Add missing options such as 'print-build-trace?', etc. --- guix/scripts/deploy.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 329de41143..cf571756fd 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -66,11 +66,15 @@ Perform the deployment specified by FILE.\n")) %standard-build-options)) (define %default-options - `((substitutes? . #t) - (build-hook? . #t) - (graft? . #t) + ;; Alist of default option values. + `((verbosity . 1) (debug . 0) - (verbosity . 1))) + (graft? . #t) + (substitutes? . #t) + (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t))) (define (load-source-file file) "Load FILE as a user module." -- cgit v1.2.3 From 76073d29e11c71d3678efd44db646852b5502e55 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Sep 2019 13:24:03 +0200 Subject: Add (guix json). * guix/swh.scm (define-json-reader, define-json-mapping): Move to... * guix/json.scm: ... here. New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/json.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ guix/swh.scm | 35 +-------------------------------- 3 files changed, 64 insertions(+), 34 deletions(-) create mode 100644 guix/json.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index fa6bf8fe80..7b96c9473c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -68,6 +68,7 @@ MODULES = \ guix/cpio.scm \ guix/deprecation.scm \ guix/docker.scm \ + guix/json.scm \ guix/records.scm \ guix/pki.scm \ guix/progress.scm \ diff --git a/guix/json.scm b/guix/json.scm new file mode 100644 index 0000000000..20f0bd8f13 --- /dev/null +++ b/guix/json.scm @@ -0,0 +1,62 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018, 2019 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 . + +(define-module (guix json) + #:use-module (json) + #:use-module (srfi srfi-9) + #:export (define-json-mapping)) + +;;; Commentary: +;;; +;;; Helpers to map JSON objects to SRFI-9 records. Taken from (guix swh). +;;; +;;; Code: + +(define-syntax-rule (define-json-reader json->record ctor spec ...) + "Define JSON->RECORD as a procedure that converts a JSON representation, +read from a port, string, or hash table, into a record created by CTOR and +following SPEC, a series of field specifications." + (define (json->record input) + (let ((table (cond ((port? input) + (json->scm input)) + ((string? input) + (json-string->scm input)) + ((or (null? input) (pair? input)) + input)))) + (let-syntax ((extract-field (syntax-rules () + ((_ table (field key json->value)) + (json->value (assoc-ref table key))) + ((_ table (field key)) + (assoc-ref table key)) + ((_ table (field)) + (assoc-ref table + (symbol->string 'field)))))) + (ctor (extract-field table spec) ...))))) + +(define-syntax-rule (define-json-mapping rtd ctor pred json->record + (field getter spec ...) ...) + "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9, +and define JSON->RECORD as a conversion from JSON to a record of this type." + (begin + (define-record-type rtd + (ctor field ...) + pred + (field getter) ...) + + (define-json-reader json->record ctor + (field spec ...) ...))) diff --git a/guix/swh.scm b/guix/swh.scm index 01648a1ebe..7acad05928 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -21,6 +21,7 @@ #:use-module (guix build utils) #:use-module ((guix build syscalls) #:select (mkdtemp!)) #:use-module (web uri) + #:use-module (guix json) #:use-module (web client) #:use-module (web response) #:use-module (json) @@ -135,40 +136,6 @@ url (string-append url "/"))) -(define-syntax-rule (define-json-reader json->record ctor spec ...) - "Define JSON->RECORD as a procedure that converts a JSON representation, -read from a port, string, or hash table, into a record created by CTOR and -following SPEC, a series of field specifications." - (define (json->record input) - (let ((table (cond ((port? input) - (json->scm input)) - ((string? input) - (json-string->scm input)) - ((or (null? input) (pair? input)) - input)))) - (let-syntax ((extract-field (syntax-rules () - ((_ table (field key json->value)) - (json->value (assoc-ref table key))) - ((_ table (field key)) - (assoc-ref table key)) - ((_ table (field)) - (assoc-ref table - (symbol->string 'field)))))) - (ctor (extract-field table spec) ...))))) - -(define-syntax-rule (define-json-mapping rtd ctor pred json->record - (field getter spec ...) ...) - "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9, -and define JSON->RECORD as a conversion from JSON to a record of this type." - (begin - (define-record-type rtd - (ctor field ...) - pred - (field getter) ...) - - (define-json-reader json->record ctor - (field spec ...) ...))) - (define %date-regexp ;; Match strings like "2014-11-17T22:09:38+01:00" or ;; "2018-09-30T23:20:07.815449+00:00"". -- cgit v1.2.3 From a85a74ce6c9ff36ccd6ef50216ba8515723f3a62 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Sep 2019 14:58:40 +0200 Subject: ci: Use (guix json) and adjust for Guile-JSON 3.x. This is in part a followup to 81c3dc32244a17241d74eea9fa265edfcb326f6d. * guix/ci.scm (, , ): Define using 'define-json-mapping'. (json->build, json->checkout, json->evaluation): Remove. (queued-builds, latest-builds, latest-evaluations): Pass JSON arrays through 'vector->list' to adjust for Guile-JSON 3.x. (evaluations-for-commit): Fix typo to really export. --- guix/ci.scm | 68 ++++++++++++++++++++++++------------------------------------- 1 file changed, 27 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/guix/ci.scm b/guix/ci.scm index 1727297dd7..9e21996023 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,9 +18,10 @@ (define-module (guix ci) #:use-module (guix http-client) - #:autoload (json parser) (json->scm) + #:use-module (guix json) + #:use-module (json) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) + #:use-module (ice-9 match) #:export (build? build-id build-derivation @@ -42,7 +43,7 @@ queued-builds latest-builds latest-evaluations - evaluation-for-commit)) + evaluations-for-commit)) ;;; Commentary: ;;; @@ -51,28 +52,31 @@ ;;; ;;; Code: -(define-record-type - (make-build id derivation system status timestamp) - build? - (id build-id) ;integer +(define-json-mapping make-build build? + json->build + (id build-id "id") ;integer (derivation build-derivation) ;string | #f (system build-system) ;string - (status build-status) ;integer + (status build-status "buildstatus" ) ;integer (timestamp build-timestamp)) ;integer -(define-record-type - (make-checkout commit input) - checkout? +(define-json-mapping make-checkout checkout? + json->checkout (commit checkout-commit) ;string (SHA1) (input checkout-input)) ;string (name) -(define-record-type - (make-evaluation id spec complete? checkouts) - evaluation? +(define-json-mapping make-evaluation evaluation? + json->evaluation (id evaluation-id) ;integer (spec evaluation-spec) ;string - (complete? evaluation-complete?) ;Boolean - (checkouts evaluation-checkouts)) ;* + (complete? evaluation-complete? "in-progress" + (match-lambda + (0 #t) + (_ #f))) ;Boolean + (checkouts evaluation-checkouts "checkouts" ;* + (lambda (checkouts) + (map json->checkout + (vector->list checkouts))))) (define %query-limit ;; Max number of builds requested in queries. @@ -84,18 +88,11 @@ (close-port port) json)) -(define (json->build json) - (make-build (hash-ref json "id") - (hash-ref json "derivation") - (hash-ref json "system") - (hash-ref json "buildstatus") - (hash-ref json "timestamp"))) - (define* (queued-builds url #:optional (limit %query-limit)) "Return the list of queued derivations on URL." (let ((queue (json-fetch (string-append url "/api/queue?nr=" (number->string limit))))) - (map json->build queue))) + (map json->build (vector->list queue)))) (define* (latest-builds url #:optional (limit %query-limit) #:key evaluation system) @@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM." (option "system" system))))) ;; Note: Hydra does not provide a "derivation" field for entries in ;; 'latestbuilds', but Cuirass does. - (map json->build latest))) - -(define (json->checkout json) - (make-checkout (hash-ref json "commit") - (hash-ref json "input"))) - -(define (json->evaluation json) - (make-evaluation (hash-ref json "id") - (hash-ref json "specification") - (case (hash-ref json "in-progress") - ((0) #t) - (else #f)) - (map json->checkout (hash-ref json "checkouts")))) + (map json->build (vector->list latest)))) (define* (latest-evaluations url #:optional (limit %query-limit)) "Return the latest evaluations performed by the CI server at URL." (map json->evaluation - (json->scm - (http-fetch (string-append url "/api/evaluations?nr=" - (number->string limit)))))) + (vector->list + (json->scm + (http-fetch (string-append url "/api/evaluations?nr=" + (number->string limit))))))) (define* (evaluations-for-commit url commit #:optional (limit %query-limit)) -- cgit v1.2.3 From 2791870d09afd247a011bc8cb6cf88661729bd98 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Sep 2019 16:20:36 +0200 Subject: import: crate: Separate crates.io API from actual conversion. This provides a clean separation between bindings to the https://crates.io/api/v1 API and actual conversion to Guix package sexps. As a side-effect, it fixes things like "guix import blake2-rfc", "guix refresh -t crates", etc. * guix/import/crate.scm (, , ): New record types. (lookup-crate, crate-version-dependencies): New procedures. (crate-fetch): Remove. (crate->guix-package): Rewrite to use the new API. (latest-release): Likewise. * guix/build-system/cargo.scm (%crate-base-url): New variable. * tests/crate.scm (test-crate): Update accordingly. fixlet --- guix/build-system/cargo.scm | 11 +++- guix/import/crate.scm | 153 ++++++++++++++++++++++++++++++++------------ tests/crate.scm | 13 +++- 3 files changed, 131 insertions(+), 46 deletions(-) (limited to 'guix') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 10a1bac844..1e8b3a578e 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2016 David Craven @@ -35,12 +35,17 @@ #:export (%cargo-build-system-modules %cargo-utils-modules cargo-build-system + %crate-base-url crate-url crate-url? crate-uri)) -(define crate-url "https://crates.io/api/v1/crates/") -(define crate-url? (cut string-prefix? crate-url <>)) +(define %crate-base-url + (make-parameter "https://crates.io")) +(define crate-url + (string-append (%crate-base-url) "/api/v1/crates/")) +(define crate-url? + (cut string-prefix? crate-url <>)) (define (crate-uri name version) "Return a URI string for the crate package hosted at crates.io corresponding diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 52c5cb1c30..b674323177 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven +;;; Copyright © 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ #:use-module ((guix download) #:prefix download:) #:use-module (gcrypt hash) #:use-module (guix http-client) + #:use-module (guix json) #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) @@ -30,7 +32,6 @@ #:use-module (guix upstream) #:use-module (guix utils) #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) ; recursive #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -39,46 +40,82 @@ guix-package->crate-name %crate-updater)) -(define (crate-fetch crate-name callback) - "Fetch the metadata for CRATE-NAME from crates.io and call the callback." + +;;; +;;; Interface to https://crates.io/api/v1. +;;; - (define (crates->inputs crates) - (sort (map (cut assoc-ref <> "crate_id") crates) string-ci below. +(define-json-mapping make-crate crate? + json->crate + (name crate-name) ;string + (latest-version crate-latest-version "max_version") ;string + (home-page crate-home-page "homepage") ;string | #nil + (repository crate-repository) ;string + (description crate-description) ;string + (keywords crate-keywords ;list of strings + "keywords" vector->list) + (categories crate-categories ;list of strings + "categories" vector->list) + (versions crate-versions "actual_versions" ;list of + (lambda (vector) + (map json->crate-version + (vector->list vector)))) + (links crate-links)) ;alist - (define (string->license string) - (map spdx-string->license (string-split string #\/))) +;; Crate version. +(define-json-mapping make-crate-version crate-version? + json->crate-version + (id crate-version-id) ;integer + (number crate-version-number "num") ;string + (download-path crate-version-download-path "dl_path") ;string + (readme-path crate-version-readme-path "readme_path") ;string + (license crate-version-license "license") ;string + (links crate-version-links)) ;alist + +;; Crate dependency. Each dependency (each edge in the graph) is annotated as +;; being a "normal" dependency or a development dependency. There also +;; information about the minimum required version, such as "^0.0.41". +(define-json-mapping make-crate-dependency + crate-dependency? + json->crate-dependency + (id crate-dependency-id "crate_id") ;string + (kind crate-dependency-kind "kind" ;'normal | 'dev + string->symbol) + (requirement crate-dependency-requirement "req")) ;string + +(define (lookup-crate name) + "Look up NAME on https://crates.io and return the corresopnding +record or #f if it was not found." + (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/" + name)))) + (and=> (and json (assoc-ref json "crate")) + (lambda (alist) + ;; The "versions" field of ALIST is simply a list of version IDs + ;; (integers). Here, we squeeze in the actual version + ;; dictionaries that are not part of ALIST but are just more + ;; convenient handled this way. + (let ((versions (or (assoc-ref json "versions") '#()))) + (json->crate `(,@alist + ("actual_versions" . ,versions)))))))) + +(define (crate-version-dependencies version) + "Return the list of records of VERSION, a +." + (let* ((path (assoc-ref (crate-version-links version) "dependencies")) + (url (string-append (%crate-base-url) path))) + (match (assoc-ref (or (json-fetch url) '()) "dependencies") + ((? vector? vector) + (map json->crate-dependency (vector->list vector))) + (_ + '())))) - (define (crate-kind-predicate kind) - (lambda (dep) (string=? (assoc-ref dep "kind") kind))) - - (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) - (crate (assoc-ref crate-json "crate")) - (name (assoc-ref crate "name")) - (version (assoc-ref crate "max_version")) - (homepage (assoc-ref crate "homepage")) - (repository (assoc-ref crate "repository")) - (synopsis (assoc-ref crate "description")) - (description (assoc-ref crate "description")) - (license (or (and=> (assoc-ref crate "license") - string->license) - '())) ;missing license info - (path (string-append "/" version "/dependencies")) - (deps-json (json-fetch (string-append crate-url name path))) - (deps (vector->list (assoc-ref deps-json "dependencies"))) - (dep-crates (filter (crate-kind-predicate "normal") deps)) - (dev-dep-crates - (filter (lambda (dep) - (not ((crate-kind-predicate "normal") dep))) deps)) - (cargo-inputs (crates->inputs dep-crates)) - (cargo-development-inputs (crates->inputs dev-dep-crates)) - (home-page (match homepage - (() repository) - (_ homepage)))) - (callback #:name name #:version version - #:cargo-inputs cargo-inputs - #:cargo-development-inputs cargo-development-inputs - #:home-page home-page #:synopsis synopsis - #:description description #:license license))) + +;;; +;;; Converting crates to Guix packages. +;;; (define (maybe-cargo-inputs package-names) (match (package-names->package-inputs package-names) @@ -141,7 +178,38 @@ and LICENSE." (define (crate->guix-package crate-name) "Fetch the metadata for CRATE-NAME from crates.io, and return the `package' s-expression corresponding to that package, or #f on failure." - (crate-fetch crate-name make-crate-sexp)) + (define (string->license string) + (map spdx-string->license (string-split string #\/))) + + (define (normal-dependency? dependency) + (eq? (crate-dependency-kind dependency) 'normal)) + + (define crate + (lookup-crate crate-name)) + + (and crate + (let* ((version (find (lambda (version) + (string=? (crate-version-number version) + (crate-latest-version crate))) + (crate-versions crate))) + (dependencies (crate-version-dependencies version)) + (dep-crates (filter normal-dependency? dependencies)) + (dev-dep-crates (remove normal-dependency? dependencies)) + (cargo-inputs (sort (map crate-dependency-id dep-crates) + string-ci (crate-version-license version) + string->license))))) (define (guix-package->crate-name package) "Return the crate name of PACKAGE." @@ -157,6 +225,7 @@ and LICENSE." (define (crate-name->package-name name) (string-append "rust-" (string-join (string-split name #\_) "-"))) + ;;; ;;; Updater ;;; @@ -175,9 +244,9 @@ and LICENSE." (define (latest-release package) "Return an for the latest release of PACKAGE." (let* ((crate-name (guix-package->crate-name package)) - (callback (lambda* (#:key version #:allow-other-keys) version)) - (version (crate-fetch crate-name callback)) - (url (crate-uri crate-name version))) + (crate (lookup-crate crate-name)) + (version (crate-latest-version crate)) + (url (crate-uri crate-name version))) (upstream-source (package (package-name package)) (version version) diff --git a/tests/crate.scm b/tests/crate.scm index 72c3a13350..8a232ba06c 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2016 David Craven +;;; Copyright © 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,10 +33,20 @@ \"crate\": { \"max_version\": \"1.0.0\", \"name\": \"foo\", - \"license\": \"MIT/Apache-2.0\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", + \"keywords\": [\"dummy\" \"test\"], + \"categories\": [\"test\"] + \"actual_versions\": [ + { \"id\": \"foo\", + \"num\": \"1.0.0\", + \"license\": \"MIT/Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" + } + } + ] } }") -- cgit v1.2.3 From 191668bc9759dc87a27b5f4d55d214cc655f197f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 Sep 2019 16:32:11 +0200 Subject: import: crate: Correct interpretation of dual-licensing strings. * guix/import/crate.scm (%dual-license-rx): New variable. (crate->guix-package)[string->license]: Rewrite to match it. * tests/crate.scm (test-crate): Adjust "license" field to current practice. --- guix/import/crate.scm | 11 ++++++++++- tests/crate.scm | 2 +- 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index b674323177..f6057dbf8b 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -32,6 +32,7 @@ #:use-module (guix upstream) #:use-module (guix utils) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -175,11 +176,19 @@ and LICENSE." (close-port port) pkg)) +(define %dual-license-rx + ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0". + ;; This regexp matches that. + (make-regexp "^(.*) OR (.*)$")) + (define (crate->guix-package crate-name) "Fetch the metadata for CRATE-NAME from crates.io, and return the `package' s-expression corresponding to that package, or #f on failure." (define (string->license string) - (map spdx-string->license (string-split string #\/))) + (match (regexp-exec %dual-license-rx string) + (#f (list (spdx-string->license string))) + (m (list (spdx-string->license (match:substring m 1)) + (spdx-string->license (match:substring m 2)))))) (define (normal-dependency? dependency) (eq? (crate-dependency-kind dependency) 'normal)) diff --git a/tests/crate.scm b/tests/crate.scm index 8a232ba06c..c14862ad9f 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -41,7 +41,7 @@ \"actual_versions\": [ { \"id\": \"foo\", \"num\": \"1.0.0\", - \"license\": \"MIT/Apache-2.0\", + \"license\": \"MIT OR Apache-2.0\", \"links\": { \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" } -- cgit v1.2.3 From a44a535ebecd40c52514623a44d31d927ecca9da Mon Sep 17 00:00:00 2001 From: nixo Date: Mon, 29 Jul 2019 18:45:26 +0200 Subject: build: Add julia-build-system. * guix/build/julia-build-system.scm: New file. * guix/build-system/julia.scm: New file. * Makefile.am (MODULES): Add them. * doc/guix.texi (Build Systems): Document julia-build-system. Signed-off-by: Julien Lepiller --- Makefile.am | 2 + doc/guix.texi | 23 +++++++ guix/build-system/julia.scm | 132 +++++++++++++++++++++++++++++++++++++ guix/build/julia-build-system.scm | 135 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 292 insertions(+) create mode 100644 guix/build-system/julia.scm create mode 100644 guix/build/julia-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 7b96c9473c..796e96f099 100644 --- a/Makefile.am +++ b/Makefile.am @@ -126,6 +126,7 @@ MODULES = \ guix/build-system/gnu.scm \ guix/build-system/guile.scm \ guix/build-system/haskell.scm \ + guix/build-system/julia.scm \ guix/build-system/linux-module.scm \ guix/build-system/node.scm \ guix/build-system/perl.scm \ @@ -184,6 +185,7 @@ MODULES = \ guix/build/texlive-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ + guix/build/julia-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ guix/build/json.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index a078822871..6d6a09b36b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6034,6 +6034,29 @@ Packages built with @code{guile-build-system} must provide a Guile package in their @code{native-inputs} field. @end defvr +@defvr {Scheme Variable} julia-build-system +This variable is exported by @code{(guix build-system julia)}. It implements +the build procedure used by @uref{https://julialang.org/, julia} packages, +which essentially is similar to running @command{julia -e 'using Pkg; +Pkg.add(package)'} in an environment where @code{JULIA_LOAD_PATH} contains the +paths to all Julia package inputs. Tests are run not run. + +Julia packages require the source @code{file-name} to be the real name of the +package, correctly capitalized. + +For packages requiring shared library dependencies, you may need to write the +@file{/deps/deps.jl} file manually. It's usually a line of @code{const +variable = /gnu/store/libary.so} for each dependency, plus a void function +@code{check_deps() = nothing}. + +Some older packages that aren't using @file{Package.toml} yet, will require +this file to be created, too. The function @code{julia-create-package-toml} +helps creating the file. You need to pass the outputs and the source of the +package, it's name (the same as the @code{file-name} parameter), the package +uuid, the package version, and a list of dependencies specified by their name +and their uuid. +@end defvr + @defvr {Scheme Variable} minify-build-system This variable is exported by @code{(guix build-system minify)}. It implements a minification procedure for simple JavaScript packages. diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm new file mode 100644 index 0000000000..50237905ec --- /dev/null +++ b/guix/build-system/julia.scm @@ -0,0 +1,132 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Nicolò Balzarotti +;;; +;;; 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 . + +(define-module (guix build-system julia) + #:use-module ((guix build julia-build-system)) + #:use-module (gnu packages julia) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (%julia-build-system-modules + julia-build + julia-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Julia packages. +;; +;; Code: + +(define %julia-build-system-modules + ;; Build-side modules imported by default. + `((guix build julia-build-system) + ,@%gnu-build-system-modules)) + +(define (default-julia) + "Return the default Julia package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((julia-mod (resolve-interface '(gnu packages julia)))) + (module-ref julia-mod 'julia))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (julia julia) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:julia #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("julia" ,julia) + ,@native-inputs)) + (outputs outputs) + (build julia-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (julia-build store name inputs + #:key source + (tests? #f) + (phases '(@ (guix build julia-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %julia-build-system-modules) + (modules '((guix build julia-build-system) + (guix build utils)))) + "Build SOURCE using Julia, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (julia-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define julia-build-system + (build-system + (name 'julia) + (description "The build system for Julia packages") + (lower lower))) + +;;; julia.scm ends here diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm new file mode 100644 index 0000000000..ff6fcf5fe3 --- /dev/null +++ b/guix/build/julia-build-system.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Nicolò Balzarotti +;;; +;;; 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 . + + +(define-module (guix build julia-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:export (%standard-phases + julia-create-package-toml + julia-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Julia packages. +;; +;; Code: + +(define (invoke-julia code) + (invoke "julia" "-e" code)) + +;; subpath where we store the package content +(define %package-path "/share/julia/packages/") + +(define (generate-load-path inputs outputs) + (string-append + (string-join (map (match-lambda + ((_ . path) + (string-append path %package-path))) + ;; Restrict to inputs beginning with "julia-". + (filter (match-lambda + ((name . _) + (string-prefix? "julia-" name))) + inputs)) + ":") + (string-append ":" (assoc-ref outputs "out") %package-path) + ;; stdlib is always required to find Julia's standard libraries. + ;; usually there are other two paths in this variable: + ;; "@" and "@v#.#" + ":@stdlib")) + +(define* (install #:key source inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (package-dir (string-append out %package-path + (string-append + (strip-store-file-name source))))) + (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + (mkdir-p package-dir) + (copy-recursively source package-dir)) + #t) + +;; TODO: Precompilation is working, but I don't know how to tell +;; julia to use use it. If (on rantime) we set HOME to +;; store path, julia tries to write files there (failing) +(define* (precompile #:key source inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (builddir (string-append out "/share/julia/")) + (package (strip-store-file-name source))) + (mkdir-p builddir) + (setenv "JULIA_DEPOT_PATH" builddir) + (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + ;; Actual precompilation + (invoke-julia (string-append "using " package))) + #t) + +(define* (check #:key source inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (package (strip-store-file-name source)) + (builddir (string-append out "/share/julia/"))) + (setenv "JULIA_DEPOT_PATH" builddir) + (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs)) + (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")"))) + #t) + +(define (julia-create-package-toml outputs source + name uuid version + deps) + "Some packages are not using the new Package.toml dependency specifications. +Write this file manually, so that Julia can find its dependencies." + (let ((f (open-file + (string-append + (assoc-ref outputs "out") + %package-path + (string-append + name "/Project.toml")) + "w"))) + (display (string-append + " +name = \"" name "\" +uuid = \"" uuid "\" +version = \"" version "\" +") f) + (when (not (null? deps)) + (display "[deps]\n" f) + (for-each (lambda dep + (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n") + f)) + deps)) + (close-port f)) + #t) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'check) ; tests must be run after installation + (replace 'install install) + (add-after 'install 'precompile precompile) + ;; (add-after 'install 'check check) + ;; TODO: In the future we could add a "system-image-generation" phase + ;; where we use PackageCompiler.jl to speed up package loading times + (delete 'configure) + (delete 'bootstrap) + (delete 'patch-usr-bin-file) + (delete 'build))) + +(define* (julia-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Julia package, applying all of PHASES in order." + (apply gnu:gnu-build + #:inputs inputs #:phases phases + args)) -- cgit v1.2.3 From d3366a8ee8cec53cfb982855aaeb30244d3f1aa2 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 4 Sep 2019 21:01:04 +0200 Subject: import: opam: Remove initial "v" in some version numbers. * guix/import/opam.scm (opam-fetch): Remove initial "v" in some version numbers. --- guix/import/opam.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 5dcc0e97a3..7c533a4b4e 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -238,7 +238,9 @@ path to the repository." (version (find-latest-version name repository)) (file (string-append repository "/packages/" name "/" name "." version "/opam"))) `(("metadata" ,@(get-metadata file)) - ("version" . ,version)))) + ("version" . ,(if (string-prefix? "v" version) + (substring version 1) + version))))) (define (opam->guix-package name) (and-let* ((opam-file (opam-fetch name)) -- cgit v1.2.3 From b2f810fe939ca98ee578a55d42f8d939539ae845 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 4 Sep 2019 22:36:33 +0200 Subject: import: opam: Use propagated-inputs instead of inputs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/opam.scm (opam->guix-package): Use propagated-inputs instead of inputs. --- guix/import/opam.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 7c533a4b4e..7f089a5cf3 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -285,7 +285,7 @@ path to the repository." 'ocaml-build-system)) ,@(if (null? inputs) '() - `((inputs ,(list 'quasiquote inputs)))) + `((propagated-inputs ,(list 'quasiquote inputs)))) ,@(if (null? native-inputs) '() `((native-inputs ,(list 'quasiquote native-inputs)))) -- cgit v1.2.3 From 458b07ebe0243d13e8485ca1d7eb185cec35b7bb Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 4 Sep 2019 23:56:24 +0200 Subject: build-system/julia: Fix syntax error. * guix/build-system/julia.scm: Fix invalid module reference. --- guix/build-system/julia.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 50237905ec..9c8b8ad398 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build-system julia) - #:use-module ((guix build julia-build-system)) + #:use-module (guix build julia-build-system) #:use-module (gnu packages julia) #:use-module (guix store) #:use-module (guix utils) -- cgit v1.2.3 From 56b1977a5d1080fc9d331b3589ca80e0676d0e67 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Thu, 5 Sep 2019 00:20:41 +0200 Subject: build-system/julia: Avoid module cycles. * guix/build-system/julia.scm: Remove unused imports. (lower)[julia]: Default to (DEFAULT-JULIA). --- guix/build-system/julia.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 9c8b8ad398..488fe9bb1d 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -17,8 +17,6 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build-system julia) - #:use-module (guix build julia-build-system) - #:use-module (gnu packages julia) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) @@ -51,7 +49,7 @@ (define* (lower name #:key source inputs native-inputs outputs system target - (julia julia) + (julia (default-julia)) #:allow-other-keys #:rest arguments) "Return a bag for NAME." -- cgit v1.2.3 From 01e38cc4264d9d0076ce9d894796ceff1f08b35a Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Mon, 2 Sep 2019 15:47:42 +0200 Subject: build-system/asdf: Add option to compress programs. * guix/build/lisp-utils.scm (build-program): Add `compress?' key argument. (generate-executable-for-system): Same. (generate-executable): Same. --- guix/build/lisp-utils.scm | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 97bc6197a3..c7a589c902 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -220,12 +220,19 @@ Also load TEST-ASD-FILE if necessary." "Return a lisp keyword for the concatenation of STRINGS." (string->symbol (apply string-append ":" strings))) -(define (generate-executable-for-system type system) +(define* (generate-executable-for-system type system #:key compress?) "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or 'asdf:program-op. The latter will always be standalone. Depends on having created a \"SYSTEM-exec\" system which contains the entry program." (lisp-eval-program `((require :asdf) + ;; Only SBCL supports compression as of 2019-09-02. + ,(if (and compress? (string=? (%lisp-type) "sbcl")) + '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) + (uiop:dump-image (asdf:output-file o c) + :executable t + :compression t)) + '()) (asdf:operate ',type ,(string-append system "-exec"))))) (define (generate-executable-wrapper-system system dependencies) @@ -339,6 +346,7 @@ which are not nested." (dependency-prefixes (list (library-output outputs))) (dependencies (list (basename program))) entry-program + compress? #:allow-other-keys) "Generate an executable program containing all DEPENDENCIES, and which will execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it @@ -350,6 +358,7 @@ retained." #:dependencies dependencies #:dependency-prefixes dependency-prefixes #:entry-program entry-program + #:compress? compress? #:type 'asdf:program-op) (let* ((name (basename program)) (bin-directory (dirname program))) @@ -382,6 +391,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained." dependency-prefixes entry-program type + compress? #:allow-other-keys) "Generate an executable by using asdf operation TYPE, containing whithin the image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an @@ -405,7 +415,7 @@ references to those libraries are retained." `(((,bin-directory :**/ :*.*.*) (,bin-directory :**/ :*.*.*))))))) - (generate-executable-for-system type name) + (generate-executable-for-system type name #:compress? compress?) (let* ((after-store-prefix-index (string-index out-file #\/ -- cgit v1.2.3 From 67c2db17bc29e483dbaffbee246c910a617744c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 5 Sep 2019 17:05:08 +0200 Subject: download: Pass 'http_proxy' et al. to git, hg, etc. This allows 'git-fetch' etc. origins to honor the proxy and locale of the daemon. * guix/bzr-download.scm (bzr-fetch): Pass #:leaked-env-vars to 'gexp->derivation'. * guix/cvs-download.scm (cvs-fetch): Likewise. * guix/git-download.scm (git-fetch): Likewise. * guix/hg-download.scm (hg-fetch): Likewise. * guix/svn-download.scm (svn-multi-fetch): Likewise. --- guix/bzr-download.scm | 3 +++ guix/cvs-download.scm | 5 ++++- guix/git-download.scm | 3 +++ guix/hg-download.scm | 5 ++++- guix/svn-download.scm | 5 ++++- 5 files changed, 18 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm index d30833c5d7..010e0decff 100644 --- a/guix/bzr-download.scm +++ b/guix/bzr-download.scm @@ -75,6 +75,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #:env-vars `(("bzr url" . ,(bzr-reference-url ref)) ("bzr reference" . ,(bzr-reference-revision ref))) + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") #:system system #:local-build? #t ;don't offload repo branching #:hash-algo hash-algo diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index 8b46f8ef8c..cb42103aae 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2015 Mark H Weaver ;;; @@ -92,6 +92,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") #:system system #:hash-algo hash-algo #:hash hash diff --git a/guix/git-download.scm b/guix/git-download.scm index c62bb8ad0f..1eae035fc4 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -157,6 +157,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ("git commit" . ,(git-reference-commit ref)) ("git recursive?" . ,(object->string (git-reference-recursive? ref)))) + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") #:system system #:local-build? #t ;don't offload repo cloning diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 6b25b87b6b..4cdc1a780a 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -92,6 +92,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") #:system system #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 5c25437059..4139cbc2e2 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2017, 2019 Ricardo Wurmus ;;; @@ -131,6 +131,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") #:system system #:hash-algo hash-algo #:hash hash -- cgit v1.2.3 From bc60349b5bc58a0b803df5adce1de6db82453744 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 Sep 2019 14:41:58 +0200 Subject: packages: 'supported-package?' binds '%current-system' for graph traversal. Previously, (supported-package? coreutils "armhf-linux") with (%current-system) = "x86_64-linux" would return false. That's because 'supported-package?' would traverse the x86_64 dependency graph, which contains 'tcc-boot0', which supports x86 only. Consequently, 'supported-package?' would match only 53 packages for "armhf-linux" when running on x86, as is the case during continuous integration. * guix/packages.scm (package-transitive-supported-systems): Add an optional 'system' parameter. Use 'mlambda' instead of 'mlambdaq' for memoization. (supported-package?): Pass 'system' to 'package-transitive-supported-systems'. * tests/packages.scm ("package-transitive-supported-systems, implicit inputs") ("package-transitive-supported-systems: reduced binary seed, implicit inputs"): Remove calls to 'invalidate-memoization!', which no longer work and were presumably introduced to work around the bug we're fixing (see commit 0db65c168fd6dec57a357735fe130c80feba5460). * tests/packages.scm ("supported-package?"): Rewrite test to use only existing system name since otherwise 'bootstrap-executable' raises an exception. ("supported-package? vs. system-dependent graph"): New test. --- guix/packages.scm | 30 ++++++++++++++++++------------ tests/packages.scm | 36 +++++++++++++++++++++++++++++------- 2 files changed, 47 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index d9eeee15a2..39ab28d807 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -767,23 +767,29 @@ in INPUTS and their transitive propagated inputs." (transitive-inputs inputs))) (define package-transitive-supported-systems - (mlambdaq (package) - "Return the intersection of the systems supported by PACKAGE and those + (let () + (define supported-systems + (mlambda (package system) + (parameterize ((%current-system system)) + (fold (lambda (input systems) + (match input + ((label (? package? package) . _) + (lset-intersection string=? systems + (supported-systems package system))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package)))))) + + (lambda* (package #:optional (system (%current-system))) + "Return the intersection of the systems supported by PACKAGE and those supported by its dependencies." - (fold (lambda (input systems) - (match input - ((label (? package? p) . _) - (lset-intersection - string=? systems (package-transitive-supported-systems p))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package))))) + (supported-systems package system)))) (define* (supported-package? package #:optional (system (%current-system))) "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its dependencies are known to build on SYSTEM." - (member system (package-transitive-supported-systems package))) + (member system (package-transitive-supported-systems package system))) (define (bag-direct-inputs bag) "Same as 'package-direct-inputs', but applied to a bag." diff --git a/tests/packages.scm b/tests/packages.scm index 0478fff237..423c5061aa 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -341,7 +341,6 @@ (build-system gnu-build-system) (supported-systems `("does-not-exist" "foobar" ,@%supported-systems))))) - (invalidate-memoization! package-transitive-supported-systems) (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture (package-transitive-supported-systems p)))) @@ -354,17 +353,40 @@ (build-system gnu-build-system) (supported-systems `("does-not-exist" "foobar" ,@%supported-systems))))) - (invalidate-memoization! package-transitive-supported-systems) (parameterize ((%current-system "x86_64-linux")) (package-transitive-supported-systems p)))) (test-assert "supported-package?" - (let ((p (dummy-package "foo" - (build-system gnu-build-system) - (supported-systems '("x86_64-linux" "does-not-exist"))))) + (let* ((d (dummy-package "dep" + (build-system trivial-build-system) + (supported-systems '("x86_64-linux")))) + (p (dummy-package "foo" + (build-system gnu-build-system) + (inputs `(("d" ,d))) + (supported-systems '("x86_64-linux" "armhf-linux"))))) + (and (supported-package? p "x86_64-linux") + (not (supported-package? p "i686-linux")) + (not (supported-package? p "armhf-linux"))))) + +(test-assert "supported-package? vs. system-dependent graph" + ;; The inputs of a package can depend on (%current-system). Thus, + ;; 'supported-package?' must make sure that it binds (%current-system) + ;; appropriately before traversing the dependency graph. In the example + ;; below, 'supported-package?' must thus return true for both systems. + (let* ((p0a (dummy-package "foo-arm" + (build-system trivial-build-system) + (supported-systems '("armhf-linux")))) + (p0b (dummy-package "foo-x86_64" + (build-system trivial-build-system) + (supported-systems '("x86_64-linux")))) + (p (dummy-package "bar" + (build-system trivial-build-system) + (inputs + (if (string=? (%current-system) "armhf-linux") + `(("foo" ,p0a)) + `(("foo" ,p0b))))))) (and (supported-package? p "x86_64-linux") - (not (supported-package? p "does-not-exist")) - (not (supported-package? p "i686-linux"))))) + (supported-package? p "armhf-linux")))) (test-skip (if (not %store) 8 0)) -- cgit v1.2.3 From 2e3e5d21988fc2cafb2a9eaf4b00976ea425629d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Sep 2019 21:36:29 +0200 Subject: daemon: Invoke 'guix gc --list-busy' instead of 'list-runtime-roots'. * nix/scripts/list-runtime-roots.in: Remove. * guix/store/roots.scm (%proc-directory): New variable. (proc-file-roots, proc-exe-roots, proc-cwd-roots) (proc-fd-roots, proc-maps-roots, proc-environ-roots) (referenced-files, canonicalize-store-item, busy-store-items): New procedures, taken from 'list-runtime-roots.in'. * nix/libstore/globals.hh (Settings)[guixProgram]: New field. * nix/libstore/globals.cc (Settings::processEnvironment): Initialize 'guixProgram'. * nix/libstore/gc.cc (addAdditionalRoots): Drop code related to 'NIX_ROOT_FINDER'. Run "guix gc --list-busy". * nix/local.mk (nodist_pkglibexec_SCRIPTS): Remove 'scripts/list-runtime-roots'. * config-daemon.ac: Don't output nix/scripts/list-runtime-roots. * build-aux/pre-inst-env.in: Don't set 'NIX_ROOT_FINDER'. Set 'GUIX'. * doc/guix.texi (Invoking guix gc): Document '--list-busy'. * guix/scripts/gc.scm (show-help, %options): Add "--list-busy". (guix-gc)[list-busy]: New procedure. Handle the 'list-busy' action. --- build-aux/pre-inst-env.in | 6 +- config-daemon.ac | 3 - doc/guix.texi | 4 ++ guix/scripts/gc.scm | 15 ++++ guix/store/roots.scm | 129 ++++++++++++++++++++++++++++++++- nix/libstore/gc.cc | 11 ++- nix/libstore/globals.cc | 1 + nix/libstore/globals.hh | 3 + nix/local.mk | 1 - nix/scripts/list-runtime-roots.in | 147 -------------------------------------- 10 files changed, 158 insertions(+), 162 deletions(-) delete mode 100644 nix/scripts/list-runtime-roots.in (limited to 'guix') diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in index 3efab69e7d..ab1c519d70 100644 --- a/build-aux/pre-inst-env.in +++ b/build-aux/pre-inst-env.in @@ -44,15 +44,17 @@ export PATH # Daemon helpers. -NIX_ROOT_FINDER="$abs_top_builddir/nix/scripts/list-runtime-roots" NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts" # for 'authenticate', etc. -export NIX_ROOT_FINDER NIX_LIBEXEC_DIR +export NIX_LIBEXEC_DIR NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload" @BUILD_DAEMON_OFFLOAD_TRUE@export NIX_BUILD_HOOK @BUILD_DAEMON_OFFLOAD_FALSE@# No offloading support. @BUILD_DAEMON_OFFLOAD_FALSE@unset NIX_BUILD_HOOK +# The daemon invokes 'guix'; tell it which one to use. +GUIX="$abs_top_builddir/scripts/guix" +export GUIX # The following variables need only be defined when compiling Guix # modules, but we define them to be on the safe side in case of diff --git a/config-daemon.ac b/config-daemon.ac index f1ad10acff..f1d26af3a7 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -148,9 +148,6 @@ if test "x$guix_build_daemon" = "xyes"; then AC_SUBST([GUIX_TEST_ROOT]) GUIX_CHECK_LOCALSTATEDIR - - AC_CONFIG_FILES([nix/scripts/list-runtime-roots], - [chmod +x nix/scripts/list-runtime-roots]) AC_CONFIG_FILES([nix/scripts/download], [chmod +x nix/scripts/download]) AC_CONFIG_FILES([nix/scripts/substitute], diff --git a/doc/guix.texi b/doc/guix.texi index 83f791d71d..31f7890fe9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3496,6 +3496,10 @@ This prints nothing unless the daemon was started with List the GC roots owned by the user; when run as root, list @emph{all} the GC roots. +@item --list-busy +List store items in use by currently running processes. These store +items are effectively considered GC roots: they cannot be deleted. + @item --clear-failures Remove the specified store items from the failed-build cache. diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 31657326b6..3f20a2e192 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -56,6 +56,8 @@ Invoke the garbage collector.\n")) -D, --delete attempt to delete PATHS")) (display (G_ " --list-roots list the user's garbage collector roots")) + (display (G_ " + --list-busy list store items used by running processes")) (display (G_ " --optimize optimize the store by deduplicating identical files")) (display (G_ " @@ -174,6 +176,10 @@ is deprecated; use '-D'~%")) (lambda (opt name arg result) (alist-cons 'action 'list-roots (alist-delete 'action result)))) + (option '("list-busy") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-busy + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -265,6 +271,12 @@ is deprecated; use '-D'~%")) (newline)) roots))) + (define (list-busy) + ;; List store items used by running processes. + (for-each (lambda (item) + (display item) (newline)) + (busy-store-items))) + (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) @@ -305,6 +317,9 @@ is deprecated; use '-D'~%")) ((list-roots) (assert-no-extra-arguments) (list-roots)) + ((list-busy) + (assert-no-extra-arguments) + (list-busy)) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/store/roots.scm b/guix/store/roots.scm index 4f23ae34e8..58653507f8 100644 --- a/guix/store/roots.scm +++ b/guix/store/roots.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,9 +26,13 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (rnrs io ports) #:re-export (%gc-roots-directory) #:export (gc-roots - user-owned?)) + user-owned? + busy-store-items)) ;;; Commentary: ;;; @@ -118,3 +122,124 @@ are user-controlled symlinks stored anywhere on the file system." (= (stat:uid stat) uid)) (const #f))) + + +;;; +;;; Listing "busy" store items: those referenced by currently running +;;; processes. +;;; + +(define %proc-directory + ;; Mount point of Linuxish /proc file system. + "/proc") + +(define (proc-file-roots dir file) + "Return a one-element list containing the file pointed to by DIR/FILE, +or the empty list." + (or (and=> (false-if-exception (readlink (string-append dir "/" file))) + list) + '())) + +(define proc-exe-roots (cut proc-file-roots <> "exe")) +(define proc-cwd-roots (cut proc-file-roots <> "cwd")) + +(define (proc-fd-roots dir) + "Return the list of store files referenced by DIR, which is a +/proc/XYZ directory." + (let ((dir (string-append dir "/fd"))) + (filter-map (lambda (file) + (let ((target (false-if-exception + (readlink (string-append dir "/" file))))) + (and target + (string-prefix? "/" target) + target))) + (or (scandir dir string->number) '())))) + +(define (proc-maps-roots dir) + "Return the list of store files referenced by DIR, which is a +/proc/XYZ directory." + (define %file-mapping-line + (make-regexp "^.*[[:blank:]]+/([^ ]+)$")) + + (call-with-input-file (string-append dir "/maps") + (lambda (maps) + (let loop ((line (read-line maps)) + (roots '())) + (cond ((eof-object? line) + roots) + ((regexp-exec %file-mapping-line line) + => + (lambda (match) + (let ((file (string-append "/" + (match:substring match 1)))) + (loop (read-line maps) + (cons file roots))))) + (else + (loop (read-line maps) roots))))))) + +(define (proc-environ-roots dir) + "Return the list of store files referenced by DIR/environ, where DIR is a +/proc/XYZ directory." + (define split-on-nul + (cute string-tokenize <> + (char-set-complement (char-set #\nul)))) + + (define (rhs-file-names str) + (let ((equal (string-index str #\=))) + (if equal + (let* ((str (substring str (+ 1 equal))) + (rx (string-append (regexp-quote %store-directory) + "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+"))) + (map match:substring (list-matches rx str))) + '()))) + + (define environ + (string-append dir "/environ")) + + (append-map rhs-file-names + (split-on-nul + (call-with-input-file environ + get-string-all)))) + +(define (referenced-files) + "Return the list of referenced store items." + (append-map (lambda (pid) + (let ((proc (string-append %proc-directory "/" pid))) + (catch 'system-error + (lambda () + (append (proc-exe-roots proc) + (proc-cwd-roots proc) + (proc-fd-roots proc) + (proc-maps-roots proc) + (proc-environ-roots proc))) + (lambda args + (let ((err (system-error-errno args))) + (if (or (= ENOENT err) ;TOCTTOU race + (= ESRCH err) ;ditto + (= EACCES err)) ;not running as root + '() + (apply throw args))))))) + (scandir %proc-directory string->number + (lambda (a b) + (< (string->number a) (string->number b)))))) + +(define canonicalize-store-item + (let* ((store (string-append %store-directory "/")) + (prefix (string-length store))) + (lambda (file) + "Return #f if FILE is not a store item; otherwise, return the store file +name without any sub-directory components." + (and (string-prefix? store file) + (string-append store + (let ((base (string-drop file prefix))) + (match (string-index base #\/) + (#f base) + (slash (string-take base slash))))))))) + +(define (busy-store-items) + "Return the list of store items used by the currently running processes. + +This code should typically run as root; it allows the garbage collector to +determine which store items must not be deleted." + (delete-duplicates + (filter-map canonicalize-store-item (referenced-files)))) diff --git a/nix/libstore/gc.cc b/nix/libstore/gc.cc index 46171e116c..c466996668 100644 --- a/nix/libstore/gc.cc +++ b/nix/libstore/gc.cc @@ -339,14 +339,11 @@ Roots LocalStore::findRoots() static void addAdditionalRoots(StoreAPI & store, PathSet & roots) { - Path rootFinder = getEnv("NIX_ROOT_FINDER", - settings.nixLibexecDir + "/list-runtime-roots"); + debug(format("executing `%1% gc --list-busy' to find additional roots") + % settings.guixProgram); - if (rootFinder.empty()) return; - - debug(format("executing `%1%' to find additional roots") % rootFinder); - - string result = runProgram(rootFinder); + const Strings args = { "gc", "--list-busy" }; + string result = runProgram(settings.guixProgram, false, args); StringSet paths = tokenizeString(result, "\n"); diff --git a/nix/libstore/globals.cc b/nix/libstore/globals.cc index 6df20e7a52..8f7c976fcb 100644 --- a/nix/libstore/globals.cc +++ b/nix/libstore/globals.cc @@ -73,6 +73,7 @@ void Settings::processEnvironment() nixLibexecDir = canonPath(getEnv("NIX_LIBEXEC_DIR", NIX_LIBEXEC_DIR)); nixBinDir = canonPath(getEnv("NIX_BIN_DIR", NIX_BIN_DIR)); nixDaemonSocketFile = canonPath(nixStateDir + DEFAULT_SOCKET_PATH); + guixProgram = canonPath(getEnv("GUIX", nixBinDir + "/guix")); } diff --git a/nix/libstore/globals.hh b/nix/libstore/globals.hh index b073f724b6..0d9315a41a 100644 --- a/nix/libstore/globals.hh +++ b/nix/libstore/globals.hh @@ -66,6 +66,9 @@ struct Settings { /* File name of the socket the daemon listens to. */ Path nixDaemonSocketFile; + /* Absolute file name of the 'guix' program. */ + Path guixProgram; + /* Whether to keep temporary directories of failed builds. */ bool keepFailed; diff --git a/nix/local.mk b/nix/local.mk index 6d7e60e9fb..fd7379b5ff 100644 --- a/nix/local.mk +++ b/nix/local.mk @@ -155,7 +155,6 @@ noinst_HEADERS = \ (write (get-string-all in) out)))))" nodist_pkglibexec_SCRIPTS = \ - %D%/scripts/list-runtime-roots \ %D%/scripts/substitute \ %D%/scripts/download diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in deleted file mode 100644 index 5f2660fb5e..0000000000 --- a/nix/scripts/list-runtime-roots.in +++ /dev/null @@ -1,147 +0,0 @@ -#!@GUILE@ -ds -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2017 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 . - -;;; -;;; List files being used at run time; these files are garbage collector -;;; roots. This is equivalent to `find-runtime-roots.pl' in Nix. -;;; - -(use-modules (ice-9 ftw) - (ice-9 regex) - (ice-9 rdelim) - (ice-9 match) - (srfi srfi-1) - (srfi srfi-26) - (rnrs io ports)) - -(define %proc-directory - ;; Mount point of Linuxish /proc file system. - "/proc") - -(define %store-directory - (or (getenv "NIX_STORE_DIR") - "@storedir@")) - -(define (proc-file-roots dir file) - "Return a one-element list containing the file pointed to by DIR/FILE, -or the empty list." - (or (and=> (false-if-exception (readlink (string-append dir "/" file))) - list) - '())) - -(define proc-exe-roots (cut proc-file-roots <> "exe")) -(define proc-cwd-roots (cut proc-file-roots <> "cwd")) - -(define (proc-fd-roots dir) - "Return the list of store files referenced by DIR, which is a -/proc/XYZ directory." - (let ((dir (string-append dir "/fd"))) - (filter-map (lambda (file) - (let ((target (false-if-exception - (readlink (string-append dir "/" file))))) - (and target - (string-prefix? "/" target) - target))) - (or (scandir dir string->number) '())))) - -(define (proc-maps-roots dir) - "Return the list of store files referenced by DIR, which is a -/proc/XYZ directory." - (define %file-mapping-line - (make-regexp "^.*[[:blank:]]+/([^ ]+)$")) - - (call-with-input-file (string-append dir "/maps") - (lambda (maps) - (let loop ((line (read-line maps)) - (roots '())) - (cond ((eof-object? line) - roots) - ((regexp-exec %file-mapping-line line) - => - (lambda (match) - (let ((file (string-append "/" - (match:substring match 1)))) - (loop (read-line maps) - (cons file roots))))) - (else - (loop (read-line maps) roots))))))) - -(define (proc-environ-roots dir) - "Return the list of store files referenced by DIR/environ, where DIR is a -/proc/XYZ directory." - (define split-on-nul - (cute string-tokenize <> - (char-set-complement (char-set #\nul)))) - - (define (rhs-file-names str) - (let ((equal (string-index str #\=))) - (if equal - (let* ((str (substring str (+ 1 equal))) - (rx (string-append (regexp-quote %store-directory) - "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+"))) - (map match:substring (list-matches rx str))) - '()))) - - (define environ - (string-append dir "/environ")) - - (append-map rhs-file-names - (split-on-nul - (call-with-input-file environ - get-string-all)))) - -(define (referenced-files) - "Return the list of referenced store items." - (append-map (lambda (pid) - (let ((proc (string-append %proc-directory "/" pid))) - (catch 'system-error - (lambda () - (append (proc-exe-roots proc) - (proc-cwd-roots proc) - (proc-fd-roots proc) - (proc-maps-roots proc) - (proc-environ-roots proc))) - (lambda args - (let ((err (system-error-errno args))) - (if (or (= ENOENT err) ;TOCTTOU race - (= ESRCH err) ;ditto - (= EACCES err)) ;not running as root - '() - (apply throw args))))))) - (scandir %proc-directory string->number - (lambda (a b) - (< (string->number a) (string->number b)))))) - -(define canonicalize-store-item - (let* ((store (string-append %store-directory "/")) - (prefix (string-length store))) - (lambda (file) - "Return #f if FILE is not a store item; otherwise, return the store file -name without any sub-directory components." - (and (string-prefix? store file) - (string-append store - (let ((base (string-drop file prefix))) - (match (string-index base #\/) - (#f base) - (slash (string-take base slash))))))))) - -(for-each (cut simple-format #t "~a~%" <>) - (delete-duplicates - (filter-map canonicalize-store-item (referenced-files)))) -- cgit v1.2.3 From 982a94e97eff85b053558fac7c0442726a091f11 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 8 Sep 2019 14:29:27 +0200 Subject: import: github: Fix incorrect no-release case. This is a followup to 81c3dc32244a17241d74eea9fa265edfcb326f6d. Since that commit, when /releases returned an empty JSON array, we would not fall back to /tags because of the incorrect match. * guix/import/github.scm (fetch-releases-or-tags): Match the empty vector instead of the empty list. --- guix/import/github.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index 55e1f72a42..55ea00a111 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -161,7 +161,7 @@ empty list." url)) (match (json-fetch (decorate release-url) #:headers headers) - (() + (#() ;; We got the empty list, presumably because the user didn't use GitHub's ;; "release" mechanism, but hopefully they did use Git tags. (json-fetch (decorate tag-url) #:headers headers)) -- cgit v1.2.3 From 36eef80d45ae754ba42a761ffc97e38cc7253bd0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 9 Sep 2019 10:19:59 +0200 Subject: packages: 'package-field-location' really catches 'system-error. This had been wrong since forever (i.e., 2013). * guix/packages.scm (package-field-location): Catch 'system-error, not 'system. --- guix/packages.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 143417b861..b92ed0ab0c 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -351,7 +351,7 @@ object." (match (package-location package) (($ file line column) - (catch 'system + (catch 'system-error (lambda () ;; In general we want to keep relative file names for modules. (with-fluids ((%file-port-name-canonicalization 'relative)) -- cgit v1.2.3 From 7c101c4c175b7abcb43279d1c66b41a91b9c64bc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 9 Sep 2019 10:33:42 +0200 Subject: refresh: Distinguish between "no updater" and "failing updater". Previously, something like "guix refresh texmacs" would report "no updater". Now, it reports that the 'gnu-ftp' updater failed to list releases. * guix/upstream.scm (lookup-updater): Use 'find' instead of 'any' to return the . (package-latest-release): Adjust accordingly. * guix/scripts/refresh.scm (check-for-package-update): When 'package-latest-release' returns #f, distinguish between "no updater" and "failing updater". --- guix/scripts/refresh.scm | 12 ++++++++++-- guix/upstream.scm | 12 ++++++------ 2 files changed, 16 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 4591d0f308..daf6fcf947 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -368,8 +368,16 @@ the latest known version of ~a (~a)~%") (upstream-source-version source))))))) (#f (when warn? - (warn-no-updater package))))) - + ;; Distinguish between "no updater" and "failing updater." + (match (lookup-updater package updaters) + ((? upstream-updater? updater) + (warning (package-location package) + (G_ "'~a' updater failed to determine available \ +releases for ~a~%") + (upstream-updater-name updater) + (package-name package))) + (#f + (warn-no-updater package))))))) ;;; diff --git a/guix/upstream.scm b/guix/upstream.scm index d4f9c5bb45..aa47dab4b4 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -245,18 +245,18 @@ correspond to the same version." (define (lookup-updater package updaters) "Return an updater among UPDATERS that matches PACKAGE, or #f if none of them matches." - (any (match-lambda - (($ name description pred latest) - (and (pred package) latest))) - updaters)) + (find (match-lambda + (($ name description pred latest) + (pred package))) + updaters)) (define (package-latest-release package updaters) "Return an upstream source to update PACKAGE, a object, or #f if none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure that the returned source is newer than the current one." (match (lookup-updater package updaters) - ((? procedure? latest-release) - (latest-release package)) + ((? upstream-updater? updater) + ((upstream-updater-latest updater) package)) (_ #f))) (define (package-latest-release* package updaters) -- cgit v1.2.3 From fd63ecbe050bf8fa7c8ff0a003d56cce97b6ded1 Mon Sep 17 00:00:00 2001 From: Martin Becze Date: Mon, 9 Sep 2019 11:36:04 -0400 Subject: import: crate: Allow imports of a specific version. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/crate.scm (crate->guix-package): Add optional 'version' argument and honor it. * guix/scripts/import/crate.scm (guix-import-crate): Assume the first argument is a spec and destructure it with 'package-name->name+version'. Pass both to 'crate->guix-package'. * doc/guix.texi (Invoking guix import): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 12 +++++++++++- guix/import/crate.scm | 29 +++++++++++++++++++---------- guix/scripts/import/crate.scm | 13 ++++++++++--- 3 files changed, 40 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 9101aafda1..989b3d03bb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8912,7 +8912,17 @@ in Guix. @item crate @cindex crate Import metadata from the crates.io Rust package repository -@uref{https://crates.io, crates.io}. +@uref{https://crates.io, crates.io}, as in this example: + +@example +guix import crate blake2-rfc +@end example + +The crate importer also allows you to specify a version string: + +@example +guix import crate constant-time-eq@@0.1.0 +@end example @item opam @cindex OPAM diff --git a/guix/import/crate.scm b/guix/import/crate.scm index f6057dbf8b..fd1974eae8 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven ;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -181,9 +182,11 @@ and LICENSE." ;; This regexp matches that. (make-regexp "^(.*) OR (.*)$")) -(define (crate->guix-package crate-name) +(define* (crate->guix-package crate-name #:optional version) "Fetch the metadata for CRATE-NAME from crates.io, and return the -`package' s-expression corresponding to that package, or #f on failure." +`package' s-expression corresponding to that package, or #f on failure. +When VERSION is specified, attempt to fetch that version; otherwise fetch the +latest version of CRATE-NAME." (define (string->license string) (match (regexp-exec %dual-license-rx string) (#f (list (spdx-string->license string))) @@ -196,12 +199,18 @@ and LICENSE." (define crate (lookup-crate crate-name)) - (and crate - (let* ((version (find (lambda (version) - (string=? (crate-version-number version) - (crate-latest-version crate))) - (crate-versions crate))) - (dependencies (crate-version-dependencies version)) + (define version-number + (or version + (crate-latest-version crate))) + + (define version* + (find (lambda (version) + (string=? (crate-version-number version) + version-number)) + (crate-versions crate))) + + (and crate version* + (let* ((dependencies (crate-version-dependencies version*)) (dep-crates (filter normal-dependency? dependencies)) (dev-dep-crates (remove normal-dependency? dependencies)) (cargo-inputs (sort (map crate-dependency-id dep-crates) @@ -210,14 +219,14 @@ and LICENSE." (sort (map crate-dependency-id dev-dep-crates) string-ci (crate-version-license version) + #:license (and=> (crate-version-license version*) string->license))))) (define (guix-package->crate-name package) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index cab9a4397b..7ae8638911 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -2,6 +2,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2016 David Craven +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,6 +76,7 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (alist-cons 'argument arg result)) %default-options)) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -82,11 +84,16 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (let ((sexp (crate->guix-package package-name))) + ((spec) + (define-values (name version) + (package-name->name+version spec)) + + (let ((sexp (crate->guix-package name version))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) + (if version + (string-append name "@" version) + name))) sexp)) (() (leave (G_ "too few arguments~%"))) -- cgit v1.2.3 From da1027a70508ea96134f5ef89d9dd390679255f0 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Tue, 27 Aug 2019 18:20:16 +0200 Subject: guix: Rename and move sans-extension to tarball-sans-extension. * guix/gnu-maintenance.scm (sans-extension): Move and rename to ... * guix/utils.scm (tarball-sans-extension): ... here. --- guix/gnu-maintenance.scm | 26 ++++++++++++-------------- guix/utils.scm | 7 +++++++ 2 files changed, 19 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index d63d44f629..8fce956c60 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -230,12 +230,6 @@ network to check in GNU's database." (or (assoc-ref (package-properties package) 'ftp-directory) (string-append "/gnu/" name))))) -(define (sans-extension tarball) - "Return TARBALL without its .tar.* or .zip extension." - (let ((end (or (string-contains tarball ".tar") - (string-contains tarball ".zip")))) - (substring tarball 0 end))) - (define %tarball-rx ;; The .zip extensions is notably used for freefont-ttf. ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". @@ -261,14 +255,15 @@ true." (string-append project "-src"))))))) (not (regexp-exec %alpha-tarball-rx file)) - (let ((s (sans-extension file))) + (let ((s (tarball-sans-extension file))) (regexp-exec %package-name-rx s)))) (define (tarball->version tarball) "Return the version TARBALL corresponds to. TARBALL is a file name like \"coreutils-8.23.tar.xz\"." (let-values (((name version) - (gnu-package-name->name+version (sans-extension tarball)))) + (gnu-package-name->name+version + (tarball-sans-extension tarball)))) version)) (define* (releases project @@ -492,8 +487,9 @@ return the corresponding signature URL, or #f it signatures are unavailable." (and (string=? url (basename url)) ;relative reference? (release-file? package url) (let-values (((name version) - (package-name->name+version (sans-extension url) - #\-))) + (package-name->name+version + (tarball-sans-extension url) + #\-))) (upstream-source (package name) (version version) @@ -565,14 +561,16 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)." (release-file? name (basename file)))) files))) (match (sort relevant (lambda (file1 file2) - (version>? (sans-extension (basename file1)) - (sans-extension (basename file2))))) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) ((and tarballs (reference _ ...)) (let* ((version (tarball->version reference)) (tarballs (filter (lambda (file) - (string=? (sans-extension + (string=? (tarball-sans-extension (basename file)) - (sans-extension + (tarball-sans-extension (basename reference)))) tarballs))) (upstream-source diff --git a/guix/utils.scm b/guix/utils.scm index f480c3291f..1f99c5b3f5 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -91,6 +91,7 @@ arguments-from-environment-variable file-extension file-sans-extension + tarball-sans-extension compressed-file? switch-symlinks call-with-temporary-output-file @@ -578,6 +579,12 @@ minor version numbers from version-string." (substring file 0 dot) file))) +(define (tarball-sans-extension tarball) + "Return TARBALL without its .tar.* or .zip extension." + (let ((end (or (string-contains tarball ".tar") + (string-contains tarball ".zip")))) + (substring tarball 0 end))) + (define (compressed-file? file) "Return true if FILE denotes a compressed file." (->bool (member (file-extension file) -- cgit v1.2.3 From 33f53947aa6d50ef7fe08c0ef9e32cdb9e77db89 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 4 Aug 2019 11:30:32 +0200 Subject: gnu-maintenance: KDE updater no longer relies on FTP access. Fetch the ls-lR.bz2 file list for download.kde.org, convert it into a list of file paths and cache the list. * guix/gnu-maintenance.scm (%kde-file-list-uri): New variable. (download.kde.org-files): New procedure. (latest-kde-release): Change to use DOWNLOAD.KDE.ORG-FILES and search for files in this list. --- guix/gnu-maintenance.scm | 100 +++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 92 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 8fce956c60..9ce06508a3 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov +;;; Copyright © 2019 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ #:use-module (sxml simple) #:use-module (ice-9 regex) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -613,15 +615,97 @@ releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) +(define %kde-file-list-uri + ;; URI of the file list (ls -lR format) for download.kde.org. + (string->uri "https://download.kde.org/ls-lR.bz2")) + +(define (download.kde.org-files) + ;;"Return the list of files available at download.kde.org." + + (define (ls-lR-line->filename path line) + ;; remove mode, blocks, user, group, size, date, time and one space + (regexp-substitute + #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) + + (define (canonicalize path) + (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) + (string-drop path (string-length "/srv/archives/ftp")) + path)) + (path (if (string-suffix? ":" path) + (string-drop-right path 1) + path)) + (path (if (not (string-suffix? "/" path)) + (string-append path "/") + path))) + path)) + + (define (write-cache input cache) + "Read bzipped ls-lR from INPUT, and write it as a list of file paths to +CACHE." + + (call-with-decompressed-port 'bzip2 input + (lambda (input) + (let loop_dirs ((files '())) + (let ((path (read-line input))) + (if + (or (eof-object? path) (string= path "")) + (write (reverse files) cache)) + (let loop_entries ((path (canonicalize path)) + (files files)) + (let ((line (read-line input))) + (cond + ((eof-object? line) + (write (reverse files) cache)) + ((string-prefix? "-" line) + (loop_entries path + (cons (ls-lR-line->filename path line) files))) + ((not (string= line "")) + (loop_entries path files)) + (#t (loop_dirs files)))))))))) + + (define (cache-miss uri) + (format (current-error-port) "fetching ~a...~%" (uri->string uri))) + + (let* ((port (http-fetch/cached %kde-file-list-uri + #:ttl 3600 + #:write-cache write-cache + #:cache-miss cache-miss)) + (files (read port))) + (close-port port) + files)) + (define (latest-kde-release package) - "Return the latest release of PACKAGE, the name of an KDE.org package." - (let ((uri (string->uri (origin-uri (package-source package))))) - (false-if-ftp-error - (latest-ftp-release - (package-upstream-name package) - #:server "ftp.mirrorservice.org" - #:directory (string-append "/sites/ftp.kde.org/pub/kde/" - (dirname (dirname (uri-path uri)))))))) + "Return the latest release of PACKAGE, a KDE package, or #f if it could not +be determined." + (let* ((uri (string->uri (origin-uri (package-source package)))) + (directory (dirname (dirname (uri-path uri)))) + (name (package-upstream-name package)) + (files (download.kde.org-files)) + (relevant (filter (lambda (file) + (and (string-prefix? directory file) + (release-file? name (basename file)))) + files))) + (match (sort relevant (lambda (file1 file2) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) + ((and tarballs (reference _ ...)) + (let* ((version (tarball->version reference)) + (tarballs (filter (lambda (file) + (string=? (tarball-sans-extension + (basename file)) + (tarball-sans-extension + (basename reference)))) + tarballs))) + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs))))) + (() + #f)))) (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." -- cgit v1.2.3 From d1dce0c3638a577a2ab713d2551f4aabe67d031c Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Tue, 3 Sep 2019 14:16:03 +0200 Subject: upstream: Move KDE updater into a separate module. As it was done for (guix import gnome). * guix/import/kde.scm: New file. * Makefile.am (MODULES): Add it. * guix/gnu-maintenance.scm (%kde-updater) (%kde-file-list-uri) (download.kde.org-files) (latest-kde-release): Remove. --- Makefile.am | 1 + guix/gnu-maintenance.scm | 102 ------------------------------ guix/import/kde.scm | 158 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 159 insertions(+), 102 deletions(-) create mode 100644 guix/import/kde.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 683b2242f0..7e3b5c1070 100644 --- a/Makefile.am +++ b/Makefile.am @@ -221,6 +221,7 @@ MODULES = \ guix/import/gnu.scm \ guix/import/hackage.scm \ guix/import/json.scm \ + guix/import/kde.scm \ guix/import/launchpad.scm \ guix/import/opam.scm \ guix/import/print.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 9ce06508a3..ef067704ad 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,7 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov -;;; Copyright © 2019 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +24,6 @@ #:use-module (sxml simple) #:use-module (ice-9 regex) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -64,7 +62,6 @@ %gnu-updater %gnu-ftp-updater - %kde-updater %xorg-updater %kernel.org-updater)) @@ -615,98 +612,6 @@ releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) -(define %kde-file-list-uri - ;; URI of the file list (ls -lR format) for download.kde.org. - (string->uri "https://download.kde.org/ls-lR.bz2")) - -(define (download.kde.org-files) - ;;"Return the list of files available at download.kde.org." - - (define (ls-lR-line->filename path line) - ;; remove mode, blocks, user, group, size, date, time and one space - (regexp-substitute - #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) - - (define (canonicalize path) - (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) - (string-drop path (string-length "/srv/archives/ftp")) - path)) - (path (if (string-suffix? ":" path) - (string-drop-right path 1) - path)) - (path (if (not (string-suffix? "/" path)) - (string-append path "/") - path))) - path)) - - (define (write-cache input cache) - "Read bzipped ls-lR from INPUT, and write it as a list of file paths to -CACHE." - - (call-with-decompressed-port 'bzip2 input - (lambda (input) - (let loop_dirs ((files '())) - (let ((path (read-line input))) - (if - (or (eof-object? path) (string= path "")) - (write (reverse files) cache)) - (let loop_entries ((path (canonicalize path)) - (files files)) - (let ((line (read-line input))) - (cond - ((eof-object? line) - (write (reverse files) cache)) - ((string-prefix? "-" line) - (loop_entries path - (cons (ls-lR-line->filename path line) files))) - ((not (string= line "")) - (loop_entries path files)) - (#t (loop_dirs files)))))))))) - - (define (cache-miss uri) - (format (current-error-port) "fetching ~a...~%" (uri->string uri))) - - (let* ((port (http-fetch/cached %kde-file-list-uri - #:ttl 3600 - #:write-cache write-cache - #:cache-miss cache-miss)) - (files (read port))) - (close-port port) - files)) - -(define (latest-kde-release package) - "Return the latest release of PACKAGE, a KDE package, or #f if it could not -be determined." - (let* ((uri (string->uri (origin-uri (package-source package)))) - (directory (dirname (dirname (uri-path uri)))) - (name (package-upstream-name package)) - (files (download.kde.org-files)) - (relevant (filter (lambda (file) - (and (string-prefix? directory file) - (release-file? name (basename file)))) - files))) - (match (sort relevant (lambda (file1 file2) - (version>? (tarball-sans-extension - (basename file1)) - (tarball-sans-extension - (basename file2))))) - ((and tarballs (reference _ ...)) - (let* ((version (tarball->version reference)) - (tarballs (filter (lambda (file) - (string=? (tarball-sans-extension - (basename file)) - (tarball-sans-extension - (basename reference)))) - tarballs))) - (upstream-source - (package name) - (version version) - (urls (map (lambda (file) - (string-append "mirror://kde/" file)) - tarballs))))) - (() - #f)))) - (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." (let ((uri (string->uri (origin-uri (package-source package))))) @@ -754,13 +659,6 @@ be determined." (pure-gnu-package? package)))) (latest latest-release*))) -(define %kde-updater - (upstream-updater - (name 'kde) - (description "Updater for KDE packages") - (pred (url-prefix-predicate "mirror://kde/")) - (latest latest-kde-release))) - (define %xorg-updater (upstream-updater (name 'xorg) diff --git a/guix/import/kde.scm b/guix/import/kde.scm new file mode 100644 index 0000000000..927ecc8263 --- /dev/null +++ b/guix/import/kde.scm @@ -0,0 +1,158 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2019 Hartmut Goebel +;;; +;;; 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 . + +(define-module (guix import kde) + #:use-module (guix http-client) + #:use-module (guix memoization) + #:use-module (guix gnu-maintenance) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-11) + #:use-module (web uri) + + #:export (%kde-updater)) + +;;; Commentary: +;;; +;;; This package provides not an actual importer but simply an updater for +;;; KDE packages. It grabs available files from the 'ls-lR.bz2' file +;;; available on download.kde.org. +;;; +;;; Code: + +(define (tarball->version tarball) + "Return the version TARBALL corresponds to. TARBALL is a file name like +\"coreutils-8.23.tar.xz\"." + (let-values (((name version) + (gnu-package-name->name+version + (tarball-sans-extension tarball)))) + version)) + +(define %kde-file-list-uri + ;; URI of the file list (ls -lR format) for download.kde.org. + (string->uri "https://download.kde.org/ls-lR.bz2")) + +(define (download.kde.org-files) + ;;"Return the list of files available at download.kde.org." + + (define (ls-lR-line->filename path line) + ;; Remove mode, blocks, user, group, size, date, time and one space, + ;; then prepend PATH + (regexp-substitute + #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) + + (define (canonicalize path) + (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) + (string-drop path (string-length "/srv/archives/ftp")) + path)) + (path (if (string-suffix? ":" path) + (string-drop-right path 1) + path)) + (path (if (not (string-suffix? "/" path)) + (string-append path "/") + path))) + path)) + + (define (write-cache input cache) + "Read bzipped ls-lR from INPUT, and write it as a list of file paths to +CACHE." + (call-with-decompressed-port 'bzip2 input + (lambda (input) + (let loop_dirs ((files '())) + ;; process a new directory block + (let ((path (read-line input))) + (if + (or (eof-object? path) (string= path "")) + (write (reverse files) cache) + (let loop_entries ((path (canonicalize path)) + (files files)) + ;; process entries within the directory block + (let ((line (read-line input))) + (cond + ((eof-object? line) + (write (reverse files) cache)) + ((string-prefix? "-" line) + ;; this is a file entry: prepend to FILES, then re-enter + ;; the loop for remaining entries + (loop_entries path + (cons (ls-lR-line->filename path line) files) + )) + ((not (string= line "")) + ;; this is a non-file entry: ignore it, just re-enter the + ;; loop for remaining entries + (loop_entries path files)) + ;; empty line: directory block end, re-enter the outer + ;; loop for the next block + (#t (loop_dirs files))))))))))) + + (define (cache-miss uri) + (format (current-error-port) "fetching ~a...~%" (uri->string uri))) + + (let* ((port (http-fetch/cached %kde-file-list-uri + #:ttl 3600 + #:write-cache write-cache + #:cache-miss cache-miss)) + (files (read port))) + (close-port port) + files)) + +(define (latest-kde-release package) + "Return the latest release of PACKAGE, a KDE package, or #f if it could +not be determined." + (let* ((uri (string->uri (origin-uri (package-source package)))) + (directory (dirname (dirname (uri-path uri)))) + (name (package-upstream-name package)) + (files (download.kde.org-files)) + (relevant (filter (lambda (file) + (and (string-prefix? directory file) + (release-file? name (basename file)))) + files))) + (match (sort relevant (lambda (file1 file2) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) + ((and tarballs (reference _ ...)) + (let* ((version (tarball->version reference)) + (tarballs (filter (lambda (file) + (string=? (tarball-sans-extension + (basename file)) + (tarball-sans-extension + (basename reference)))) + tarballs))) + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs))))) + (() + #f)))) + +(define %kde-updater + (upstream-updater + (name 'kde) + (description "Updater for KDE packages") + (pred (url-prefix-predicate "mirror://kde/")) + (latest latest-kde-release))) -- cgit v1.2.3 From 4eb69bf0d33810886ee118f38989cef696e4c868 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 4 Aug 2019 11:32:39 +0200 Subject: import: KDE updater finds packages even in sub-directory. Fixes and finally fixes . Formerly packages living in a path like /stable/frameworks/5.60/portingAids/kross-5.60.0.tar.xz have not been found. * guix/import/kde.scm (uri->kde-path-pattern): New procedure. (latest-kde-release): Use pattern to search for file. --- guix/import/kde.scm | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/kde.scm b/guix/import/kde.scm index 927ecc8263..6873418d62 100644 --- a/guix/import/kde.scm +++ b/guix/import/kde.scm @@ -117,15 +117,47 @@ CACHE." (close-port port) files)) +(define (uri->kde-path-pattern uri) + "Build a regexp from the package's URI suitable for matching the package +path version-agnostic. + +Example: +Input: + mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip +Output: + //stable/frameworks/[^/]+/portingAids/ +" + + (define version-regexp + ;; regexp for matching versions as used in the ld-lR file + (make-regexp + (string-join '("^([0-9]+\\.)+[0-9]+-?" ;; 5.12.90, 4.2.0-preview + "^[0-9]+$" ;; 20031002 + ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1 + "|"))) + + (define (version->pattern part) + ;; If a path element might be a version, replace it by a catch-all part + (if (regexp-exec version-regexp part) + "[^/]+" + part)) + + (let* ((path (uri-path uri)) + (directory-parts (string-split (dirname path) #\/))) + (make-regexp + (string-append + (string-join (map version->pattern directory-parts) "/") + "/")))) + (define (latest-kde-release package) "Return the latest release of PACKAGE, a KDE package, or #f if it could not be determined." (let* ((uri (string->uri (origin-uri (package-source package)))) - (directory (dirname (dirname (uri-path uri)))) + (path-rx (uri->kde-path-pattern uri)) (name (package-upstream-name package)) (files (download.kde.org-files)) (relevant (filter (lambda (file) - (and (string-prefix? directory file) + (and (regexp-exec path-rx file) (release-file? name (basename file)))) files))) (match (sort relevant (lambda (file1 file2) -- cgit v1.2.3 From f58b2f38e4dfdbb8473fb2816d44fae6ad9cbc79 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 12 Sep 2019 20:20:26 +0300 Subject: build: cargo-build-system: Strip store hash from vendor-dir. * guix/build/cargo-build-system.scm (configure): When copying the sources into the vendor-dir strip off the hash before the package name. --- guix/build/cargo-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index f173b64c83..0134997c27 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -99,7 +99,7 @@ Cargo.toml file present at its root." (for-each (match-lambda ((name . path) - (let* ((basepath (basename path)) + (let* ((basepath (string-drop (basename path) 33)) (crate-dir (string-append vendor-dir "/" basepath))) (and (crate-src? path) ;; Gracefully handle duplicate inputs -- cgit v1.2.3 From 5ccec77176b7e0c67ed58c8849e5e76f3dd79a88 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Sep 2019 22:17:43 +0200 Subject: file-systems: Add /var/run/nscd to '%network-file-mappings'. This allows containers created by "guix environment -CN" or by "guix system container -N" to talk to the host nscd. * gnu/system/file-systems.scm (%network-file-mappings): Add "/var/run/nscd". * gnu/build/shepherd.scm (default-mounts)[nscd-socket]: Remove. * gnu/system/linux-container.scm (container-script)[nscd-run-directory] [nscd-mapping, nscd-os, nscd-specs]: Remove. [script]: Filter out from SPECS bind-mounts where the device does not exist. * guix/scripts/environment.scm (launch-environment/container) [optional-mapping->fs]: New procedure. [mappings]: Remove %NETWORK-FILE-MAPPINGS. [file-systems]: Add %NETWORK-FILE-MAPPINGS here, filtered through 'optional-mapping->fs'. --- gnu/build/shepherd.scm | 8 +------- gnu/system/file-systems.scm | 2 +- gnu/system/linux-container.scm | 35 ++++++++++++++--------------------- guix/scripts/environment.scm | 13 ++++++++----- 4 files changed, 24 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index cf68f2108b..b32765ed5e 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -67,16 +67,10 @@ (file-system-mapping (source "/etc/group") (target source)))) - (define nscd-socket - (file-system-mapping - (source "/var/run/nscd") (target source) - (writable? #t))) - (append (cons (tmpfs "/tmp") %container-file-systems) (let ((mappings `(,@(if (memq 'net namespaces) '() - (cons nscd-socket - %network-file-mappings)) + %network-file-mappings) ,@(if (and (memq 'mnt namespaces) (not (memq 'user namespaces))) accounts diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index d11b36f25d..6cf6ccc53e 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -508,7 +508,7 @@ a bind mount." ;; symlink to a file in a tmpfs which, for an unknown reason, ;; cannot be bind mounted read-only within the container. (writable? (string=? file "/etc/resolv.conf")))) - %network-configuration-files)) + (cons "/var/run/nscd" %network-configuration-files))) (define (file-system-type-predicate type) "Return a predicate that, when passed a file system, returns #t if that file diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 6273cee3d3..451a72762c 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -147,13 +147,6 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." "Return a derivation of a script that runs OS as a Linux container. MAPPINGS is a list of objects that specify the files/directories that will be shared with the host system." - (define nscd-run-directory "/var/run/nscd") - - (define nscd-mapping - (file-system-mapping - (source nscd-run-directory) - (target nscd-run-directory))) - (define (mountable-file-system? file-system) ;; Return #t if FILE-SYSTEM should be mounted in the container. (and (not (string=? "/" (file-system-mount-point file-system))) @@ -168,12 +161,7 @@ that will be shared with the host system." os (cons %store-mapping mappings) #:shared-network? shared-network? #:extra-file-systems %container-file-systems)) - (nscd-os (containerized-operating-system - os (cons* nscd-mapping %store-mapping mappings) - #:shared-network? shared-network? - #:extra-file-systems %container-file-systems)) - (specs (os-file-system-specs os)) - (nscd-specs (os-file-system-specs nscd-os))) + (specs (os-file-system-specs os))) (define script (with-imported-modules (source-module-closure @@ -182,14 +170,19 @@ that will be shared with the host system." #~(begin (use-modules (gnu build linux-container) (gnu system file-systems) ;spec->file-system - (guix build utils)) - - (call-with-container - (map spec->file-system - (if (and #$shared-network? - (file-exists? #$nscd-run-directory)) - '#$nscd-specs - '#$specs)) + (guix build utils) + (srfi srfi-1)) + + (define file-systems + (filter-map (lambda (spec) + (let* ((fs (spec->file-system spec)) + (flags (file-system-flags fs))) + (and (or (not (memq 'bind-mount flags)) + (file-exists? (file-system-device fs))) + fs))) + '#$specs)) + + (call-with-container file-systems (lambda () (setenv "HOME" "/root") (setenv "TMPDIR" "/tmp") diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index cf58768300..535f181bfd 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -462,6 +462,10 @@ host file systems to mount inside the container. If USER is not #f, each target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the environment profile." + (define (optional-mapping->fs mapping) + (and (file-exists? (file-system-mapping-source mapping)) + (file-system-mapping->bind-mount mapping))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -498,11 +502,6 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (target cwd) (writable? #t))) '()))) - ;; When in Rome, do as Nix build.cc does: Automagically - ;; map common network configuration files. - (if network? - %network-file-mappings - '()) ;; Mappings for the union closure of all inputs. (map (lambda (dir) (file-system-mapping @@ -511,6 +510,10 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (writable? #f))) reqs))) (file-systems (append %container-file-systems + (if network? + (filter-map optional-mapping->fs + %network-file-mappings) + '()) (map file-system-mapping->bind-mount mappings)))) (exit/status -- cgit v1.2.3 From 43ffa11fdc4de4197a1096f6ebc4067115f9eb26 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Fri, 13 Sep 2019 15:05:10 +0300 Subject: build-system/cargo: Use 'strip-store-file-name'. This is a follow-up to f58b2f38e4dfdbb8473fb2816d44fae6ad9cbc79. * guix/build/cargo-build-system.scm (configure): Use bespoke 'strip-store-file-name' function. --- guix/build/cargo-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 0134997c27..c69cae5afd 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -99,7 +99,7 @@ Cargo.toml file present at its root." (for-each (match-lambda ((name . path) - (let* ((basepath (string-drop (basename path) 33)) + (let* ((basepath (strip-store-file-name path)) (crate-dir (string-append vendor-dir "/" basepath))) (and (crate-src? path) ;; Gracefully handle duplicate inputs -- cgit v1.2.3 From 3af85f832dd007296ec64ddc34beadd397481311 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Fri, 13 Sep 2019 15:09:34 +0300 Subject: build-system/cargo: Remove unused function. * guix/build/cargo-build-system.scm (touch): Remove it. --- guix/build/cargo-build-system.scm | 3 --- 1 file changed, 3 deletions(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index c69cae5afd..4be5443083 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -168,9 +168,6 @@ directory = '" port) (apply invoke `("cargo" "test" ,@cargo-test-flags)) #t)) -(define (touch file-name) - (call-with-output-file file-name (const #t))) - (define* (install #:key inputs outputs skip-build? #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) -- cgit v1.2.3 From 6e377b88930226f3f74ba9fac74d80c36494d9be Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 14 Sep 2019 00:36:51 +0200 Subject: import/utils: beautify-description: Recognize more fragments. * guix/import/utils.scm (beautify-description): Handle additional common initial sentence fragments in descriptions. --- guix/import/utils.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 252875eeab..4694b6e7ef 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -212,10 +212,19 @@ with dashes." (define (beautify-description description) "Improve the package DESCRIPTION by turning a beginning sentence fragment into a proper sentence and by using two spaces between sentences." - (let ((cleaned (if (string-prefix? "A " description) - (string-append "This package provides a" - (substring description 1)) - description))) + (let ((cleaned (cond + ((string-prefix? "A " description) + (string-append "This package provides a" + (substring description 1))) + ((string-prefix? "Provides " description) + (string-append "This package provides" + (substring description + (string-length "Provides")))) + ((string-prefix? "Functions " description) + (string-append "This package provides functions" + (substring description + (string-length "Functions")))) + (else description)))) ;; Use double spacing between sentences (regexp-substitute/global #f "\\. \\b" cleaned 'pre ". " 'post))) -- cgit v1.2.3 From 9bbaf2ae72ce8457702f50277fee908d2c43d13c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Sep 2019 17:35:08 +0200 Subject: pack: Add packages in the order in which they appear on the command line. * guix/scripts/pack.scm (guix-pack)[manifest-from-args](packages): Reverse order of packages taken from OPTS. --- guix/scripts/pack.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index dd91a24284..055d6c95f5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -944,7 +944,8 @@ Create a bundle of PACKAGE.\n")) (list (transform store package) output)) ((? package? package) (list (transform store package) "out"))) - (filter-map maybe-package-argument opts))) + (reverse + (filter-map maybe-package-argument opts)))) (manifest-file (assoc-ref opts 'manifest))) (define properties (if (assoc-ref opts 'save-provenance?) -- cgit v1.2.3 From 0074844366381e3056d09492b8b437836c7adb61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Sep 2019 17:32:16 +0200 Subject: pack: Provide a meaningful "repository name" for Docker. Previously, images produced by 'guix pack -f docker' would always show up as "profile" in the output of 'docker images'. With this change, 'docker images' shows a name constructed from the packages found in the image--e.g., "bash-coreutils-grep-sed". * guix/docker.scm (canonicalize-repository-name): New procedure. (generate-tag): Remove. (manifest): Add optional 'tag' parameter and honor it. (repositories): Likewise. (build-docker-image): Add #:repository parameter and pass it to 'manifest' and 'repositories'. * guix/scripts/pack.scm (docker-image)[build]: Compute 'tag' and pass it as #:repository to 'build-docker-image'. --- guix/docker.scm | 43 ++++++++++++++++++++++++++++++------------- guix/scripts/pack.scm | 13 +++++++++++++ 2 files changed, 43 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index 757bdeb458..97ac6d982b 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -57,22 +57,36 @@ (created . ,time) (container_config . #nil))) -(define (generate-tag path) - "Generate an image tag for the given PATH." - (match (string-split (basename path) #\-) - ((hash name . rest) (string-append name ":" hash)))) +(define (canonicalize-repository-name name) + "\"Repository\" names are restricted to roughtl [a-z0-9_.-]. +Return a version of TAG that follows these rules." + (define ascii-letters + (string->char-set "abcdefghijklmnopqrstuvwxyz")) -(define (manifest path id) + (define separators + (string->char-set "_-.")) + + (define repo-char-set + (char-set-union char-set:digit ascii-letters separators)) + + (string-map (lambda (chr) + (if (char-set-contains? repo-char-set chr) + chr + #\.)) + (string-trim (string-downcase name) separators))) + +(define* (manifest path id #:optional (tag "guix")) "Generate a simple image manifest." - `#(((Config . "config.json") - (RepoTags . #(,(generate-tag path))) - (Layers . #(,(string-append id "/layer.tar")))))) + (let ((tag (canonicalize-repository-name tag))) + `#(((Config . "config.json") + (RepoTags . #(,(string-append tag ":latest"))) + (Layers . #(,(string-append id "/layer.tar"))))))) ;; According to the specifications this is required for backwards ;; compatibility. It duplicates information provided by the manifest. -(define (repositories path id) +(define* (repositories path id #:optional (tag "guix")) "Generate a repositories file referencing PATH and the image ID." - `((,(generate-tag path) . ((latest . ,id))))) + `((,(canonicalize-repository-name tag) . ((latest . ,id))))) ;; See https://github.com/opencontainers/image-spec/blob/master/config.md (define* (config layer time arch #:key entry-point (environment '())) @@ -112,6 +126,7 @@ (define* (build-docker-image image paths prefix #:key + (repository "guix") (extra-files '()) (transformations '()) (system (utsname:machine (uname))) @@ -121,7 +136,9 @@ compressor (creation-time (current-time time-utc))) "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX -must be a store path that is a prefix of any store paths in PATHS. +must be a store path that is a prefix of any store paths in PATHS. REPOSITORY +is a descriptive name that will show up in \"REPOSITORY\" column of the output +of \"docker images\". When DATABASE is true, copy it to /var/guix/db in the image and create /var/guix/gcroots and friends. @@ -243,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata." #:entry-point entry-point)))) (with-output-to-file "manifest.json" (lambda () - (scm->json (manifest prefix id)))) + (scm->json (manifest prefix id repository)))) (with-output-to-file "repositories" (lambda () - (scm->json (repositories prefix id))))) + (scm->json (repositories prefix id repository))))) (apply invoke "tar" "-cf" image "-C" directory `(,@%tar-determinism-options diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 055d6c95f5..2543f0c0b5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -516,6 +516,18 @@ the image." `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) + (define tag + ;; Compute a meaningful "repository" name, which will show up in + ;; the output of "docker images". + (let ((manifest (profile-manifest #$profile))) + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names))))))) ;drop one entry (setenv "PATH" (string-append #$archiver "/bin")) @@ -524,6 +536,7 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile + #:repository tag #:database #+database #:system (or #$target (utsname:machine (uname))) #:environment environment -- cgit v1.2.3 From 76c0b608219cc1f58decbd85f4a8194337f0558d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 16 Sep 2019 11:16:40 +0200 Subject: import/cran: Export %bioconductor-version. * guix/import/cran.scm (%bioconductor-version): Export it. --- guix/import/cran.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 35caa3e463..e47aff2b12 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -49,6 +49,7 @@ cran-recursive-import %cran-updater %bioconductor-updater + %bioconductor-version cran-package? bioconductor-package? -- cgit v1.2.3 From 41ca406fa54e69f61c55b11ffe5cf465192a907c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 16 Sep 2019 11:23:57 +0200 Subject: build-system/r: Use %bioconductor-version. * guix/build-system/r.scm (bioconductor-uri): Use %bioconductor-version instead of hard-coding the version string. --- guix/build-system/r.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index dd2a9fe8de..936ad974d0 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) + #:use-module ((guix import cran) #:select (%bioconductor-version)) #:use-module (ice-9 match) #:use-module (srfi srfi-26) #:export (%r-build-system-modules @@ -58,8 +59,8 @@ release corresponding to NAME and VERSION." type-url-part "/src/contrib/" name "_" version ".tar.gz") - ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.9" + (string-append "https://bioconductor.org/packages/" + %bioconductor-version type-url-part "/src/contrib/Archive/" name "_" version ".tar.gz")))) -- cgit v1.2.3 From 74e7465c9b3758c1509a3e0dbe575e2014e20f0a Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 16 Sep 2019 14:34:15 +0300 Subject: Revert "build-system/r: Use %bioconductor-version." This reverts commit 41ca406fa54e69f61c55b11ffe5cf465192a907c. This commit breaks 'guix pull', as reported by Hao Chen. --- guix/build-system/r.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 936ad974d0..dd2a9fe8de 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,7 +24,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module ((guix import cran) #:select (%bioconductor-version)) #:use-module (ice-9 match) #:use-module (srfi srfi-26) #:export (%r-build-system-modules @@ -59,8 +58,8 @@ release corresponding to NAME and VERSION." type-url-part "/src/contrib/" name "_" version ".tar.gz") - (string-append "https://bioconductor.org/packages/" - %bioconductor-version + ;; TODO: use %bioconductor-version from (guix import cran) + (string-append "https://bioconductor.org/packages/3.9" type-url-part "/src/contrib/Archive/" name "_" version ".tar.gz")))) -- cgit v1.2.3 From f9c0400392843540a87985a67ffb9fb6e4dbc2fa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Sep 2019 14:55:44 +0200 Subject: guix package: "guix package -f FILE" ensures FILE returns a package. * guix/scripts/package.scm (options->installable): Add clause for 'install option with a non-package object. * tests/guix-package.sh: Add test. --- guix/scripts/package.scm | 6 +++++- tests/guix-package.sh | 11 +++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a43c96516f..21737f43da 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -607,7 +607,11 @@ and upgrades." (let-values (((package output) (specification->package+output spec))) (package->manifest-entry* package output)))) - (_ #f)) + (('install . obj) + (leave (G_ "cannot install non-package object: ~s~%") + obj)) + (_ + #f)) opts)) (fold manifest-transaction-install-entry diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 79d6ec65e4..79e89286f1 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -331,6 +331,17 @@ cat > "$module_dir/package.scm"< "$module_dir/package.scm"< Date: Wed, 18 Sep 2019 22:53:17 +0200 Subject: import: pypi: Refresher recognizes pythonhosted.org source URLs. This is a followup to a5376200541abf8245973e601be246bf65b8b6c7. Since that commit, 'pypi-package?' would return false for most Python packages, and thus "guix refresh python-xxx" would report that no updaters apply to the package. * guix/import/pypi.scm (pypi-package?)[pypi-url?]: Recognize "files.pythonhosted.org" URLs. --- guix/import/pypi.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 9b3d80a02e..354cae9c4c 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -437,7 +437,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (pypi-url? url) (or (string-prefix? "https://pypi.org/" url) (string-prefix? "https://pypi.python.org/" url) - (string-prefix? "https://pypi.org/packages" url))) + (string-prefix? "https://pypi.org/packages" url) + (string-prefix? "https://files.pythonhosted.org/packages" url))) (let ((source-url (and=> (package-source package) origin-uri)) (fetch-method (and=> (package-source package) origin-method))) -- cgit v1.2.3 From ee25048e51dd45ad91a1ad4b0f25f4013843c52b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Sep 2019 22:59:13 +0200 Subject: pull: Work around Ubuntu's 'sudo'. Partly fixes . Reported by Julien Lepiller . * guix/scripts/pull.scm (ensure-default-profile): Do not call 'migrate-generations' when "SUDO_USER" is set. --- guix/scripts/pull.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 54bbaddf30..4b03cea2e3 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -293,8 +293,15 @@ true, display what would be built without actually building it." ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move ;; them to %PROFILE-DIRECTORY. - (unless (string=? %profile-directory - (dirname (canonicalize-profile %user-profile-directory))) + ;; + ;; XXX: Ubuntu's 'sudo' preserves $HOME by default, and thus the second + ;; condition below is always false when one runs "sudo guix pull". As a + ;; workaround, skip this code when $SUDO_USER is set. See + ;; . + (unless (or (getenv "SUDO_USER") + (string=? %profile-directory + (dirname + (canonicalize-profile %user-profile-directory)))) (migrate-generations %user-profile-directory %profile-directory)) ;; Make sure ~/.config/guix/current points to /var/guix/profiles/…. -- cgit v1.2.3 From da551107129d22dfb2a4278a55b702a7340e7f51 Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Wed, 18 Sep 2019 09:52:18 +0200 Subject: scripts: pull: Add options for generation management MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/pull.scm (%options) Add --roll-back, --switch-generation, --delete-generations (process-generation-change): New function (guix-pull): Execute generation management operations * doc/guix.texi: Document the generation management operations Signed-off-by: Ludovic Courtès --- doc/guix.texi | 47 +++++++++++++++++++++++++++++++++++++++++++++-- guix/scripts/pull.scm | 41 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 85 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index da62194a16..0ed59072c9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3673,11 +3673,20 @@ Generation 3 Jun 13 2018 23:31:07 (current) @xref{Invoking guix describe, @command{guix describe}}, for other ways to describe the current status of Guix. -This @code{~/.config/guix/current} profile works like any other profile -created by @command{guix package} (@pxref{Invoking guix package}). That +This @code{~/.config/guix/current} profile works exactly like the profiles +created by @command{guix package} (@pxref{Invoking guix package}). That is, you can list generations, roll back to the previous generation---i.e., the previous Guix---and so on: +@example +$ guix pull --roll-back +switched from generation 3 to 2 +$ guix pull --delete-generations=1 +deleting /var/guix/profiles/per-user/charlie/current-guix-1-link +@end example + +You can also use @command{guix package} (@pxref{Invoking guix package}) +to manage the profile by naming it explicitly: @example $ guix package -p ~/.config/guix/current --roll-back switched from generation 3 to 2 @@ -3724,6 +3733,40 @@ is provided, the subset of generations that match @var{pattern}. The syntax of @var{pattern} is the same as with @code{guix package --list-generations} (@pxref{Invoking guix package}). +@item --roll-back +@cindex rolling back +@cindex undoing transactions +@cindex transactions, undoing +Roll back to the previous @dfn{generation} of @file{~/.config/guix/current}---i.e., +undo the last transaction. + +@item --switch-generation=@var{pattern} +@itemx -S @var{pattern} +@cindex generations +Switch to a particular generation defined by @var{pattern}. + +@var{pattern} may be either a generation number or a number prefixed +with ``+'' or ``-''. The latter means: move forward/backward by a +specified number of generations. For example, if you want to return to +the latest generation after @code{--roll-back}, use +@code{--switch-generation=+1}. + +@item --delete-generations[=@var{pattern}] +@itemx -d [@var{pattern}] +When @var{pattern} is omitted, delete all generations except the current +one. + +This command accepts the same patterns as @option{--list-generations}. +When @var{pattern} is specified, delete the matching generations. When +@var{pattern} specifies a duration, generations @emph{older} than the +specified duration match. For instance, @code{--delete-generations=1m} +deletes generations that are more than one month old. + +If the current generation matches, it is @emph{not} deleted. + +Note that deleting generations prevents rolling back to them. +Consequently, this command must be used with care. + @xref{Invoking guix describe}, for a way to display information about the current generation only. diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 4b03cea2e3..c9835cef34 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -38,7 +38,8 @@ #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) - #:use-module ((guix scripts package) #:select (build-and-use-profile)) + #:use-module ((guix scripts package) #:select (build-and-use-profile + delete-matching-generations)) #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) @@ -91,6 +92,14 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) + (display (G_ " + --roll-back roll back to the previous generation")) + (display (G_ " + -d, --delete-generations[=PATTERN] + delete generations matching PATTERN")) + (display (G_ " + -S, --switch-generation=PATTERN + switch to a generation matching PATTERN")) (display (G_ " -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) (display (G_ " @@ -120,6 +129,18 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (cons `(query list-generations ,arg) result))) + (option '("roll-back") #f #f + (lambda (opt name arg result) + (cons '(generation roll-back) + result))) + (option '(#\S "switch-generation") #t #f + (lambda (opt name arg result) + (cons `(generation switch ,arg) + result))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result) + (cons `(generation delete ,arg) + result))) (option '(#\N "news") #f #f (lambda (opt name arg result) (cons '(query display-news) result))) @@ -505,6 +526,22 @@ list of package changes."))))) (display-profile-news profile #:current-is-newer? #t)))) +(define (process-generation-change opts profile) + "Process a request to change the current generation (roll-back, switch, delete)." + (unless (assoc-ref opts 'dry-run?) + (match (assoc-ref opts 'generation) + (('roll-back) + (with-store store + (roll-back* store profile))) + (('switch pattern) + (let ((number (relative-generation-spec->number profile pattern))) + (if number + (switch-to-generation* profile number) + (leave (G_ "cannot switch to generation '~a'~%") pattern)))) + (('delete pattern) + (with-store store + (delete-matching-generations store profile pattern)))))) + (define (channel-list opts) "Return the list of channels to use. If OPTS specify a channel file, channels are read from there; otherwise, if ~/.config/guix/channels.scm @@ -572,6 +609,8 @@ Use '~/.config/guix/channels.scm' instead.")) (profile (or (assoc-ref opts 'profile) %current-profile))) (cond ((assoc-ref opts 'query) (process-query opts profile)) + ((assoc-ref opts 'generation) + (process-generation-change opts profile)) (else (with-store store (ensure-default-profile) -- cgit v1.2.3 From d2cdef65605b9e14bfa02c3bf1612ab6b62f4a89 Mon Sep 17 00:00:00 2001 From: zimoun Date: Wed, 18 Sep 2019 17:57:57 +0200 Subject: ui: 'relevance' connects regexps with a logical and. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Previously, the logical and connecting the regexps did not output the expected results (introduced in 8874faaaac665100a095ef25e39c9a389f5a397f). * guix/ui.scm (relevance) [score]: Change its arguments. [regexp->score]: New procedure. * tests/ui.scm ("package-relevance"): Add test. Signed-off-by: Ludovic Courtès --- guix/ui.scm | 48 ++++++++++++++++++++++++------------------------ tests/ui.scm | 5 ++++- 2 files changed, 28 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 7920335928..4be31db047 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019 Chris Marusich ;;; Copyright © 2019 Tobias Geerinckx-Rice +;;; Copyright © 2019 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -1281,33 +1282,32 @@ weight of this field in the final score. A score of zero means that OBJ does not match any of REGEXPS. The higher the score, the more relevant OBJ is to REGEXPS." - (define (score str) - (define scores - (map (lambda (regexp) - (fold-matches regexp str 0 - (lambda (m score) - (+ score - (if (string=? (match:substring m) str) - 5 ;exact match - 1))))) - regexps)) - + (define (score regexp str) + (fold-matches regexp str 0 + (lambda (m score) + (+ score + (if (string=? (match:substring m) str) + 5 ;exact match + 1))))) + + (define (regexp->score regexp) + (let ((score-regexp (lambda (str) (score regexp str)))) + (fold (lambda (metric relevance) + (match metric + ((field . weight) + (match (field obj) + (#f relevance) + ((? string? str) + (+ relevance (* (score-regexp str) weight))) + ((lst ...) + (+ relevance (* weight (apply + (map score-regexp lst))))))))) + 0 metrics))) + + (let ((scores (map regexp->score regexps))) ;; Return zero if one of REGEXPS doesn't match. (if (any zero? scores) 0 - (reduce + 0 scores))) - - (fold (lambda (metric relevance) - (match metric - ((field . weight) - (match (field obj) - (#f relevance) - ((? string? str) - (+ relevance (* (score str) weight))) - ((lst ...) - (+ relevance (* weight (apply + (map score lst))))))))) - 0 - metrics)) + (reduce + 0 scores)))) (define %package-metrics ;; Metrics used to compute the "relevance score" of a package against a set diff --git a/tests/ui.scm b/tests/ui.scm index 2138e23369..d8573e88d8 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -267,6 +267,7 @@ Second line" 24)) (gcrypt (specification->package "guile-gcrypt")) (go (specification->package "go")) (gnugo (specification->package "gnugo")) + (libb2 (specification->package "libb2")) (rx (cut make-regexp <> regexp/icase)) (>0 (cut > <> 0)) (=0 zero?)) @@ -283,6 +284,8 @@ Second line" 24)) (=0 (package-relevance go (map rx '("go" "game")))) (>0 (package-relevance gnugo - (map rx '("go" "game"))))))) + (map rx '("go" "game")))) + (>0 (package-relevance libb2 + (map rx '("crypto" "library"))))))) (test-end "ui") -- cgit v1.2.3 From 3fd738f31b3fc6b31e048468980cc20c3d04261d Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Tue, 17 Sep 2019 21:50:36 +0300 Subject: import/github: Check for more version prefixes. * guix/import/github.scm (latest-released-version): Allow the version string to begin with the word 'version'. --- guix/import/github.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index 55ea00a111..df5f6ff32f 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Eric Bavier ;;; Copyright © 2019 Arun Isaac +;;; Copyright © 2019 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -186,7 +187,12 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" (substring tag 0 (+ name-length 1)))) (substring tag (+ name-length 1))) ;; some tags start with a "v" e.g. "v0.25.0" + ;; or with the word "version" e.g. "version.2.1" ;; where some are just the version number + ((string-prefix? "version" tag) + (if (char-set-contains? char-set:digit (string-ref tag 7)) + (substring tag 7) + (substring tag 8))) ((string-prefix? "v" tag) (substring tag 1)) ;; Finally, reject tags that don't start with a digit: -- cgit v1.2.3 From 71507435225f10d8d944ba183cbcc77ef953e0e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Sep 2019 22:26:53 +0200 Subject: inferior: Propagate '&store-protocol-error' error conditions. Until now '&store-protocol-error' conditions raised in the inferior would not be correctly propagated because SRFI-35 records lack a read syntax. Reported at by Carl Dong . * guix/inferior.scm (port->inferior): Import (srfi srfi-34) in the inferior. (inferior-eval-with-store): Define 'error?' and 'error-message'. Wrap call to PROC in 'guard'. Check the response of INFERIOR for a 'store-protocol-error' or a 'result' tag. * tests/inferior.scm ("inferior-eval-with-store, &store-protocol-error"): New test. --- guix/inferior.scm | 31 +++++++++++++++++++++++++++---- tests/inferior.scm | 13 +++++++++++++ 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index fee97750b6..6be30d3f17 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,6 +19,8 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix utils) #:select (%current-system source-properties->location @@ -29,7 +31,8 @@ #:select (store-connection-socket store-connection-major-version store-connection-minor-version - store-lift)) + store-lift + &store-protocol-error)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) #:use-module (guix gexp) @@ -151,6 +154,7 @@ inferior." (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (ice-9 match)) result) + (inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -462,7 +466,13 @@ thus be the code of a one-argument procedure that accepts a store." (listen socket 1024) (send-inferior-request `(let ((proc ,code) - (socket (socket AF_UNIX SOCK_STREAM 0))) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (error? (if (defined? 'store-protocol-error?) + store-protocol-error? + nix-protocol-error?)) + (error-message (if (defined? 'store-protocol-error-message) + store-protocol-error-message + nix-protocol-error-message))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly @@ -475,7 +485,13 @@ thus be the code of a one-argument procedure that accepts a store." (dynamic-wind (const #t) (lambda () - (proc store)) + ;; Serialize '&store-protocol-error' conditions. The + ;; exception serialization mechanism that + ;; 'read-repl-response' expects is unsuitable for SRFI-35 + ;; error conditions, hence this special case. + (guard (c ((error? c) + `(store-protocol-error ,(error-message c)))) + `(result ,(proc store)))) (lambda () (close-connection store) (close-port socket))))) @@ -484,7 +500,14 @@ thus be the code of a one-argument procedure that accepts a store." ((client . address) (proxy client (store-connection-socket store)))) (close-port socket) - (read-inferior-response inferior))))) + + (match (read-inferior-response inferior) + (('store-protocol-error message) + (raise (condition + (&store-protocol-error (message message) + (status 1))))) + (('result result) + result)))))) (define* (inferior-package-derivation store package #:optional diff --git a/tests/inferior.scm b/tests/inferior.scm index 71ebf8f59b..f54b6d6037 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -186,6 +187,18 @@ (add-text-to-store store "foo" "Hello, world!"))))) +(test-assert "inferior-eval-with-store, &store-protocol-error" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) + "invalid character"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "we|rd/?!@" + "uh uh"))) + #f))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From aeb51370da7c854e8167066df9b138e15d7363e6 Mon Sep 17 00:00:00 2001 From: zimoun Date: Thu, 19 Sep 2019 19:24:42 +0200 Subject: guix package: Add 'guix show' alias. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/show.scm: New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Add it. * tests/guix-package-aliases.sh: Add test. * doc/guix.texi (Invoking guix package): Document it and use it in a example. Signed-off-by: Ludovic Courtès --- Makefile.am | 1 + doc/guix.texi | 8 ++++-- guix/scripts/show.scm | 67 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/guix-package-aliases.sh | 4 +++ 5 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 guix/scripts/show.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 93d18d7df6..f71ea77671 100644 --- a/Makefile.am +++ b/Makefile.am @@ -241,6 +241,7 @@ MODULES = \ guix/scripts/remove.scm \ guix/scripts/upgrade.scm \ guix/scripts/search.scm \ + guix/scripts/show.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 0ed59072c9..af1903f6ff 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2657,7 +2657,9 @@ For your convenience, we also provide the following aliases: @item @command{guix remove} is an alias for @command{guix package -r}, @item -and @command{guix upgrade} is an alias for @command{guix package -u}. +@command{guix upgrade} is an alias for @command{guix package -u}, +@item +and @command{guix show} is an alias for @command{guix package --show=}. @end itemize These aliases are less expressive than @command{guix package} and provide @@ -3020,9 +3022,9 @@ version: 3.3.5 @end example You may also specify the full name of a package to only get details about a -specific version of it: +specific version of it (this time using the @command{guix show} alias): @example -$ guix package --show=python@@3.4 | recsel -p name,version +$ guix show python@@3.4 | recsel -p name,version name: python version: 3.4.3 @end example diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm new file mode 100644 index 0000000000..94f0559358 --- /dev/null +++ b/guix/scripts/show.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Simon Tournier +;;; +;;; 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 . + +(define-module (guix scripts show) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-show)) + +(define (show-help) + (display (G_ "Usage: guix show [OPTION] PACKAGE... +Show details about PACKAGE.")) + (display (G_" +This is an alias for 'guix package --show='.\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix show"))))) + +(define (guix-show . args) + (define (handle-argument arg result) + ;; Treat all non-option arguments as regexps. + (cons `(query show ,arg) + result)) + + (define opts + (args-fold* args %options + (lambda (opt name arg . rest) + (leave (G_ "~A: unrecognized option~%") name)) + handle-argument + '())) + + (unless (assoc-ref opts 'query) + (leave (G_ "missing arguments: no package to show~%"))) + + (guix-package* opts)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 8b556ac0ec..f629034d61 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -47,6 +47,7 @@ guix/scripts/install.scm guix/scripts/remove.scm guix/scripts/upgrade.scm guix/scripts/search.scm +guix/scripts/show.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 5c68664093..9c038b99a5 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -58,3 +58,7 @@ if guix remove -i guile-bootstrap -p "$profile" --bootstrap then false; else true; fi guix search '\' game | grep '^name: gnubg' + +guix show --version +guix show guile +guix show python@3 | grep "^name: python" -- cgit v1.2.3 From 660dbe65641851aa99b810e4ae065a5f72dc37d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Sep 2019 23:02:30 +0200 Subject: guix package: '--show' ignores deprecated packages. * guix/scripts/package.scm (process-query) <'show>: Remove superseded packages. * tests/guix-package-aliases.sh: Add test. --- guix/scripts/package.scm | 3 ++- tests/guix-package-aliases.sh | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 21737f43da..f03741aa9e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -764,7 +764,8 @@ processed, #f otherwise." (('show requested-name) (let-values (((name version) (package-name->name+version requested-name))) - (match (find-packages-by-name name version) + (match (remove package-superseded + (find-packages-by-name name version)) (() (leave (G_ "~a~@[@~a~]: package not found~%") name version)) (packages diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 9c038b99a5..4beed2e5b7 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -62,3 +62,6 @@ guix search '\' game | grep '^name: gnubg' guix show --version guix show guile guix show python@3 | grep "^name: python" + +# "python@2" exists but is deprecated; make sure it doesn't show up. +if guix show python@2; then false; else true; fi -- cgit v1.2.3 From 961b95c985991ed4421c2419c22026eb0153c1ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Sep 2019 14:59:58 +0200 Subject: pull: '--news' shows the list of channels added or removed. * guix/scripts/pull.scm (display-channel, channel=?) (display-channel-news, display-news): New procedures. (process-query): Call 'display-news' instead of 'display-profile-news'. --- guix/scripts/pull.scm | 61 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 57 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c9835cef34..472947bb3a 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -213,6 +213,62 @@ newest generation of PROFILE." (G_ "New in this revision:\n"))))) (_ #t))) +(define (display-channel channel) + "Display information about CHANNEL." + (format (current-error-port) + ;; TRANSLATORS: This describes a "channel"; the first placeholder is + ;; the channel name (e.g., "guix") and the second placeholder is its + ;; URL. + (G_ " ~a at ~a~%") + (channel-name channel) + (channel-url channel))) + +(define (channel=? channel1 channel2) + "Return true if CHANNEL1 and CHANNEL2 are the same for all practical +purposes." + ;; Assume that the URL matters less than the name. + (eq? (channel-name channel1) (channel-name channel2))) + +(define (display-channel-news profile) + "Display news about the channels of PROFILE " + (define previous + (and=> (relative-generation profile -1) + (cut generation-file-name profile <>))) + + (when previous + (let ((old-channels (profile-channels previous)) + (new-channels (profile-channels profile))) + (and (pair? old-channels) (pair? new-channels) + (begin + (match (lset-difference channel=? new-channels old-channels) + (() + #t) + (new + (let ((count (length new))) + (format (current-error-port) + (N_ " ~*One new channel:~%" + " ~a new channels:~%" count) + count) + (for-each display-channel new)))) + (match (lset-difference channel=? old-channels new-channels) + (() + #t) + (removed + (let ((count (length removed))) + (format (current-error-port) + (N_ " ~*One channel removed:~%" + " ~a channels removed:~%" count) + count) + (for-each display-channel removed))))))))) + +(define (display-news profile) + ;; Display profile news, with the understanding that this process represents + ;; the newest generation. + (display-profile-news profile + #:current-is-newer? #t) + + (display-channel-news profile)) + (define* (build-and-install instances profile #:key use-substitutes? verbose? dry-run?) "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is @@ -521,10 +577,7 @@ list of package changes."))))) ((numbers ...) (list-generations profile numbers))))))) (('display-news) - ;; Display profile news, with the understanding that this process - ;; represents the newest generation. - (display-profile-news profile - #:current-is-newer? #t)))) + (display-news profile)))) (define (process-generation-change opts profile) "Process a request to change the current generation (roll-back, switch, delete)." -- cgit v1.2.3 From a78dcb3d599cc84b347578940bb0fd44b1ad50b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Sep 2019 17:46:34 +0200 Subject: git: 'update-cached-checkout' avoids network access when unnecessary. * guix/git.scm (reference-available?): New procedure. (update-cached-checkout): Avoid call to 'remote-fetch' when REPOSITORY already contains REF. --- guix/git.scm | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index de98fed40c..92a7353b5a 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -220,6 +220,21 @@ dynamic extent of EXP." (G_ "Support for submodules is missing; \ please upgrade Guile-Git.~%")))) +(define (reference-available? repository ref) + "Return true if REF, a reference such as '(commit . \"cabba9e\"), is +definitely available in REPOSITORY, false otherwise." + (match ref + (('commit . commit) + (catch 'git-error + (lambda () + (->bool (commit-lookup repository (string->oid commit)))) + (lambda (key error . rest) + (if (= GIT_ENOTFOUND (git-error-code error)) + #f + (apply throw key error rest))))) + (_ + #f))) + (define* (update-cached-checkout url #:key (ref '(branch . "master")) @@ -254,7 +269,8 @@ When RECURSIVE? is true, check out submodules as well, if any." (repository-open cache-directory) (clone* url cache-directory)))) ;; Only fetch remote if it has not been cloned just before. - (when cache-exists? + (when (and cache-exists? + (not (reference-available? repository ref))) (remote-fetch (remote-lookup repository "origin"))) (when recursive? (update-submodules repository #:log-port log-port)) -- cgit v1.2.3 From 873f6f1334ab06a69e768a8aea0054404237542f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Sep 2019 17:54:06 +0200 Subject: git: Add 'commit-difference'. * guix/git.scm (commit-closure, commit-difference): New procedures. * guix/tests/git.scm, tests/git.scm: New files. * Makefile.am (dist_noinst_DATA): Add guix/tests/git.scm. (SCM_TESTS): Add tests/git.scm. --- .dir-locals.el | 1 + Makefile.am | 6 +++- guix/git.scm | 40 ++++++++++++++++++++++ guix/tests/git.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/git.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 242 insertions(+), 1 deletion(-) create mode 100644 guix/tests/git.scm create mode 100644 tests/git.scm (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 228685a69f..22aac2c402 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -90,6 +90,7 @@ (eval . (put 'eventually 'scheme-indent-function 1)) (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1)) + (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2)) ;; This notably allows '(' in Paredit to not insert a space when the ;; preceding symbol is one of these. diff --git a/Makefile.am b/Makefile.am index f71ea77671..658f03bd54 100644 --- a/Makefile.am +++ b/Makefile.am @@ -307,7 +307,10 @@ STORE_MODULES = \ MODULES += $(STORE_MODULES) # Internal modules with test suite support. -dist_noinst_DATA = guix/tests.scm guix/tests/http.scm +dist_noinst_DATA = \ + guix/tests.scm \ + guix/tests/http.scm \ + guix/tests/git.scm # Auxiliary files for packages. AUX_FILES = \ @@ -391,6 +394,7 @@ SCM_TESTS = \ tests/file-systems.scm \ tests/gem.scm \ tests/gexp.scm \ + tests/git.scm \ tests/glob.scm \ tests/gnu-maintenance.scm \ tests/grafts.scm \ diff --git a/guix/git.scm b/guix/git.scm index 92a7353b5a..d7dddde3a7 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -28,6 +28,7 @@ #:use-module (guix utils) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix sets) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -37,8 +38,10 @@ #:export (%repository-cache-directory honor-system-x509-certificates! + with-repository update-cached-checkout latest-repository-commit + commit-difference git-checkout git-checkout? @@ -339,6 +342,43 @@ Log progress and checkout info to LOG-PORT." (set-exception-printer! 'git-error print-git-error) + +;;; +;;; Commit difference. +;;; + +(define (commit-closure commit) + "Return the closure of COMMIT as a set." + (let loop ((commits (list commit)) + (visited (setq))) + (match commits + (() + visited) + ((head . tail) + (if (set-contains? visited head) + (loop tail visited) + (loop (append (commit-parents head) tail) + (set-insert head visited))))))) + +(define (commit-difference new old) + "Return the list of commits between NEW and OLD, where OLD is assumed to be +an ancestor of NEW. + +Essentially, this computes the set difference between the closure of NEW and +that of OLD." + (let loop ((commits (list new)) + (result '()) + (visited (commit-closure old))) + (match commits + (() + (reverse result)) + ((head . tail) + (if (set-contains? visited head) + (loop tail result visited) + (loop (append (commit-parents head) tail) + (cons head result) + (set-insert head visited))))))) + ;;; ;;; Checkouts. diff --git a/guix/tests/git.scm b/guix/tests/git.scm new file mode 100644 index 0000000000..52abe77c83 --- /dev/null +++ b/guix/tests/git.scm @@ -0,0 +1,97 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 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 . + +(define-module (guix tests git) + #:use-module (git) + #:use-module (guix utils) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 control) + #:export (git-command + with-temporary-git-repository + find-commit)) + +(define git-command + (make-parameter "git")) + +(define (populate-git-repository directory directives) + "Initialize a new Git checkout and repository in DIRECTORY and apply +DIRECTIVES. Each element of DIRECTIVES is an sexp like: + + (add \"foo.txt\" \"hi!\") + +Return DIRECTORY on success." + + ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do + ;; all this, so resort to the "git" command. + (define (git command . args) + (apply invoke (git-command) "-C" directory + command args)) + + (mkdir-p directory) + (git "init") + + (let loop ((directives directives)) + (match directives + (() + directory) + ((('add file contents) rest ...) + (let ((file (string-append directory "/" file))) + (mkdir-p (dirname file)) + (call-with-output-file file + (lambda (port) + (display contents port))) + (git "add" file) + (loop rest))) + ((('commit text) rest ...) + (git "commit" "-m" text) + (loop rest)) + ((('branch name) rest ...) + (git "branch" name) + (loop rest)) + ((('checkout branch) rest ...) + (git "checkout" branch) + (loop rest)) + ((('merge branch message) rest ...) + (git "merge" branch "-m" message) + (loop rest))))) + +(define (call-with-temporary-git-repository directives proc) + (call-with-temporary-directory + (lambda (directory) + (populate-git-repository directory directives) + (proc directory)))) + +(define-syntax-rule (with-temporary-git-repository directory + directives exp ...) + "Evaluate EXP in a context where DIRECTORY contains a checkout populated as +per DIRECTIVES." + (call-with-temporary-git-repository directives + (lambda (directory) + exp ...))) + +(define (find-commit repository message) + "Return the commit in REPOSITORY whose message includes MESSAGE, a string." + (let/ec return + (fold-commits (lambda (commit _) + (and (string-contains (commit-message commit) + message) + (return commit))) + #f + repository) + (error "commit not found" message))) diff --git a/tests/git.scm b/tests/git.scm new file mode 100644 index 0000000000..8ba10ece51 --- /dev/null +++ b/tests/git.scm @@ -0,0 +1,99 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 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 . + +(define-module (test-git) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests git) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +;; Test the (guix git) tools. + +(test-begin "git") + +;; 'with-temporary-git-repository' relies on the 'git' command. +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, linear history" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (add "d.txt" "D") + (commit "fourth commit")) + (with-repository directory repository + (let ((commit1 (find-commit repository "first")) + (commit2 (find-commit repository "second")) + (commit3 (find-commit repository "third")) + (commit4 (find-commit repository "fourth"))) + (and (lset= eq? (commit-difference commit4 commit1) + (list commit2 commit3 commit4)) + (lset= eq? (commit-difference commit4 commit2) + (list commit3 commit4)) + (equal? (commit-difference commit3 commit2) + (list commit3)) + + ;; COMMIT4 is not an ancestor of COMMIT1 so we should get the + ;; empty list. + (null? (commit-difference commit1 commit4))))))) + +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, fork" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (branch "devel") + (checkout "devel") + (add "devel/1.txt" "1") + (commit "first devel commit") + (add "devel/2.txt" "2") + (commit "second devel commit") + (checkout "master") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (merge "devel" "merge") + (add "d.txt" "D") + (commit "fourth commit")) + (with-repository directory repository + (let ((master1 (find-commit repository "first commit")) + (master2 (find-commit repository "second commit")) + (master3 (find-commit repository "third commit")) + (master4 (find-commit repository "fourth commit")) + (devel1 (find-commit repository "first devel")) + (devel2 (find-commit repository "second devel")) + (merge (find-commit repository "merge"))) + (and (equal? (commit-difference master4 merge) + (list master4)) + (lset= eq? (commit-difference master3 master1) + (list master3 master2)) + (lset= eq? (commit-difference devel2 master1) + (list devel2 devel1)) + + ;; The merge occurred between MASTER2 and MASTER4 so here we + ;; expect to see all the commits from the "devel" branch in + ;; addition to those on "master". + (lset= eq? (commit-difference master4 master2) + (list master4 merge master3 devel1 devel2))))))) + +(test-end "git") -- cgit v1.2.3 From 8ba7fd3cd6962f1c1aaaa5f71eed7f9222094f25 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Sep 2019 23:16:54 +0200 Subject: channels: Add support for a news file. * guix/channels.scm ()[news-file]: New field. (read-channel-metadata): Set the 'news-file' field. (read-channel-metadata-from-source): Likewise. (, ): New record types. (sexp->channel-news-entry, read-channel-news) (channel-news-for-commit): New procedures. * guix/tests/git.scm (populate-git-repository): For 'add', allow CONTENTS to be a procedure. * tests/channels.scm ("channel-news, no news") ("channel-news, one entry"): New tests. * doc/guix.texi (Channels): Document it. --- doc/guix.texi | 62 +++++++++++++++++++++++++++ guix/channels.scm | 123 +++++++++++++++++++++++++++++++++++++++++++++++++---- guix/tests/git.scm | 7 ++- tests/channels.scm | 99 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 282 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index af1903f6ff..cd108faa8f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3991,6 +3991,68 @@ add a meta-data file @file{.guix-channel} that contains: (directory "guix")) @end lisp +@cindex news, for channels +@subsection Writing Channel News + +Channel authors may occasionally want to communicate to their users +information about important changes in the channel. You'd send them all +an email, but that's not convenient. + +Instead, channels can provide a @dfn{news file}; when the channel users +run @command{guix pull}, that news file is automatically read and +@command{guix pull --news} can display the announcements that correspond +to the new commits that have been pulled, if any. + +To do that, channel authors must first declare the name of the news file +in their @file{.guix-channel} file: + +@lisp +(channel + (version 0) + (news-file "etc/news.txt")) +@end lisp + +The news file itself, @file{etc/news.txt} in this example, must look +something like this: + +@lisp +(channel-news + (version 0) + (entry (commit "d894ab8e9bfabcefa6c49d9ba2e834dd5a73a300") + (title (en "Fixed terrible bug") + (fr "Oh la la")) + (body (en "@@emph@{Good news@}! It's fixed!") + (eo "Certe ĝi pli bone funkcias nun!"))) + (entry (commit "bdcabe815cd28144a2d2b4bc3c5057b051fa9906") + (title (en "Added a great package") + (ca "Què vol dir guix?")) + (body (en "Don't miss the @@code@{hello@} package!")))) +@end lisp + +The file consists of a list of @dfn{news entries}. Each entry is +associated with a commit: it describes changes made in this commit, +possibly in preceding commits as well. Users see entries only the first +time they obtain the commit the entry refers to. + +The @code{title} field should be a one-line summary while @code{body} +can be arbitrarily long, and both can contain Texinfo markup +(@pxref{Overview,,, texinfo, GNU Texinfo}). Both the title and body are +a list of language tag/message tuples, which allows @command{guix pull} +to display news in the language that corresponds to the user's locale. + +If you want to translate news using a gettext-based workflow, you can +extract translatable strings with @command{xgettext} (@pxref{xgettext +Invocation,,, gettext, GNU Gettext Utilities}). For example, assuming +you write news entries in English first, the command below creates a PO +file containing the strings to translate: + +@example +xgettext -o news.po -l scheme -ken etc/news.scm +@end example + +To sum up, yes, you could use your channel as a blog. But beware, this +is @emph{not quite} what your users might expect. + @subsection Replicating Guix @cindex pinning, channels diff --git a/guix/channels.scm b/guix/channels.scm index ebb2cacbc7..0dadba616f 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix channels) + #:use-module (git) #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) @@ -29,6 +30,7 @@ #:use-module (guix derivations) #:use-module (guix combinators) #:use-module (guix diagnostics) + #:use-module (guix sets) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -67,7 +69,14 @@ %channel-profile-hooks channel-instances->derivation - profile-channels)) + profile-channels + + channel-news-entry? + channel-news-entry-commit + channel-news-entry-title + channel-news-entry-body + + channel-news-for-commit)) ;;; Commentary: ;;; @@ -110,10 +119,11 @@ (checkout channel-instance-checkout)) (define-record-type - (channel-metadata directory dependencies) + (channel-metadata directory dependencies news-file) channel-metadata? (directory channel-metadata-directory) ;string with leading slash - (dependencies channel-metadata-dependencies)) ;list of + (dependencies channel-metadata-dependencies) ;list of + (news-file channel-metadata-news-file)) ;string | #f (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for @@ -129,12 +139,13 @@ if valid metadata could not be read from PORT." (match (read port) (('channel ('version 0) properties ...) (let ((directory (and=> (assoc-ref properties 'directory) first)) - (dependencies (or (assoc-ref properties 'dependencies) '()))) + (dependencies (or (assoc-ref properties 'dependencies) '())) + (news-file (and=> (assoc-ref properties 'news-file) first))) (channel-metadata - (cond ((not directory) "/") + (cond ((not directory) "/") ;directory ((string-prefix? "/" directory) directory) (else (string-append "/" directory))) - (map (lambda (item) + (map (lambda (item) ;dependencies (let ((get (lambda* (key #:optional default) (or (and=> (assoc-ref item key) first) default)))) (and-let* ((name (get 'name)) @@ -145,7 +156,8 @@ if valid metadata could not be read from PORT." (branch branch) (url url) (commit (get 'commit)))))) - dependencies)))) + dependencies) + news-file))) ;news-file ((and ('channel ('version version) _ ...) sexp) (raise (condition (&message (message "unsupported '.guix-channel' version")) @@ -169,7 +181,7 @@ doesn't exist." read-channel-metadata)) (lambda args (if (= ENOENT (system-error-errno args)) - (channel-metadata "/" '()) + (channel-metadata "/" '() #f) (apply throw args))))) (define (channel-instance-metadata instance) @@ -560,3 +572,98 @@ PROFILE is not a profile created by 'guix pull', return the empty list." ;; Show most recently installed packages last. (reverse (manifest-entries (profile-manifest profile))))) + + +;;; +;;; News. +;;; + +;; Channel news. +(define-record-type + (channel-news entries) + channel-news? + (entries channel-news-entries)) ;list of + +;; News entry, associated with a specific commit of the channel. +(define-record-type + (channel-news-entry commit title body) + channel-news-entry? + (commit channel-news-entry-commit) ;hex string + (title channel-news-entry-title) ;list of language tag/string pairs + (body channel-news-entry-body)) ;list of language tag/string pairs + +(define (sexp->channel-news-entry entry) + "Return the record corresponding to ENTRY, an sexp." + (define (pair language message) + (cons (symbol->string language) message)) + + (match entry + (('entry ('commit commit) + ('title ((? symbol? title-tags) (? string? titles)) ...) + ('body ((? symbol? body-tags) (? string? bodies)) ...) + _ ...) + (channel-news-entry commit + (map pair title-tags titles) + (map pair body-tags bodies))) + (_ + (raise (condition + (&message (message "invalid channel news entry")) + (&error-location + (location (source-properties->location + (source-properties entry))))))))) + +(define (read-channel-news port) + "Read a channel news feed from PORT and return it as a +record." + (match (false-if-exception (read port)) + (('channel-news ('version 0) entries ...) + (channel-news (map sexp->channel-news-entry entries))) + (('channel-news ('version version) _ ...) + ;; This is an unsupported version from the future. There's nothing wrong + ;; with that (the user may simply need to upgrade the 'guix' channel to + ;; be able to read it), so silently ignore it. + (channel-news '())) + (#f + (raise (condition + (&message (message "syntactically invalid channel news file"))))) + (sexp + (raise (condition + (&message (message "invalid channel news file")) + (&error-location + (location (source-properties->location + (source-properties sexp))))))))) + +(define* (channel-news-for-commit channel new #:optional old) + "Return a list of for CHANNEL between commits OLD and +NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." + (catch 'git-error + (lambda () + (let* ((checkout (update-cached-checkout (channel-url channel) + #:ref `(commit . ,new))) + (metadata (read-channel-metadata-from-source checkout)) + (news-file (channel-metadata-news-file metadata)) + (news-file (and news-file + (string-append checkout "/" news-file)))) + (if (and news-file (file-exists? news-file)) + (let ((entries (channel-news-entries (call-with-input-file news-file + read-channel-news)))) + (if old + (with-repository checkout repository + (let* ((new (commit-lookup repository (string->oid new))) + (old (commit-lookup repository (string->oid old))) + (commits (list->set + (map (compose oid->string commit-id) + (commit-difference new old))))) + (filter (lambda (entry) + (set-contains? commits + (channel-news-entry-commit entry))) + entries))) + entries)) + '()))) + (lambda (key error . rest) + ;; If commit NEW or commit OLD cannot be found, then something must be + ;; wrong (for example, the history of CHANNEL was rewritten and these + ;; commits no longer exist upstream), so quietly return the empty list. + (if (= GIT_ENOTFOUND (git-error-code error)) + '() + (apply throw key error rest))))) diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 52abe77c83..9d5b1ae321 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -18,6 +18,7 @@ (define-module (guix tests git) #:use-module (git) + #:use-module ((guix git) #:select (with-repository)) #:use-module (guix utils) #:use-module (guix build utils) #:use-module (ice-9 match) @@ -55,7 +56,11 @@ Return DIRECTORY on success." (mkdir-p (dirname file)) (call-with-output-file file (lambda (port) - (display contents port))) + (display (if (string? contents) + contents + (with-repository directory repository + (contents repository))) + port))) (git "add" file) (loop rest))) ((('commit text) rest ...) diff --git a/tests/channels.scm b/tests/channels.scm index e83b5437d3..58101bcb72 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -28,6 +28,10 @@ #:use-module (guix gexp) #:use-module ((guix utils) #:select (error-location? error-location location-line)) + #:use-module ((guix build utils) #:select (which)) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests git) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -246,4 +250,99 @@ (depends? drv3 (list drv2 drv0) (list)))))))) +(unless (which (git-command)) (test-skip 1)) +(test-equal "channel-news, no news" + '() + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "the commit")) + (with-repository directory repository + (let ((channel (channel (url (string-append "file://" directory)) + (name 'foo))) + (latest (reference-name->oid repository "HEAD"))) + (channel-news-for-commit channel (oid->string latest)))))) + +(unless (which (git-command)) (test-skip 1)) +(test-assert "channel-news, one entry" + (with-temporary-git-repository directory + `((add ".guix-channel" + ,(object->string + '(channel (version 0) + (news-file "news.scm")))) + (commit "first commit") + (add "src/a.txt" "A") + (commit "second commit") + (add "news.scm" + ,(lambda (repository) + (let ((previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (commit ,(oid->string previous)) + (title (en "New file!") + (eo "Nova dosiero!")) + (body (en "Yeah, a.txt.")))))))) + (commit "third commit") + (add "src/b.txt" "B") + (commit "fourth commit") + (add "news.scm" + ,(lambda (repository) + (let ((second + (commit-id + (find-commit repository "second commit"))) + (previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (commit ,(oid->string previous)) + (title (en "Another file!")) + (body (en "Yeah, b.txt."))) + (entry (commit ,(oid->string second)) + (title (en "Old news.") + (eo "Malnovaĵoj.")) + (body (en "For a.txt")))))))) + (commit "fifth commit")) + (with-repository directory repository + (define (find-commit* message) + (oid->string (commit-id (find-commit repository message)))) + + (let ((channel (channel (url (string-append "file://" directory)) + (name 'foo))) + (commit1 (find-commit* "first commit")) + (commit2 (find-commit* "second commit")) + (commit3 (find-commit* "third commit")) + (commit4 (find-commit* "fourth commit")) + (commit5 (find-commit* "fifth commit"))) + ;; First try fetching all the news up to a given commit. + (and (null? (channel-news-for-commit channel commit2)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5)) + (list commit2 commit4)) + (lset= equal? + (map channel-news-entry-title + (channel-news-for-commit channel commit5)) + '((("en" . "Another file!")) + (("en" . "Old news.") ("eo" . "Malnovaĵoj.")))) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit3)) + (list commit2)) + + ;; Now fetch news entries that apply to a commit range. + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit3 commit1)) + (list commit2)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5 commit3)) + (list commit4)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5 commit1)) + (list commit4 commit2))))))) + (test-end "channels") -- cgit v1.2.3 From 9719e8d37aaa63e1c8f9d4ab1e28d49e2e56d85b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Sep 2019 21:29:30 +0200 Subject: channels: Allow news entries to refer to a tag. Suggested by Ricardo Wurmus . * guix/channels.scm ()[tag]: New field. (sexp->channel-news-entry): Accept either 'commit' or 'tag' in 'entry' forms. (resolve-channel-news-entry-tag): New procedure. (channel-news-for-commit): Move 'with-repository' form one level higher. Call 'resolve-channel-news-entry-tag' on all the news entries. * guix/tests/git.scm (populate-git-repository): Add clause for 'tag'. * tests/channels.scm ("channel-news, one entry"): Create a tag and add an entry with a tag. Check that the tag is resolved and also visible in the record. * doc/guix.texi (Channels): Mention tags in news entries. --- doc/guix.texi | 8 ++++---- guix/channels.scm | 42 ++++++++++++++++++++++++++++++++---------- guix/tests/git.scm | 3 +++ tests/channels.scm | 9 +++++++-- 4 files changed, 46 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index cd108faa8f..33bf08e9dd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4018,7 +4018,7 @@ something like this: @lisp (channel-news (version 0) - (entry (commit "d894ab8e9bfabcefa6c49d9ba2e834dd5a73a300") + (entry (tag "the-bug-fix") (title (en "Fixed terrible bug") (fr "Oh la la")) (body (en "@@emph@{Good news@}! It's fixed!") @@ -4030,9 +4030,9 @@ something like this: @end lisp The file consists of a list of @dfn{news entries}. Each entry is -associated with a commit: it describes changes made in this commit, -possibly in preceding commits as well. Users see entries only the first -time they obtain the commit the entry refers to. +associated with a commit or tag: it describes changes made in this +commit, possibly in preceding commits as well. Users see entries only +the first time they obtain the commit the entry refers to. The @code{title} field should be a one-line summary while @code{body} can be arbitrarily long, and both can contain Texinfo markup diff --git a/guix/channels.scm b/guix/channels.scm index 0dadba616f..4e6e7090ac 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -40,6 +40,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:autoload (guix self) (whole-package make-config.scm) @@ -73,6 +74,7 @@ channel-news-entry? channel-news-entry-commit + channel-news-entry-tag channel-news-entry-title channel-news-entry-body @@ -586,9 +588,10 @@ PROFILE is not a profile created by 'guix pull', return the empty list." ;; News entry, associated with a specific commit of the channel. (define-record-type - (channel-news-entry commit title body) + (channel-news-entry commit tag title body) channel-news-entry? - (commit channel-news-entry-commit) ;hex string + (commit channel-news-entry-commit) ;hex string | #f + (tag channel-news-entry-tag) ;#f | string (title channel-news-entry-title) ;list of language tag/string pairs (body channel-news-entry-body)) ;list of language tag/string pairs @@ -598,11 +601,12 @@ PROFILE is not a profile created by 'guix pull', return the empty list." (cons (symbol->string language) message)) (match entry - (('entry ('commit commit) + (('entry ((and (or 'commit 'tag) type) commit-or-tag) ('title ((? symbol? title-tags) (? string? titles)) ...) ('body ((? symbol? body-tags) (? string? bodies)) ...) _ ...) - (channel-news-entry commit + (channel-news-entry (and (eq? type 'commit) commit-or-tag) + (and (eq? type 'tag) commit-or-tag) (map pair title-tags titles) (map pair body-tags bodies))) (_ @@ -633,6 +637,20 @@ record." (location (source-properties->location (source-properties sexp))))))))) +(define (resolve-channel-news-entry-tag repository entry) + "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup +ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to +the field its 'tag' refers to. A 'git-error' exception is raised if the tag +cannot be found." + (if (channel-news-entry-commit entry) + entry + (let* ((tag (channel-news-entry-tag entry)) + (reference (string-append "refs/tags/" tag)) + (oid (reference-name->oid repository reference))) + (channel-news-entry (oid->string oid) tag + (channel-news-entry-title entry) + (channel-news-entry-body entry))))) + (define* (channel-news-for-commit channel new #:optional old) "Return a list of for CHANNEL between commits OLD and NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." @@ -645,10 +663,14 @@ NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." (news-file (and news-file (string-append checkout "/" news-file)))) (if (and news-file (file-exists? news-file)) - (let ((entries (channel-news-entries (call-with-input-file news-file - read-channel-news)))) - (if old - (with-repository checkout repository + (with-repository checkout repository + (let* ((news (call-with-input-file news-file + read-channel-news)) + (entries (map (lambda (entry) + (resolve-channel-news-entry-tag repository + entry)) + (channel-news-entries news)))) + (if old (let* ((new (commit-lookup repository (string->oid new))) (old (commit-lookup repository (string->oid old))) (commits (list->set @@ -657,8 +679,8 @@ NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." (filter (lambda (entry) (set-contains? commits (channel-news-entry-commit entry))) - entries))) - entries)) + entries)) + entries))) '()))) (lambda (key error . rest) ;; If commit NEW or commit OLD cannot be found, then something must be diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 9d5b1ae321..21573ac14e 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -66,6 +66,9 @@ Return DIRECTORY on success." ((('commit text) rest ...) (git "commit" "-m" text) (loop rest)) + ((('tag name) rest ...) + (git "tag" name) + (loop rest)) ((('branch name) rest ...) (git "branch" name) (loop rest)) diff --git a/tests/channels.scm b/tests/channels.scm index 58101bcb72..f5a7955483 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -272,6 +272,7 @@ (commit "first commit") (add "src/a.txt" "A") (commit "second commit") + (tag "tag-for-first-news-entry") (add "news.scm" ,(lambda (repository) (let ((previous @@ -299,7 +300,7 @@ (entry (commit ,(oid->string previous)) (title (en "Another file!")) (body (en "Yeah, b.txt."))) - (entry (commit ,(oid->string second)) + (entry (tag "tag-for-first-news-entry") (title (en "Old news.") (eo "Malnovaĵoj.")) (body (en "For a.txt")))))))) @@ -343,6 +344,10 @@ (lset= string=? (map channel-news-entry-commit (channel-news-for-commit channel commit5 commit1)) - (list commit4 commit2))))))) + (list commit4 commit2)) + (lset= equal? + (map channel-news-entry-tag + (channel-news-for-commit channel commit5 commit1)) + '(#f "tag-for-first-news-entry"))))))) (test-end "channels") -- cgit v1.2.3 From a725504a3a2f855c6a618e9b4cd222df91901113 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Sep 2019 17:54:05 +0200 Subject: ui: Add 'current-message-language'. * guix/ui.scm (%default-message-language): New variable. (current-message-language): New procedure. --- guix/ui.scm | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 4be31db047..069d542131 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -121,6 +121,10 @@ roll-back* switch-to-generation* delete-generation* + + %default-message-language + current-message-language + run-guix-command run-guix guix-main)) @@ -428,6 +432,20 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." report them in a user-friendly way." (call-with-unbound-variable-handling (lambda () exp ...))) +(define %default-message-language + ;; Default language to use for messages. + (make-parameter "en")) + +(define (current-message-language) + "Return the language used for messages according to the current locale. +Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The +result is an ISO-639-2 language code such as \"ar\", without the territory +part." + (let ((locale (setlocale LC_MESSAGES))) + (match (string-index locale #\_) + (#f locale) + (index (string-take locale index))))) + (define (install-locale) "Install the current locale settings." (catch 'system-error -- cgit v1.2.3 From 7faffdc2d53b982d8443c376d6ed2f41a13b3f36 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Sep 2019 17:57:10 +0200 Subject: pull: Display channel news. * guix/scripts/pull.scm (display-news-entry) (display-channel-specific-news): New procedures. (display-channel-news): Call it. (display-new/upgraded-packages): Adjust hint message. * doc/guix.texi (Invoking guix pull): Mention it. --- doc/guix.texi | 11 ++++++---- guix/scripts/pull.scm | 61 ++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 65 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 33bf08e9dd..4830f39cdb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3720,13 +3720,16 @@ Read the list of channels from @var{file} instead of evaluates to a list of channel objects. @xref{Channels}, for more information. +@cindex channel news @item --news @itemx -N -Display the list of packages added or upgraded since the previous generation. +Display the list of packages added or upgraded since the previous +generation, as well as, occasionally, news written by channel authors +for their users (@pxref{Channels, Writing Channel News}). -This is the same information as displayed upon @command{guix pull} completion, -but without ellipses; it is also similar to the output of @command{guix pull --l} for the last generation (see below). +The package information is the same as displayed upon @command{guix +pull} completion, but without ellipses; it is also similar to the output +of @command{guix pull -l} for the last generation (see below). @item --list-generations[=@var{pattern}] @itemx -l [@var{pattern}] diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 472947bb3a..d734df5e24 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -19,6 +19,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) + #:use-module (guix colors) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix scripts) @@ -229,6 +230,48 @@ purposes." ;; Assume that the URL matters less than the name. (eq? (channel-name channel1) (channel-name channel2))) +(define (display-news-entry entry language port) + "Display ENTRY, a , in LANGUAGE, a language code, to +PORT." + (let ((title (channel-news-entry-title entry)) + (body (channel-news-entry-body entry))) + (format port " ~a~%" + (highlight + (string-trim-right + (texi->plain-text (or (assoc-ref title language) + (assoc-ref title (%default-message-language)) + ""))))) + (format port (G_ " commit ~a~%") + (channel-news-entry-commit entry)) + (newline port) + (format port " ~a~%" + (indented-string + (parameterize ((%text-width (- (%text-width) 4))) + (string-trim-right + (texi->plain-text (or (assoc-ref body language) + (assoc-ref body (%default-message-language)) + "")))) + 4)))) + +(define* (display-channel-specific-news new old + #:key (port (current-output-port))) + "Display channel news applicable the commits between OLD and NEW, where OLD +and NEW are records with a proper 'commit' field." + (let ((channel new) + (old (channel-commit old)) + (new (channel-commit new))) + (when (and old new) + (let ((language (current-message-language))) + (match (channel-news-for-commit channel new old) + (() ;no news is good news + #t) + ((entries ...) + (newline port) + (format port (G_ "News for channel '~a'~%") + (channel-name channel)) + (for-each (cut display-news-entry <> language port) entries) + (newline port))))))) + (define (display-channel-news profile) "Display news about the channels of PROFILE " (define previous @@ -259,7 +302,20 @@ purposes." (N_ " ~*One channel removed:~%" " ~a channels removed:~%" count) count) - (for-each display-channel removed))))))))) + (for-each display-channel removed)))) + + ;; Display channel-specific news for those channels that were + ;; here before and are still around afterwards. + (for-each (match-lambda + ((new old) + (display-channel-specific-news new old))) + (filter-map (lambda (new) + (define old + (find (cut channel=? new <>) + old-channels)) + + (and old (list new old))) + new-channels))))))) (define (display-news profile) ;; Display profile news, with the understanding that this process represents @@ -534,8 +590,7 @@ display long package lists that would fill the user's screen." (when (and concise? (or (> new-count concise/max-item-count) (> upgraded-count concise/max-item-count))) - (display-hint (G_ "Run @command{guix pull --news} to view the complete -list of package changes."))))) + (display-hint (G_ "Run @command{guix pull --news} to read all the news."))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." -- cgit v1.2.3 From 192ee02aeb3d2f6d14ea93cfc43b30dd93df80e8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Sep 2019 23:55:19 +0200 Subject: pull: '-l' displays channel news. * guix/scripts/pull.scm (display-channel-news): Make 'previous' a parameter. (process-query)[list-generations]: Call 'display-channel-news'. --- guix/scripts/pull.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index d734df5e24..4a4756dc6e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -272,12 +272,12 @@ and NEW are records with a proper 'commit' field." (for-each (cut display-news-entry <> language port) entries) (newline port))))))) -(define (display-channel-news profile) - "Display news about the channels of PROFILE " - (define previous - (and=> (relative-generation profile -1) - (cut generation-file-name profile <>))) - +(define* (display-channel-news profile + #:optional + (previous + (and=> (relative-generation profile -1) + (cut generation-file-name profile <>)))) + "Display news about the channels of PROFILE compared to PREVIOUS." (when previous (let ((old-channels (profile-channels previous)) (new-channels (profile-channels profile))) @@ -614,6 +614,8 @@ display long package lists that would fill the user's screen." ((first second rest ...) (display-profile-content-diff profile first second) + (display-channel-news (generation-file-name profile second) + (generation-file-name profile first)) (loop (cons second rest))) ((_) #t) (() #t)))))) -- cgit v1.2.3 From dabdd7d4650da685a9bfe470abbc2ec066ff00b9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Sep 2019 23:00:07 +0200 Subject: pull: Display news titles directly upon 'pull'. * guix/scripts/pull.scm (display-profile-news): Return true when there's more to display. (display-news-entry-title): New procedure. (display-news-entry): Use it. (display-channel-specific-news): Return true when there's more to display. (display-channel-news-headlines): New procedure. (build-and-install): Call it. When 'display-channel-news-headlines' or 'display-profile-news' returns #t, print a hint to run "pull --news". (display-new/upgraded-packages): Return true when there's more to display. --- guix/scripts/pull.scm | 112 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 81 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 4a4756dc6e..a7fd36fffc 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -189,7 +189,7 @@ Download and deploy the latest version of Guix.\n")) current-is-newer?) "Display what's up in PROFILE--new packages, and all that. If CURRENT-IS-NEWER? is true, assume that the current process represents the -newest generation of PROFILE." +newest generation of PROFILE. Return true when there's more info to display." (match (memv (generation-number profile) (reverse (profile-generations profile))) ((current previous _ ...) @@ -212,7 +212,7 @@ newest generation of PROFILE." #:concise? concise? #:heading (G_ "New in this revision:\n"))))) - (_ #t))) + (_ #f))) (define (display-channel channel) "Display information about CHANNEL." @@ -230,33 +230,44 @@ purposes." ;; Assume that the URL matters less than the name. (eq? (channel-name channel1) (channel-name channel2))) +(define (display-news-entry-title entry language port) + "Display the title of ENTRY, a news entry, to PORT." + (define title + (channel-news-entry-title entry)) + + (format port " ~a~%" + (highlight + (string-trim-right + (texi->plain-text (or (assoc-ref title language) + (assoc-ref title (%default-message-language)) + "")))))) + (define (display-news-entry entry language port) "Display ENTRY, a , in LANGUAGE, a language code, to PORT." - (let ((title (channel-news-entry-title entry)) - (body (channel-news-entry-body entry))) - (format port " ~a~%" - (highlight + (define body + (channel-news-entry-body entry)) + + (display-news-entry-title entry language port) + (format port (G_ " commit ~a~%") + (channel-news-entry-commit entry)) + (newline port) + (format port " ~a~%" + (indented-string + (parameterize ((%text-width (- (%text-width) 4))) (string-trim-right - (texi->plain-text (or (assoc-ref title language) - (assoc-ref title (%default-message-language)) - ""))))) - (format port (G_ " commit ~a~%") - (channel-news-entry-commit entry)) - (newline port) - (format port " ~a~%" - (indented-string - (parameterize ((%text-width (- (%text-width) 4))) - (string-trim-right - (texi->plain-text (or (assoc-ref body language) - (assoc-ref body (%default-message-language)) - "")))) - 4)))) + (texi->plain-text (or (assoc-ref body language) + (assoc-ref body (%default-message-language)) + "")))) + 4))) (define* (display-channel-specific-news new old - #:key (port (current-output-port))) + #:key (port (current-output-port)) + concise?) "Display channel news applicable the commits between OLD and NEW, where OLD -and NEW are records with a proper 'commit' field." +and NEW are records with a proper 'commit' field. When CONCISE? is +true, display nothing but the news titles. Return true if there are more news +to display." (let ((channel new) (old (channel-commit old)) (new (channel-commit new))) @@ -264,13 +275,17 @@ and NEW are records with a proper 'commit' field." (let ((language (current-message-language))) (match (channel-news-for-commit channel new old) (() ;no news is good news - #t) + #f) ((entries ...) (newline port) (format port (G_ "News for channel '~a'~%") (channel-name channel)) - (for-each (cut display-news-entry <> language port) entries) - (newline port))))))) + (for-each (if concise? + (cut display-news-entry-title <> language port) + (cut display-news-entry <> language port)) + entries) + (newline port) + #t)))))) (define* (display-channel-news profile #:optional @@ -317,6 +332,35 @@ and NEW are records with a proper 'commit' field." (and old (list new old))) new-channels))))))) +(define* (display-channel-news-headlines profile) + "Display the titles of news about the channels of PROFILE compared to its +previous generation. Return true if there are news to display." + (define previous + (and=> (relative-generation profile -1) + (cut generation-file-name profile <>))) + + (when previous + (let ((old-channels (profile-channels previous)) + (new-channels (profile-channels profile))) + ;; Find the channels present in both PROFILE and PREVIOUS, and print + ;; their news. + (and (pair? old-channels) (pair? new-channels) + (let ((channels (filter-map (lambda (new) + (define old + (find (cut channel=? new <>) + old-channels)) + + (and old (list new old))) + new-channels))) + (define more? + (map (match-lambda + ((new old) + (display-channel-specific-news new old + #:concise? #t))) + channels)) + + (any ->bool more?)))))) + (define (display-news profile) ;; Display profile news, with the understanding that this process represents ;; the newest generation. @@ -344,7 +388,12 @@ true, display what would be built without actually building it." #:dry-run? dry-run?) (munless dry-run? (return (newline)) - (return (display-profile-news profile #:concise? #t)) + (return + (let ((more? (list (display-profile-news profile #:concise? #t) + (display-channel-news-headlines profile)))) + (when (any ->bool more?) + (display-hint + (G_ "Run @command{guix pull --news} to read all the news."))))) (if guix-command (let ((new (map (cut string-append <> "/bin/guix") (list (user-friendly-profile profile) @@ -544,7 +593,9 @@ it." "Given the two package name/version alists ALIST1 and ALIST2, display the list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1 and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not -display long package lists that would fill the user's screen." +display long package lists that would fill the user's screen. + +Return true when there is more package info to display." (define (pretty str column) (indented-string (fill-paragraph str (- (%text-width) 4) column) @@ -587,10 +638,9 @@ display long package lists that would fill the user's screen." (pretty (list->enumeration (sort upgraded string new-count concise/max-item-count) - (> upgraded-count concise/max-item-count))) - (display-hint (G_ "Run @command{guix pull --news} to read all the news."))))) + (and concise? + (or (> new-count concise/max-item-count) + (> upgraded-count concise/max-item-count))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." -- cgit v1.2.3 From b69ce8a8721ad82a528acc21bed68e611e5c6114 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 11:57:39 +0200 Subject: deploy: Add '--verbosity' and properly interpret build log. This is a followup to 91300526b7d9d775bd98a700ed3758420ef9eac6. * guix/scripts/deploy.scm (show-help, %options): Add '--verbosity'. (guix-deploy): Wrap 'with-store' in 'with-status-verbosity'. --- guix/scripts/deploy.scm | 47 +++++++++++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index cf571756fd..f311587ec3 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -26,6 +26,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix grafts) + #:use-module (guix status) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) @@ -52,6 +53,8 @@ Perform the deployment specified by FILE.\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (show-bug-report-information)) (define %options @@ -63,6 +66,12 @@ Perform the deployment specified by FILE.\n")) (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) + %standard-build-options)) (define %default-options @@ -87,25 +96,27 @@ Perform the deployment specified by FILE.\n")) (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) + (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) (machines (or (and file (load-source-file file)) '()))) - (with-store store - (set-build-options-from-command-line store opts) - (for-each (lambda (machine) - (info (G_ "deploying to ~a...~%") - (machine-display-name machine)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) - ((deploy-error? c) - (when (deploy-error-should-roll-back c) - (info (G_ "rolling back ~a...~%") - (machine-display-name machine)) - (run-with-store store (roll-back-machine machine))) - (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine))))) - machines)))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine))))) + machines))))) -- cgit v1.2.3 From 77c2eafbbb9036c0e5ccc60e39c08439731791d8 Mon Sep 17 00:00:00 2001 From: Vagrant Cascadian Date: Mon, 23 Sep 2019 11:55:33 -0700 Subject: scripts: container: Fix typo. * guix/scripts/container/exec (show-help): Fix spelling of COMMAND. --- guix/scripts/container/exec.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index d598f5cac4..51b616b384 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -38,7 +38,7 @@ (define (show-help) (display (G_ "Usage: guix container exec PID COMMAND [ARGS...] -Execute COMMMAND within the container process PID.\n")) +Execute COMMAND within the container process PID.\n")) (newline) (display (G_ " -h, --help display this help and exit")) -- cgit v1.2.3 From 7f6941492765c5f6cfe40c38af9dbb29a0700815 Mon Sep 17 00:00:00 2001 From: Vagrant Cascadian Date: Mon, 23 Sep 2019 11:59:24 -0700 Subject: lint: Fix typo. * guix/lint: Fix spelling of "mentioning". --- guix/lint.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index ba38bef806..03a8e88225 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -525,7 +525,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (define (validate-uri uri package field) "Return #t if the given URI can be reached, otherwise return a warning for -PACKAGE mentionning the FIELD." +PACKAGE mentioning the FIELD." (let-values (((status argument) (probe-uri uri #:timeout 3))) ;wait at most 3 seconds (case status -- cgit v1.2.3 From a130544d60747d48098ef27dc0c6cf677ab65afa Mon Sep 17 00:00:00 2001 From: Vagrant Cascadian Date: Mon, 23 Sep 2019 12:02:33 -0700 Subject: inferior: Fix typo. * guix/inferior: Fix spelling of "specifications". --- guix/inferior.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 6be30d3f17..dcbc954432 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -390,7 +390,7 @@ inferior package." (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) (define (%inferior-package-search-paths package field) - "Return the list of search path specificiations of PACKAGE, an inferior + "Return the list of search path specifications of PACKAGE, an inferior package." (define paths (inferior-package-field package -- cgit v1.2.3 From fa4867cc99edc1a8d98b315034a8843883021a12 Mon Sep 17 00:00:00 2001 From: Vagrant Cascadian Date: Mon, 23 Sep 2019 12:04:36 -0700 Subject: import: stackage: Fix typo. * guix/import/stackage: Fix spelling of "version". --- guix/import/stackage.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 194bea633e..14150201b5 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -95,7 +95,7 @@ (lts-info-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved -vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION +version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." -- cgit v1.2.3 From 5da7a04abddcd9c8805131ff27abbfe2b3f1fd33 Mon Sep 17 00:00:00 2001 From: Vagrant Cascadian Date: Mon, 23 Sep 2019 12:08:13 -0700 Subject: build: ruby-build-system: Fix typo. * guix/build/ruby-build-system: Fix spelling of "invocation". --- guix/build/ruby-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 63c94765f7..c957a61115 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -128,7 +128,7 @@ is #f." (define* (install #:key inputs outputs (gem-flags '()) #:allow-other-keys) "Install the gem archive SOURCE to the output store item. Additional -GEM-FLAGS are passed to the 'gem' invokation, if present." +GEM-FLAGS are passed to the 'gem' invocation, if present." (let* ((ruby-version (match:substring (string-match "ruby-(.*)\\.[0-9]$" (assoc-ref inputs "ruby")) -- cgit v1.2.3 From 4f8c29a75c3647b104c43ebf615d4a63a5e056b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 21:22:28 +0200 Subject: show, search: Add '--load-path'. * guix/scripts/search.scm (show-help, %options): Add -L/--load-path. * guix/scripts/show.scm (show-help, %options): Add -L/--load-path. --- guix/scripts/search.scm | 11 ++++++++++- guix/scripts/show.scm | 11 ++++++++++- 2 files changed, 20 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 8fceb83668..827b2eb7a9 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -19,6 +19,8 @@ (define-module (guix scripts search) #:use-module (guix ui) #:use-module (guix scripts package) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -36,6 +38,9 @@ This is an alias for 'guix package -s'.\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) (show-bug-report-information)) (define %options @@ -46,7 +51,11 @@ This is an alias for 'guix package -s'.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix search"))))) + (show-version-and-exit "guix search"))) + + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options))) (define (guix-search . args) (define (handle-argument arg result) diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm index 94f0559358..ef64b5755b 100644 --- a/guix/scripts/show.scm +++ b/guix/scripts/show.scm @@ -19,6 +19,8 @@ (define-module (guix scripts show) #:use-module (guix ui) #:use-module (guix scripts package) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -36,6 +38,9 @@ This is an alias for 'guix package --show='.\n")) (display (G_ " -V, --version display version information and exit")) (newline) + (display (G_ " + -L, --load-path=DIR prepend DIR to the package module search path")) + (newline) (show-bug-report-information)) (define %options @@ -46,7 +51,11 @@ This is an alias for 'guix package --show='.\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix show"))))) + (show-version-and-exit "guix show"))) + + (find (lambda (option) + (member "load-path" (option-names option))) + %standard-build-options))) (define (guix-show . args) (define (handle-argument arg result) -- cgit v1.2.3 From 7abd5997f41fec38ea1daa9099a9693062f10dbc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 22:07:53 +0200 Subject: repl, marionette: 'self-quoting?' matches keywords. * guix/repl.scm (self-quoting?): Add 'keyword?' and 'array?'; remove 'vector?' and 'bytevector?'. * gnu/tests.scm (marionette-shepherd-service) : Likewise. : Remove (rnrs bytevector). --- gnu/tests.scm | 7 +++---- guix/repl.scm | 6 ++---- 2 files changed, 5 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/gnu/tests.scm b/gnu/tests.scm index 0871b4c6f7..27cb39c2b9 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -87,8 +87,7 @@ (requirement `(udev ,@requirement)) (modules '((ice-9 match) - (srfi srfi-9 gnu) - (rnrs bytevectors))) + (srfi srfi-9 gnu))) (start (with-imported-modules imported-modules #~(lambda () @@ -98,8 +97,8 @@ ((_ pred rest ...) (or (pred x) (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean?))) (match (primitive-fork) (0 diff --git a/guix/repl.scm b/guix/repl.scm index 5cff5c71e9..1ead18c53b 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -17,7 +17,6 @@ ;;; along with GNU Guix. If not, see . (define-module (guix repl) - #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (send-repl-response machine-repl)) @@ -37,9 +36,8 @@ ((_ pred rest ...) (or (pred x) (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) - + (one-of symbol? string? keyword? pair? null? array? + number? boolean?))) (define (send-repl-response exp output) "Write the response corresponding to the evaluation of EXP to PORT, an -- cgit v1.2.3 From 24ab804ce11fe12ff49cd144a3d9c4bfcf55b41c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 22:17:39 +0200 Subject: gexp: Catch and report non-self-quoting gexp inputs. Previously we would, for example, generate build scripts in the store; when trying to run them, we'd get a 'read' error due to the presence of # syntax in there. * guix/gexp.scm (gexp->sexp)[self-quoting?]: New procedure. [reference->sexp]: Check whether the argument in a box is self-quoting. Raise a '&gexp-input-error' condition if it's not. * tests/gexp.scm ("lower-gexp, non-self-quoting input"): New test. --- guix/gexp.scm | 13 ++++++++++++- tests/gexp.scm | 7 +++++++ 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 45cd5869f7..0d0b661c65 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1005,6 +1005,15 @@ references; otherwise, return only non-native references." (target (%current-target-system))) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" + (define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean?))) + (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref @@ -1034,8 +1043,10 @@ and in the current monad setting (system type, etc.)" #:target target))) ;; OBJ must be either a derivation or a store file name. (return (expand thing obj output))))) - (($ x) + (($ (? self-quoting? x)) (return x)) + (($ x) + (raise (condition (&gexp-input-error (input x))))) (x (return x))))) diff --git a/tests/gexp.scm b/tests/gexp.scm index 5c013d838d..50d0948659 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -871,6 +871,13 @@ (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) (%guile-for-build))))))) +(test-eq "lower-gexp, non-self-quoting input" + + + (guard (c ((gexp-input-error? c) + (gexp-error-invalid-input c))) + (run-with-store %store + (lower-gexp #~(foo #$+))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) -- cgit v1.2.3 From 7b7e5b88fc341ddeada4a8df418767ce4dfca691 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 22:23:52 +0200 Subject: gexp: Remove unused procedure. * guix/gexp.scm (syntax-location-string): Remove. --- guix/gexp.scm | 13 ------------- 1 file changed, 13 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 0d0b661c65..e788fc5981 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1055,19 +1055,6 @@ and in the current monad setting (system type, etc.)" reference->sexp (gexp-references exp)))) (return (apply (gexp-proc exp) args)))) -(define (syntax-location-string s) - "Return a string representing the source code location of S." - (let ((props (syntax-source s))) - (if props - (let ((file (assoc-ref props 'filename)) - (line (and=> (assoc-ref props 'line) 1+)) - (column (assoc-ref props 'column))) - (if file - (simple-format #f "~a:~a:~a" - file line column) - (simple-format #f "~a:~a" line column))) - ""))) - (define-syntax-rule (define-syntax-parameter-once name proc) ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME ;; does not get redefined. This works around a race condition in a -- cgit v1.2.3 From 7b3f56f5d7f4d2bb936e1579ed442e7f5b080abd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 23:38:59 +0200 Subject: pull: Use ~/.cache/guix/checkouts instead of ~/.cache/guix/pull. Previously 'channel-news-for-commit' would use the former while 'guix pull' would use the latter. Consequently, the first 'guix pull -N' would clone the repository anew. * guix/scripts/pull.scm (guix-pull): Remove 'cache', and leave %REPOSITORY-CACHE-DIRECTORY to its default value. --- guix/scripts/pull.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index a7fd36fffc..2b7b991b50 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -764,7 +764,6 @@ Use '~/.config/guix/channels.scm' instead.")) (with-git-error-handling (let* ((opts (parse-command-line args %options (list %default-options))) - (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) (profile (or (assoc-ref opts 'profile) %current-profile))) (cond ((assoc-ref opts 'query) @@ -776,8 +775,7 @@ Use '~/.config/guix/channels.scm' instead.")) (ensure-default-profile) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) - (%graft? (assoc-ref opts 'graft?)) - (%repository-cache-directory cache)) + (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line store opts) (honor-x509-certificates store) -- cgit v1.2.3 From 0876e9c116125b28806286b0313ff78de5948562 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Sep 2019 10:45:38 +0200 Subject: colors: Add 'dim'. * guix/colors.scm (coloring-procedure): New procedure. (%highlight-color): Remove. (highlight): Define in terms of 'coloring-procedure'. (dim): New procedure. --- guix/colors.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index 7949cf5763..b63ac37027 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -31,6 +31,8 @@ colorize-string highlight + dim + color-rules color-output? isatty?*)) @@ -133,14 +135,16 @@ that subsequent output will not have any colors in effect." (not (getenv "NO_COLOR")) (isatty?* port))) -(define %highlight-color (color BOLD)) +(define (coloring-procedure color) + "Return a procedure that applies COLOR to the given string." + (lambda* (str #:optional (port (current-output-port))) + "Return STR with extra ANSI color attributes if PORT supports it." + (if (color-output? port) + (colorize-string str color) + str))) -(define* (highlight str #:optional (port (current-output-port))) - "Return STR with extra ANSI color attributes to highlight it if PORT -supports it." - (if (color-output? port) - (colorize-string str %highlight-color) - str)) +(define highlight (coloring-procedure (color BOLD))) +(define dim (coloring-procedure (color DARK))) (define (colorize-matches rules) "Return a procedure that, when passed a string, returns that string -- cgit v1.2.3 From d26c290b7dac642c39f23fd65b4eb0d10534d58d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Sep 2019 10:48:50 +0200 Subject: pull: Dim the commit ID when displaying news. * guix/scripts/pull.scm (display-news-entry): Dim the commit line. --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2b7b991b50..0372278705 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -249,7 +249,7 @@ PORT." (channel-news-entry-body entry)) (display-news-entry-title entry language port) - (format port (G_ " commit ~a~%") + (format port (dim (G_ " commit ~a~%")) (channel-news-entry-commit entry)) (newline port) (format port " ~a~%" -- cgit v1.2.3 From 3972dc5d43ea824ee4ab78592e759f62ce90bf6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Sep 2019 17:50:48 +0200 Subject: guix package: Add '--list-profiles'. * guix/scripts/package.scm (show-help, %options): Add '--list-profiles'. (process-query): Honor it. * tests/guix-package.sh: Add test. --- doc/guix.texi | 13 +++++++++++++ guix/scripts/package.scm | 21 +++++++++++++++++++++ tests/guix-package.sh | 6 +++++- 3 files changed, 39 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4ffffcdc81..14c4514b31 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2933,6 +2933,19 @@ siblings that point to specific generations: $ rm ~/code/my-profile ~/code/my-profile-*-link @end example +@item --list-profiles +List all the user's profiles: + +@example +$ guix package --list-profiles +/home/charlie/.guix-profile +/home/charlie/code/my-profile +/home/charlie/code/devel-profile +/home/charlie/tmp/test +@end example + +When running as root, list all the profiles of all the users. + @cindex collisions, in a profile @cindex colliding packages in profiles @cindex profile collisions diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f03741aa9e..1a58d43e5c 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -39,6 +39,7 @@ #:use-module (guix scripts) #:use-module (guix scripts build) #:autoload (guix describe) (package-provenance) + #:autoload (guix store roots) (gc-roots) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) @@ -359,6 +360,8 @@ Install, remove, or upgrade packages in a single transaction.\n")) switch to a generation matching PATTERN")) (display (G_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) + (display (G_ " + --list-profiles list the user's profiles")) (newline) (display (G_ " --allow-collisions do not treat collisions in the profile as an error")) @@ -458,6 +461,11 @@ command-line option~%") (values (cons `(query list-generations ,arg) result) #f))) + (option '("list-profiles") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query list-profiles #t) + result) + #f))) (option '(#\d "delete-generations") #f #t (lambda (opt name arg result arg-handler) (values (alist-cons 'delete-generations arg @@ -750,6 +758,19 @@ processed, #f otherwise." (string "$module_dir/foo.scm"< /tmp/out test "`guix package -L "$module_dir" -s dummy-output | grep ^name:`" = "name: dummy-package" rm -rf "$module_dir" + +# Make sure we can see user profiles. +guix package --list-profiles | grep "$profile" +guix package --list-profiles | grep '\.guix-profile' -- cgit v1.2.3 From dec845606d2d184da31065fa26cd951b84b3ce2d Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Thu, 8 Aug 2019 16:43:15 +0200 Subject: guix download: Ensure destination file-name is valid in the store. Avoid invalid store-file-name by explicitly passing the destination name, replacing any character not allowed in the store-file-name by an underscore. Fixes * guix/scripts/download.scm (safe-naensure-valid-store-file-nameme): New function. (download-to-store*): Use it to generate a "safe" basename of URL. --- guix/scripts/download.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'guix') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index d8fe71ce12..22cd75ea0b 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -33,6 +33,7 @@ #:use-module (web uri) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-14) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (rnrs bytevectors) @@ -54,9 +55,23 @@ (url-fetch url file #:mirrors %mirrors))) file)) +(define (ensure-valid-store-file-name name) + "Replace any character not allowed in a stror name by an underscore." + + (define valid + ;; according to nix/libstore/store-api.cc + (string->char-set (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "0123456789" "+-._?="))) + (string-map (lambda (c) + (if (char-set-contains? valid c) c #\_)) + name)) + + (define* (download-to-store* url #:key (verify-certificate? #t)) (with-store store (download-to-store store url + (ensure-valid-store-file-name (basename url)) #:verify-certificate? verify-certificate?))) (define %default-options -- cgit v1.2.3 From 8727e0304b68cd22e827331bb40ea269f243c6ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 26 Sep 2019 18:49:25 +0200 Subject: self: Mark trivial "-modules" derivations as non-substitutable. The resulting nar takes ~500KiB and it's quicker to build it locally than to download it. * guix/self.scm (node-source+compiled): Pass #:options to 'computed-file'. --- guix/self.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index f03fe01d0c..142c834137 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -124,7 +124,11 @@ NODE's modules, under their FHS directories: share/guile/site and lib/guile." (symlink #$(node-compiled node) object)))) (computed-file (string-append (node-name node) "-modules") - build)) + build + #:options '(#:local-build? #t + + ;; "Building" it locally is faster. + #:substitutable? #f))) (define (node-fold proc init nodes) (let loop ((nodes nodes) -- cgit v1.2.3 From 21391f8c83658797c9bfbc3ef8a552859e9d861d Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 24 Sep 2019 20:57:34 -0500 Subject: compile: Fix race condition on completion progress. This prevent a race condition where multiple compilation threads could report the same progress. * guix/build/compile.scm (compile-files): Rename to... : ...this. Increment in same mutex region as the compilation is reported. --- guix/build/compile.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index c127456fd0..06ed57c9d7 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -169,11 +169,12 @@ BUILD-DIRECTORY, using up to WORKERS parallel workers. The resulting object files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (define progress-lock (make-mutex)) (define total (length files)) - (define completed 0) + (define progress 0) (define (build file) (with-mutex progress-lock - (report-compilation file total completed)) + (report-compilation file total progress) + (set! progress (+ 1 progress))) ;; Exit as soon as something goes wrong. (exit-on-exception @@ -185,9 +186,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." #:output-file (string-append build-directory "/" (scm->go relative)) #:opts (append warning-options - (optimization-options relative))))))) - (with-mutex progress-lock - (set! completed (+ 1 completed)))) + (optimization-options relative)))))))) (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory -- cgit v1.2.3 From a3af06ad65eb097ddaa9a6fab893e2b688734e04 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Sep 2019 17:22:39 +0200 Subject: offload: Include the port number in the machine lock file name. This is useful when a single machine appears several time, with different port numbers. * guix/scripts/offload.scm (machine-slot-file): Add MACHINE's port to the file name. --- guix/scripts/offload.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 0c0dd9d516..bb307cefd1 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -243,7 +243,8 @@ instead of '~a' of type '~a'~%") ;; of these; if we fail, that means all the build slots are already taken. ;; Inspired by Nix's build-remote.pl. (string-append (string-append %state-directory "/offload/" - (build-machine-name machine) + (build-machine-name machine) ":" + (number->string (build-machine-port machine)) "/" (number->string slot)))) (define (acquire-build-slot machine) -- cgit v1.2.3 From 7089f98ef1c274f1607ec314f3a16bd3c3ac89a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 19 Jul 2019 00:52:36 +0200 Subject: syscalls: 'define-as-needed' does not re-export local variables. Fixes . Reported by Timothy Sample . * guix/build/syscalls.scm (define-as-needed): Rewrite to use lower-level module primitives; define VARIABLE only if it's not already defined to avoid "re-exporting local variable" error. --- guix/build/syscalls.scm | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 3c84d3893f..f2fdb4d9d1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -396,17 +396,11 @@ the returned procedure is called." ((_ (proc args ...) body ...) (define-as-needed proc (lambda* (args ...) body ...))) ((_ variable value) - (begin - (when (module-defined? the-scm-module 'variable) - (re-export variable)) - - (define variable - (if (module-defined? the-scm-module 'variable) - (module-ref the-scm-module 'variable) - value)) - - (unless (module-defined? the-scm-module 'variable) - (export variable)))))) + (if (module-defined? the-scm-module 'variable) + (module-re-export! (current-module) '(variable)) + (begin + (module-define! (current-module) 'variable value) + (module-export! (current-module) '(variable))))))) ;;; -- cgit v1.2.3 From 8b4615ab54dcd25c6cfa22f9416a8f1c74d36612 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 1 Oct 2019 10:45:05 +0200 Subject: ui: 'show-what-to-build' colorizes store file names. * guix/ui.scm (colorize-store-file-name): New procedure. (show-what-to-build)[colorize-store-item]: New variable. Use it throughout. --- guix/ui.scm | 40 ++++++++++++++++++++++++++++++---------- 1 file changed, 30 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 069d542131..3e4bd5787e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -867,6 +867,17 @@ warning." ('profile-hook #t) (_ #f))) +(define (colorize-store-file-name file) + "Colorize FILE, a store file name, such that the hash part is less prominent +that the rest." + (let ((len (string-length file)) + (prefix (+ (string-length (%store-prefix)) 32 2))) + (if (< len prefix) + file + (string-append (colorize-string (string-take file prefix) + (color DARK)) + (string-drop file prefix))))) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) (mode (build-mode normal))) @@ -890,6 +901,11 @@ check and report what is prerequisites are available for download." (substitution-oracle store inputs #:mode mode) (const #f))) + (define colorized-store-item + (if (color-output? (current-error-port)) + colorize-store-file-name + identity)) + (let*-values (((build download) (derivation-build-plan store inputs #:mode mode @@ -935,7 +951,7 @@ check and report what is prerequisites are available for download." (N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]" "~:[The following derivations would be built:~%~{ ~a~%~}~;~]" (length build)) - (null? build) build) + (null? build) (map colorized-store-item build)) (if display-download-size? (format (current-error-port) ;; TRANSLATORS: "MB" is for "megabyte"; it should be @@ -943,29 +959,31 @@ check and report what is prerequisites are available for download." (G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]") (null? download) download-size - (map substitutable-path download)) + (map (compose colorized-store-item substitutable-path) + download)) (format (current-error-port) (N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download))) + (map (compose colorized-store-item substitutable-path) + download))) (format (current-error-port) (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" (length graft)) - (null? graft) graft) + (null? graft) (map colorized-store-item graft)) (format (current-error-port) (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]" "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]" (length hook)) - (null? hook) hook)) + (null? hook) (map colorized-store-item hook))) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" "~:[The following derivations will be built:~%~{ ~a~%~}~;~]" (length build)) - (null? build) build) + (null? build) (map colorized-store-item build)) (if display-download-size? (format (current-error-port) ;; TRANSLATORS: "MB" is for "megabyte"; it should be @@ -973,23 +991,25 @@ check and report what is prerequisites are available for download." (G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]") (null? download) download-size - (map substitutable-path download)) + (map (compose colorized-store-item substitutable-path) + download)) (format (current-error-port) (N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]" "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download))) + (map (compose colorized-store-item substitutable-path) + download))) (format (current-error-port) (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" (length graft)) - (null? graft) graft) + (null? graft) (map colorized-store-item graft)) (format (current-error-port) (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]" "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]" (length hook)) - (null? hook) hook))) + (null? hook) (map colorized-store-item hook)))) (check-available-space installed-size) -- cgit v1.2.3 From 43f7fd8783af1e824904a76115a8ae8ccbb19f06 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 1 Oct 2019 10:46:16 +0200 Subject: pull: Do not use '~*', which 'msgfmt' fails to interpret. Fixes . Reported by Konrad Hinsen . * guix/scripts/pull.scm (display-channel-news): Use ~a instead of ~* when reporting new channels. --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 0372278705..e018985469 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -304,7 +304,7 @@ to display." (new (let ((count (length new))) (format (current-error-port) - (N_ " ~*One new channel:~%" + (N_ " ~a new channel:~%" " ~a new channels:~%" count) count) (for-each display-channel new)))) -- cgit v1.2.3 From 2cd599f005bb91ae120a66824b8efbac81a27a69 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 29 Sep 2019 13:58:17 +0100 Subject: inferior: Change to use the (guix repl) module. Rather than (guix scripts repl), from which the machine-repl procedure was removed in [1]. 1: 92a4087bf4862d5ba9b77111eba3c68c2a1c4679 * guix/inferior.scm (inferior-pipe): Load (guix repl) rather than (guix scripts repl). --- guix/inferior.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index dcbc954432..d6d2053ab8 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -136,8 +136,8 @@ it's an old Guix." (object->string `(begin (primitive-load ,(search-path %load-path - "guix/scripts/repl.scm")) - ((@ (guix scripts repl) machine-repl)))))) + "guix/repl.scm")) + ((@ (guix repl) machine-repl)))))) pipe))) (define* (port->inferior pipe #:optional (close close-port)) -- cgit v1.2.3 From 13169000f6a1cc8513345542f3bae8978d0c6b1a Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Tue, 1 Oct 2019 17:06:58 +0200 Subject: pull: Do not use '~*', which 'msgfmt' fails to interpret. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Really fixes . This is a followup to f751b4646d3989d76dad9e33e39f9724c7c50be6. * guix/scripts/pull.scm (display-channel-news): Remove second occurrence of '~*' in a format string. Signed-off-by: Ludovic Courtès --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e018985469..04970cf503 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -314,7 +314,7 @@ to display." (removed (let ((count (length removed))) (format (current-error-port) - (N_ " ~*One channel removed:~%" + (N_ " ~a channel removed:~%" " ~a channels removed:~%" count) count) (for-each display-channel removed)))) -- cgit v1.2.3 From f8372932027680a1f2f1b41ea8e19c12bb7d7070 Mon Sep 17 00:00:00 2001 From: Martin Becze Date: Tue, 1 Oct 2019 16:54:56 -0400 Subject: import: crate: Support recursive imports. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/crate.scm (crate-recursive-import): New procedure. (crate->guix-package): Return dependencies as a second value. Signed-off-by: Ludovic Courtès --- guix/import/crate.scm | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index fd1974eae8..8dc014d232 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -40,6 +40,7 @@ #:use-module (srfi srfi-26) #:export (crate->guix-package guix-package->crate-name + crate-recursive-import %crate-updater)) @@ -218,16 +219,24 @@ latest version of CRATE-NAME." (cargo-development-inputs (sort (map crate-dependency-id dev-dep-crates) string-ci (crate-version-license version*) - string->license))))) + (values + (make-crate-sexp #:name crate-name + #:version (crate-version-number version*) + #:cargo-inputs cargo-inputs + #:cargo-development-inputs cargo-development-inputs + #:home-page (or (crate-home-page crate) + (crate-repository crate)) + #:synopsis (crate-description crate) + #:description (crate-description crate) + #:license (and=> (crate-version-license version*) + string->license)) + (append cargo-inputs cargo-development-inputs))))) + +(define (crate-recursive-import crate-name) + (recursive-import crate-name #f + #:repo->guix-package (lambda (name repo) + (crate->guix-package name)) + #:guix-name crate-name->package-name)) (define (guix-package->crate-name package) "Return the crate name of PACKAGE." -- cgit v1.2.3 From ed661e38d8ce3c4efa5c495b2c34ba86e1e43290 Mon Sep 17 00:00:00 2001 From: Martin Becze Date: Tue, 1 Oct 2019 16:54:57 -0400 Subject: import: crate: Add '--recursive'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/import/crate.scm (show-help, guix-import-crate): Add '--recursive'. * doc/guix.texi (Invoking guix import): Mention '--recursive'. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 10 ++++++++++ guix/scripts/import/crate.scm | 36 ++++++++++++++++++++++++++---------- 2 files changed, 36 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index a6c1319405..93139e2d05 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9083,6 +9083,16 @@ The crate importer also allows you to specify a version string: guix import crate constant-time-eq@@0.1.0 @end example +Additional options include: + +@table @code +@item --recursive +@itemx -r +Traverse the dependency graph of the given upstream package recursively +and generate package expressions for all those packages that are not yet +in Guix. +@end table + @item opam @cindex OPAM @cindex OCaml diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 7ae8638911..4690cceb4d 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-crate)) @@ -43,6 +44,9 @@ (define (show-help) (display (G_ "Usage: guix import crate PACKAGE-NAME Import and convert the crate.io package for PACKAGE-NAME.\n")) + (display (G_ " + -r, --recursive import packages recursively")) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -59,6 +63,9 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import crate"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -79,22 +86,31 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) + (('argument . value) + value) + (_ #f)) (reverse opts)))) (match args ((spec) (define-values (name version) (package-name->name+version spec)) - (let ((sexp (crate->guix-package name version))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - (if version - (string-append name "@" version) - name))) - sexp)) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (crate-recursive-import name)))) + (let ((sexp (crate->guix-package name version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + (if version + (string-append name "@" version) + name))) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) -- cgit v1.2.3 From 37c0d4580e464a5915ea34109f78898325aae2c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Oct 2019 11:15:48 +0200 Subject: channels: Add quirk to build recent 'master' with Guile 2.2.4. Fixes . Reported by Marius Bakke . * guix/channels.scm (syscalls-reexports-local-variables?) (guile-2.2.4, guile-for-source): New procedures. (%quirks): New variable. (build-from-source): Add calls to 'guile-for-source' and 'set-guile-for-build'. --- guix/channels.scm | 52 +++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 49 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 4e6e7090ac..2c28dccbcb 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -27,6 +27,7 @@ #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) + #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix combinators) #:use-module (guix diagnostics) @@ -47,6 +48,7 @@ #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module ((ice-9 rdelim) #:select (read-string)) #:export (channel channel? channel-name @@ -306,6 +308,46 @@ to '%package-module-path'." (gexp->derivation-in-inferior name build core))) +(define (syscalls-reexports-local-variables? source) + "Return true if (guix build syscalls) contains the bug described at +." + (catch 'system-error + (lambda () + (define content + (call-with-input-file (string-append source + "/guix/build/syscalls.scm") + read-string)) + + ;; The faulty code would use the 're-export' macro, causing the + ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using + ;; Guile > 2.2.4. + (string-contains content "(re-export variable)")) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (guile-2.2.4) + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-2.2.4)) + +(define %quirks + ;; List of predicate/package pairs. This allows us provide information + ;; about specific Guile versions that old Guix revisions might need to use + ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See + ;; + `((,syscalls-reexports-local-variables? . ,guile-2.2.4))) + +(define* (guile-for-source source #:optional (quirks %quirks)) + "Return the Guile package to use when building SOURCE or #f if the default +'%guile-for-build' should be good enough." + (let loop ((quirks quirks)) + (match quirks + (() + #f) + (((predicate . guile) rest ...) + (if (predicate source) (guile) (loop rest)))))) + (define* (build-from-source name source #:key core verbose? commit (dependencies '())) @@ -327,15 +369,19 @@ package modules under SOURCE using CORE, an instance of Guix." ;; about it. (parameterize ((guix-warning-port (%make-void-port "w"))) - (primitive-load script)))))) + (primitive-load script))))) + (guile (guile-for-source source))) ;; BUILD must be a monadic procedure of at least one argument: the ;; source tree. ;; ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In ;; the future we'll fall back to a previous version of the protocol ;; when that happens. - (build source #:verbose? verbose? #:version commit - #:pull-version %pull-version)) + (mbegin %store-monad + (mwhen guile + (set-guile-for-build guile)) + (build source #:verbose? verbose? #:version commit + #:pull-version %pull-version))) ;; Build a set of modules that extend Guix using the standard method. (standard-module-derivation name source core dependencies))) -- cgit v1.2.3 From 5a02f8e3842c19d28f39e5b47d804ef70e1b3160 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 3 Oct 2019 22:19:11 +0200 Subject: environment: '--container' honors '--preserve'. * guix/scripts/environment.scm (launch-environment/container): Add #:white-list parameter and honor it. (guix-environment): Pass #:white-list to 'launch-environment/container'. * tests/guix-environment-container.sh: Add test. --- guix/scripts/environment.scm | 19 +++++++++++++++++-- tests/guix-environment-container.sh | 5 +++++ 2 files changed, 22 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 535f181bfd..4a51654ce6 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -452,7 +452,7 @@ regexps in WHITE-LIST." (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? - map-cwd?) + map-cwd? (white-list '())) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to the search paths of MANIFEST. The global shell is BASH, a file name for a GNU Bash binary in the @@ -461,7 +461,10 @@ USER-MAPPINGS, a list of file system mappings, contains the user-specified host file systems to mount inside the container. If USER is not #f, each target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from -~/.guix-profile to the environment profile." +~/.guix-profile to the environment profile. + +Preserve environment variables whose name matches the one of the regexps in +WHILE-LIST." (define (optional-mapping->fs mapping) (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) @@ -487,6 +490,11 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (group-entry (gid 65534) ;the overflow GID (name "overflow")))) (home-dir (password-entry-directory passwd)) + (environ (filter (match-lambda + ((variable . value) + (find (cut regexp-exec <> variable) + white-list))) + (get-environment-variables))) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. @@ -555,6 +563,12 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (override-user-dir user home cwd) home-dir)) + ;; Set environment variables that match WHITE-LIST. + (for-each (match-lambda + ((variable . value) + (setenv variable value))) + environ) + (primitive-exit/status ;; A container's environment is already purified, so no need to ;; request it be purified again. @@ -759,6 +773,7 @@ message if any test fails." #:user-mappings mappings #:profile profile #:manifest manifest + #:white-list white-list #:link-profile? link-prof? #:network? network? #:map-cwd? (not no-cwd?)))) diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 32a5ba1f97..d313f2e734 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,11 @@ else test $? = 42 fi +# Make sure '--preserve' is honored. +result="`FOOBAR=42; export FOOBAR; guix environment -C --ad-hoc --bootstrap \ + guile-bootstrap -E ^FOO -- guile -c '(display (getenv \"FOOBAR\"))'`" +test "$result" = "42" + # By default, the UID inside the container should be the same as outside. uid="`id -u`" inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \ -- cgit v1.2.3 From cdf9811d24b9c857cb79e0ddd38181862ec34bd3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 3 Oct 2019 22:54:28 +0200 Subject: gexp: 'load-path-expression' produces an expression that deletes duplicates. Fixes . "herd eval root '(length %load-path)'" on a freshly-booted bare-bones system now returns 8 instead of 119 before. * guix/gexp.scm (load-path-expression): Rewrite expression to that it deletes duplicates. --- guix/gexp.scm | 49 +++++++++++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index e788fc5981..26881ce16c 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1527,24 +1527,37 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." #:module-path path #:system system #:target target))) - (return (gexp (eval-when (expand load eval) - (set! %load-path - (cons (ungexp modules) - (append (map (lambda (extension) - (string-append extension - "/share/guile/site/" - (effective-version))) - '((ungexp-native-splicing extensions))) - %load-path))) - (set! %load-compiled-path - (cons (ungexp compiled) - (append (map (lambda (extension) - (string-append extension - "/lib/guile/" - (effective-version) - "/site-ccache")) - '((ungexp-native-splicing extensions))) - %load-compiled-path))))))))) + (return + (gexp (eval-when (expand load eval) + ;; Augment the load paths and delete duplicates. Do that + ;; without loading (srfi srfi-1) or anything. + (let ((extensions '((ungexp-native-splicing extensions))) + (prepend (lambda (items lst) + ;; This is O(N²) but N is typically small. + (let loop ((items items) + (lst lst)) + (if (null? items) + lst + (loop (cdr items) + (cons (car items) + (delete (car items) lst)))))))) + (set! %load-path + (prepend (cons (ungexp modules) + (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + extensions)) + %load-path)) + (set! %load-compiled-path + (prepend (cons (ungexp compiled) + (map (lambda (extension) + (string-append extension + "/lib/guile/" + (effective-version) + "/site-ccache")) + extensions)) + %load-compiled-path))))))))) (define* (gexp->script name exp #:key (guile (default-guile)) -- cgit v1.2.3 From 5e5f7167943b408ae55736a44908a82056c87780 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Oct 2019 21:54:31 +0200 Subject: syscalls: Add 'add-to-entropy-count'. * guix/build/syscalls.scm (RNDADDTOENTCNT): New variable. (add-to-entropy-count): New procedure. * tests/syscalls.scm ("add-to-entropy-count"): New test. --- guix/build/syscalls.scm | 28 ++++++++++++++++++++++++++++ tests/syscalls.scm | 13 +++++++++++++ 2 files changed, 41 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index f2fdb4d9d1..bbf2531c79 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -68,6 +68,7 @@ statfs free-disk-space device-in-use? + add-to-entropy-count processes mkdtemp! @@ -706,6 +707,33 @@ backend device." (list (strerror err)) (list err)))))) + +;;; +;;; Random. +;;; + +;; From . +(define RNDADDTOENTCNT #x40045201) + +(define (add-to-entropy-count port-or-fd n) + "Add N to the kernel's entropy count (the value that can be read from +/proc/sys/kernel/random/entropy_avail). PORT-OR-FD must correspond to +/dev/urandom or /dev/random. Raise to 'system-error with EPERM when the +caller lacks root privileges." + (let ((fd (if (port? port-or-fd) + (fileno port-or-fd) + port-or-fd)) + (box (make-bytevector (sizeof int)))) + (bytevector-sint-set! box 0 n (native-endianness) + (sizeof int)) + (let-values (((ret err) + (%ioctl fd RNDADDTOENTCNT + (bytevector->pointer box)))) + (unless (zero? err) + (throw 'system-error "add-to-entropy-count" "~A" + (list (strerror err)) + (list err)))))) + ;;; ;;; Containers. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index eeb223b950..1b3121e503 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -567,6 +567,19 @@ (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx))) (or (utmpx? result) (eof-object? result)))) +(when (zero? (getuid)) + (test-skip 1)) +(test-equal "add-to-entropy-count" + EPERM + (call-with-output-file "/dev/urandom" + (lambda (port) + (catch 'system-error + (lambda () + (add-to-entropy-count port 77) + #f) + (lambda args + (system-error-errno args)))))) + (test-end) (false-if-exception (delete-file temp-file)) -- cgit v1.2.3