diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 146 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 76 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 13 |
5 files changed, 180 insertions, 70 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 6b29c470fb..28864435df 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -226,18 +226,21 @@ matching URIs given in SOURCES." obj))))) (define (evaluate-replacement-specs specs proc) - "Parse SPECS, a list of strings like \"guile=guile@2.1\", and invoke PROC on -each package pair specified by SPECS. Return the resulting list. Raise an -error if an element of SPECS uses invalid syntax, or if a package it refers to -could not be found." + "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list +of package spec/procedure pairs as expected by 'package-input-rewriting/spec'. +PROC is called with the package to be replaced and its replacement according +to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a +package it refers to could not be found." (define not-equal (char-set-complement (char-set #\=))) (map (lambda (spec) (match (string-tokenize spec not-equal) - ((old new) - (proc (specification->package old) - (specification->package new))) + ((spec new) + (cons spec + (let ((new (specification->package new))) + (lambda (old) + (proc old new))))) (x (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) @@ -248,8 +251,10 @@ dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like \"guile=guile@2.1\" meaning that, any dependency on a package called \"guile\" must be replaced with a dependency on a version 2.1 of \"guile\"." - (let* ((replacements (evaluate-replacement-specs replacement-specs cons)) - (rewrite (package-input-rewriting replacements))) + (let* ((replacements (evaluate-replacement-specs replacement-specs + (lambda (old new) + new))) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) @@ -260,41 +265,47 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the current 'gnutls' package, after which version 3.5.4 is grafted onto them." - (define (replacement-pair old new) - (cons old - (package (inherit old) (replacement new)))) + (define (set-replacement old new) + (package (inherit old) (replacement new))) (let* ((replacements (evaluate-replacement-specs replacement-specs - replacement-pair)) - (rewrite (package-input-rewriting replacements))) + set-replacement)) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) obj)))) +(define %not-equal + (char-set-complement (char-set #\=))) + +(define (package-git-url package) + "Return the URL of the Git repository for package, or raise an error if +the source of PACKAGE is not fetched from a Git repository." + (let ((source (package-source package))) + (cond ((and (origin? source) + (git-reference? (origin-uri source))) + (git-reference-url (origin-uri source))) + ((git-checkout? source) + (git-checkout-url source)) + (else + (leave (G_ "the source of ~a is not a Git reference~%") + (package-full-name package)))))) + (define (evaluate-git-replacement-specs specs proc) "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the replacement package. Raise an error if an element of SPECS uses invalid syntax, or if a package it refers to could not be found." - (define not-equal - (char-set-complement (char-set #\=))) - (map (lambda (spec) - (match (string-tokenize spec not-equal) - ((name branch-or-commit) - (let* ((old (specification->package name)) - (source (package-source old)) - (url (cond ((and (origin? source) - (git-reference? (origin-uri source))) - (git-reference-url (origin-uri source))) - ((git-checkout? source) - (git-checkout-url source)) - (else - (leave (G_ "the source of ~a is not a Git \ -reference~%") - (package-full-name old)))))) - (cons old (proc old url branch-or-commit)))) + (match (string-tokenize spec %not-equal) + ((spec branch-or-commit) + (define (replace old) + (let* ((source (package-source old)) + (url (package-git-url old))) + (proc old url branch-or-commit))) + + (cons spec replace)) (x (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) @@ -307,13 +318,16 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (define (replace old url branch) (package (inherit old) - (version (string-append "git." branch)) + (version (string-append "git." (string-map (match-lambda + (#\/ #\-) + (chr chr)) + branch))) (source (git-checkout (url url) (branch branch) (recursive? #t))))) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) - (rewrite (package-input-rewriting replacements))) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) @@ -331,16 +345,42 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using (if (< (string-length commit) 7) commit (string-take commit 7)))) - (source (git-checkout (url url) (commit commit))))) + (source (git-checkout (url url) (commit commit) + (recursive? #t))))) (let* ((replacements (evaluate-git-replacement-specs replacement-specs replace)) - (rewrite (package-input-rewriting replacements))) + (rewrite (package-input-rewriting/spec replacements))) (lambda (store obj) (if (package? obj) (rewrite obj) obj)))) +(define (transform-package-source-git-url replacement-specs) + "Return a procedure that, when passed a package, replaces its dependencies +according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like +\"guile-json=https://gitthing.com/…\" meaning that packages are built using +a checkout of the Git repository at the given URL." + (define replacements + (map (lambda (spec) + (match (string-tokenize spec %not-equal) + ((spec url) + (cons spec + (lambda (old) + (package + (inherit old) + (source (git-checkout (url url) + (recursive? #t))))))))) + replacement-specs)) + + (define rewrite + (package-input-rewriting/spec replacements)) + + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -350,7 +390,8 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using (with-input . ,transform-package-inputs) (with-graft . ,transform-package-inputs/graft) (with-branch . ,transform-package-source-branch) - (with-commit . ,transform-package-source-commit))) + (with-commit . ,transform-package-source-commit) + (with-git-url . ,transform-package-source-git-url))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -368,7 +409,9 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using (option '("with-branch") #t #f (parser 'with-branch)) (option '("with-commit") #t #f - (parser 'with-commit))))) + (parser 'with-commit)) + (option '("with-git-url") #t #f + (parser 'with-git-url))))) (define (show-transformation-options-help) (display (G_ " @@ -385,23 +428,32 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using build PACKAGE from the latest commit of BRANCH")) (display (G_ " --with-commit=PACKAGE=COMMIT - build PACKAGE from COMMIT"))) + build PACKAGE from COMMIT")) + (display (G_ " + --with-git-url=PACKAGE=URL + build PACKAGE from the repository at URL"))) (define (options->transformation opts) "Return a procedure that, when passed an object to build (package, derivation, etc.), applies the transformations specified by OPTS." (define applicable - ;; List of applicable transformations as symbol/procedure pairs. + ;; List of applicable transformations as symbol/procedure pairs in the + ;; order in which they appear on the command line. (filter-map (match-lambda - ((key . transform) - (match (filter-map (match-lambda - ((k . arg) - (and (eq? k key) arg))) - opts) - (() #f) - (args (cons key (transform args)))))) - %transformations)) + ((key . value) + (match (any (match-lambda + ((k . proc) + (and (eq? k key) proc))) + %transformations) + (#f + #f) + (transform + ;; XXX: We used to pass TRANSFORM a list of several + ;; arguments, but we now pass only one, assuming that + ;; transform composes well. + (cons key (transform (list value))))))) + (reverse opts))) (lambda (store obj) (fold (match-lambda* diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 7d0ecb0a4d..b6287d3a4c 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -85,7 +85,9 @@ Display information about the channels currently in use.\n")) (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string)) ('channels (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%") - string)))))) + string)) + (_ + (warning (G_ "'GUIX_PACKAGE_PATH' is set but it is not captured~%"))))))) (define (channel->sexp channel) `(channel diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e2ecddfbfc..e5502ef9ca 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -28,6 +28,7 @@ #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) + #:autoload (guix inferior) (inferior-package?) #:use-module (guix monads) #:use-module (guix modules) #:use-module (guix packages) @@ -305,11 +306,13 @@ added to the pack." (with-imported-modules (source-module-closure '((guix build utils) (guix build store-copy) + (guix build union) (gnu build install)) #:select? not-config?) #~(begin (use-modules (guix build utils) (guix build store-copy) + ((guix build union) #:select (relative-file-name)) (gnu build install) (srfi srfi-1) (srfi srfi-26) @@ -358,18 +361,25 @@ added to the pack." ,@(append-map (match-lambda ((source '-> target) - (list "-p" - (string-join - ;; name s mode uid gid symlink - (list source - "s" "777" "0" "0" - (string-append #$profile "/" target)))))) + ;; Create relative symlinks to work around a bug in + ;; Singularity 2.x: + ;; https://bugs.gnu.org/34913 + ;; https://github.com/sylabs/singularity/issues/1487 + (let ((target (string-append #$profile "/" target))) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (relative-file-name (dirname source) + target))))))) '#$symlinks) ;; Create empty mount points. "-p" "/proc d 555 0 0" "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0")) + "-p" "/dev d 555 0 0" + "-p" "/home d 555 0 0")) (when database ;; Initialize /var/guix. @@ -517,10 +527,14 @@ please email '~a'~%") ;;; (define* (wrapped-package package - #:optional (compiler (c-compiler))) + #:optional (compiler (c-compiler)) + #:key proot?) (define runner (local-file (search-auxiliary-file "run-in-namespace.c"))) + (define (proot) + (specification->package "proot-static")) + (define build (with-imported-modules (source-module-closure '((guix build utils) @@ -550,10 +564,19 @@ please email '~a'~%") (("@STORE_DIRECTORY@") (%store-directory))) (let* ((base (strip-store-prefix program)) - (result (string-append #$output "/" base))) + (result (string-append #$output "/" base)) + (proot #$(and proot? + #~(string-drop + #$(file-append (proot) "/bin/proot") + (+ (string-length (%store-directory)) + 1))))) (mkdir-p (dirname result)) - (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" - "run.c" "-o" result) + (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" + "run.c" "-o" result + (if proot + (list (string-append "-DPROOT_PROGRAM=\"" + proot "\"")) + '())) (delete-file "run.c"))) (setvbuf (current-output-port) 'line) @@ -573,7 +596,15 @@ please email '~a'~%") (find-files #$(file-append package "/sbin")) (find-files #$(file-append package "/libexec"))))))) - (computed-file (string-append (package-full-name package "-") "R") + (computed-file (string-append + (cond ((package? package) + (package-full-name package "-")) + ((inferior-package? package) + (string-append (inferior-package-name package) + "-" + (inferior-package-version package))) + (else "wrapper")) + "R") build)) (define (map-manifest-entries proc manifest) @@ -646,7 +677,12 @@ please email '~a'~%") (exit 0))) (option '(#\R "relocatable") #f #f (lambda (opt name arg result) - (alist-cons 'relocatable? #t result))) + (match (assq-ref result 'relocatable?) + (#f + (alist-cons 'relocatable? #t result)) + (_ + (alist-cons 'relocatable? 'proot + (alist-delete 'relocatable? result)))))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -821,11 +857,14 @@ Create a bundle of PACKAGE.\n")) #:graft? (assoc-ref opts 'graft?)))) (let* ((dry-run? (assoc-ref opts 'dry-run?)) (relocatable? (assoc-ref opts 'relocatable?)) + (proot? (eq? relocatable? 'proot)) (manifest (let ((manifest (manifest-from-args store opts))) ;; Note: We cannot honor '--bootstrap' here because ;; 'glibc-bootstrap' lacks 'libc.a'. (if relocatable? - (map-manifest-entries wrapped-package manifest) + (map-manifest-entries + (cut wrapped-package <> #:proot? proot?) + manifest) manifest))) (pack-format (assoc-ref opts 'format)) (name (string-append (symbol->string pack-format) @@ -851,7 +890,14 @@ Create a bundle of PACKAGE.\n")) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest - #:relative-symlinks? relocatable? + + ;; Always produce relative + ;; symlinks for Singularity (see + ;; <https://bugs.gnu.org/34913>). + #:relative-symlinks? + (or relocatable? + (eq? 'squashfs pack-format)) + #:hooks (if bootstrap? '() %default-profile-hooks) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index efff511299..b0c6a7ced7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -526,14 +527,14 @@ upgrading, #f otherwise." (define upgrade-regexps (filter-map (match-lambda (('upgrade . regexp) - (make-regexp* (or regexp ""))) + (make-regexp* (or regexp "") regexp/icase)) (_ #f)) opts)) (define do-not-upgrade-regexps (filter-map (match-lambda (('do-not-upgrade . regexp) - (make-regexp* regexp)) + (make-regexp* regexp regexp/icase)) (_ #f)) opts)) @@ -686,7 +687,7 @@ processed, #f otherwise." #t) (('list-installed regexp) - (let* ((regexp (and regexp (make-regexp* regexp))) + (let* ((regexp (and regexp (make-regexp* regexp regexp/icase))) (manifest (profile-manifest profile)) (installed (manifest-entries manifest))) (leave-on-EPIPE @@ -702,7 +703,7 @@ processed, #f otherwise." #t)) (('list-available regexp) - (let* ((regexp (and regexp (make-regexp* regexp))) + (let* ((regexp (and regexp (make-regexp* regexp regexp/icase))) (available (fold-available-packages (lambda* (name version result #:key outputs location diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d67b9f8185..97508f4bd6 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -808,8 +808,17 @@ and TARGET arguments." #~(begin (use-modules (gnu build bootloader) (guix build utils) - (ice-9 binary-ports)) - (#$installer #$bootloader #$device #$target))))) + (ice-9 binary-ports) + (srfi srfi-34) + (srfi srfi-35)) + + (guard (c ((message-condition? c) ;XXX: i18n + (format (current-error-port) "error: ~a~%" + (condition-message c)) + (exit 1))) + (#$installer #$bootloader #$device #$target) + (format #t "bootloader successfully installed on '~a'~%" + #$device)))))) (define* (perform-action action os #:key skip-safety-checks? |