diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 76 | ||||
| -rw-r--r-- | guix/scripts/import/cran.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/import/elpa.scm | 26 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 25 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 46 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 430 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 97 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 41 | ||||
| -rw-r--r-- | guix/scripts/system/search.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 8 |
11 files changed, 565 insertions, 237 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 401087e830..4dd4fbccdf 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -661,43 +661,47 @@ build." (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) - (parameterize ((%graft? graft?)) - (append-map (match-lambda - ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (G_ "~a: warning: \ + ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields + ;; of user packages. Since 'guix build' is the primary tool for people + ;; testing new packages, report such errors gracefully. + (with-unbound-variable-handling + (parameterize ((%graft? graft?)) + (append-map (match-lambda + ((? package? p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (G_ "~a: warning: \ package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) - ((? derivation? drv) - (list drv)) - ((? procedure? proc) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - ((? gexp? gexp) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system)))))) - (map (cut transform store <>) - (options->things-to-build opts))))) + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)))))) + (map (cut transform store <>) + (options->things-to-build opts)))))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index d65c644c05..30ae6d4342 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -99,8 +99,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse (stream->list (recursive-import package-name - (or (assoc-ref opts 'repo) 'cran))))) + (reverse + (stream->list + (cran-recursive-import package-name + (or (assoc-ref opts 'repo) 'cran))))) ;; Single import (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index 34eb16485e..f1ed5016ba 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,10 +22,12 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import elpa) + #:use-module (guix import utils) #:use-module (guix scripts import) #: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-elpa)) @@ -45,6 +48,8 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive generate package expressions for all Emacs packages that are not yet in Guix")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -62,6 +67,9 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (lambda (opt name arg result) (alist-cons 'repo (string->symbol arg) (alist-delete 'repo result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -87,10 +95,20 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) - (unless sexp - (leave (G_ "failed to download package '~a'~%") package-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 + (elpa-recursive-import package-name + (or (assoc-ref opts 'repo) 'gnu))))) + (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) + (unless sexp + (leave (G_ "failed to download package '~a'~%") package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4ec3267007..e477bf0ddc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -809,15 +809,6 @@ descriptions maintained upstream." (emit-warning package (G_ "invalid license field") 'license)))) -(define (patch-file-name patch) - "Return the basename of PATCH's file name, or #f if the file name could not -be determined." - (match patch - ((? string?) - (basename patch)) - ((? origin?) - (and=> (origin-actual-file-name patch) basename)))) - (define (call-with-networking-fail-safe message error-value proc) "Call PROC catching any network-related errors. Upon a networking error, display a message including MESSAGE and return ERROR-VALUE." @@ -878,20 +869,14 @@ the NIST server non-fatal." (() #t) ((vulnerabilities ...) - (let* ((patches (filter-map patch-file-name - (or (and=> (package-source package) - origin-patches) - '()))) + (let* ((patched (package-patched-vulnerabilities package)) (known-safe (or (assq-ref (package-properties package) 'lint-hidden-cve) '())) (unpatched (remove (lambda (vuln) (let ((id (vulnerability-id vuln))) - (or - (find (cute string-contains - <> id) - patches) - (member id known-safe)))) + (or (member id patched) + (member id known-safe)))) vulnerabilities))) (unless (null? unpatched) (emit-warning package @@ -1037,7 +1022,7 @@ them for PACKAGE." (check check-inputs-should-be-native)) (lint-checker (name 'inputs-should-not-be-input) - (description "Identify inputs that should be inputs at all") + (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) (lint-checker (name 'patch-file-names) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 56d6de6308..fb61d7c059 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -494,6 +494,30 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (() (values #f #f)))))) +(define (call-with-timeout timeout drv thunk) + "Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call +THUNK. Use DRV as an indication of what we were building when the timeout +expired." + (if (number? timeout) + (dynamic-wind + (lambda () + (sigaction SIGALRM + (lambda _ + ;; The exit code here will be 1, which guix-daemon will + ;; interpret as a transient failure. + (leave (G_ "timeout expired while offloading '~a'~%") + (derivation-file-name drv)))) + (alarm timeout)) + thunk + (lambda () + (alarm 0))) + (thunk))) + +(define-syntax-rule (with-timeout timeout drv exp ...) + "Evaluate EXP... and leave after TIMEOUT seconds if EXP hasn't completed. +If TIMEOUT is #f, simply evaluate EXP..." + (call-with-timeout timeout drv (lambda () exp ...))) + (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) @@ -520,13 +544,18 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (display "# accept\n") (let ((inputs (string-tokenize (read-line))) (outputs (string-tokenize (read-line)))) - (transfer-and-offload drv machine - #:inputs inputs - #:outputs outputs - #:max-silent-time max-silent-time - #:build-timeout build-timeout - #:print-build-trace? - print-build-trace?))) + ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can + ;; be issues with the connection or deadlocks that could + ;; lead the 'guix offload' process to remain stuck forever. + ;; To avoid that, install a timeout here as well. + (with-timeout build-timeout drv + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? + print-build-trace?)))) (lambda () (release-build-slot slot))) @@ -755,6 +784,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) ;;; eval: (put 'with-file-lock 'scheme-indent-function 1) ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) +;;; eval: (put 'with-timeout 'scheme-indent-function 2) ;;; End: ;;; offload.scm ends here diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 488638adc5..76729d8e10 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; @@ -32,17 +32,20 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system gnu) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (gnu packages compression) #:use-module (gnu packages guile) - #:autoload (gnu packages base) (tar) + #:use-module (gnu packages base) #:autoload (gnu packages package-management) (guix) #:autoload (gnu packages gnupg) (libgcrypt) #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (compressor? @@ -90,7 +93,7 @@ found." (compressor (first %compressors)) localstatedir? (symlinks '()) - (tar tar)) + (archiver tar)) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -99,11 +102,14 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." (define build - (with-imported-modules '((guix build utils) - (guix build store-copy) - (gnu build install)) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build union) + (guix build store-copy) + (gnu build install))) #~(begin (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) (gnu build install) (srfi srfi-1) (srfi srfi-26) @@ -116,9 +122,17 @@ added to the pack." ;; parent directories. (match-lambda ((source '-> target) - (let ((target (string-append #$profile "/" target))) - `((directory ,(dirname source)) - (,source -> ,target)))))) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) (define directives ;; Fully-qualified symlinks. @@ -128,7 +142,7 @@ added to the pack." ;; 2014-07-28. For testing, we use the bootstrap tar, which is ;; older and doesn't support it. (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") + (zero? (system* (string-append #+archiver "/bin/tar") "cf" "/dev/null" "--files-from=/dev/null" "--sort=name"))) @@ -137,11 +151,13 @@ added to the pack." (string-append #$(if localstatedir? (file-append guix "/sbin:") "") - #$tar "/bin")) + #$archiver "/bin")) - ;; Note: there is not much to gain here with deduplication and - ;; there is the overhead of the '.links' directory, so turn it - ;; off. + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. (populate-single-profile-directory %root #:profile #$profile #:closure "profile" @@ -188,6 +204,8 @@ added to the pack." (filter-map (match-lambda (('directory directory) (string-append "." directory)) + ((source '-> _) + (string-append "." source)) (_ #f)) directives))))))))) @@ -196,13 +214,97 @@ added to the pack." build #:references-graphs `(("profile" ,profile)))) +(define* (squashfs-image name profile + #:key target + deduplicate? + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver squashfs-tools-next)) + "Return a squashfs image containing a store initialized with the closure of +PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount +points for virtual file systems (like procfs), and optional symlinks. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." + (define build + (with-imported-modules '((guix build utils) + (guix build store-copy) + (gnu build install)) + #~(begin + (use-modules (guix build utils) + (gnu build install) + (guix build store-copy) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (setenv "PATH" (string-append #$archiver "/bin")) + + ;; We need an empty file in order to have a valid file argument when + ;; we reparent the root file system. Read on for why that's + ;; necessary. + (with-output-to-file ".empty" (lambda () (display ""))) + + ;; Create the squashfs image in several steps. + ;; Add all store items. Unfortunately mksquashfs throws away all + ;; ancestor directories and only keeps the basename. We fix this + ;; in the following invocations of mksquashfs. + (apply invoke "mksquashfs" + `(,@(call-with-input-file "profile" + read-reference-graph) + ,#$output + + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) + + ;; Here we reparent the store items. For each sub-directory of + ;; the store prefix we need one invocation of "mksquashfs". + (for-each (lambda (dir) + (apply invoke "mksquashfs" + `(".empty" + ,#$output + "-root-becomes" ,dir))) + (reverse (string-tokenize (%store-directory) + (char-set-complement (char-set #\/))))) + + ;; Add symlinks and mount points. + (apply invoke "mksquashfs" + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(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)))))) + '#$symlinks) + + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0"))))) + + (gexp->derivation (string-append name + (compressor-extension compressor) + ".squashfs") + build + #:references-graphs `(("profile" ,profile)))) + (define* (docker-image name profile #:key target deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) - (tar tar)) + (archiver tar)) "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -216,11 +318,13 @@ the image." (('gnu rest ...) #t) (rest #f))) + (define defmod 'define-module) ;trick Geiser + (define config ;; (guix config) module for consumption by (guix gcrypt). (scheme-file "gcrypt-config.scm" #~(begin - (define-module (guix config) + (#$defmod (guix config) #:export (%libgcrypt)) ;; XXX: Work around <http://bugs.gnu.org/15602>. @@ -236,28 +340,25 @@ the image." guile-json)) (define build - (with-imported-modules `(,@(source-module-closure '((guix docker)) - #:select? not-config?) - (guix build store-copy) - ((guix config) => ,config)) - #~(begin - ;; Guile-JSON is required by (guix docker). - (add-to-load-path - (string-append #+json "/share/guile/site/" - (effective-version))) - - (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) - - (setenv "PATH" (string-append #$tar "/bin")) - - (build-docker-image #$output - (call-with-input-file "profile" - read-reference-graph) - #$profile - #:system (or #$target (utsname:machine (uname))) - #:symlinks '#$symlinks - #:compressor '#$(compressor-command compressor) - #:creation-time (make-time time-utc 0 1))))) + ;; Guile-JSON is required by (guix docker). + (with-extensions (list json) + (with-imported-modules `(,@(source-module-closure '((guix docker)) + #:select? not-config?) + (guix build store-copy) + ((guix config) => ,config)) + #~(begin + (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) + + (setenv "PATH" (string-append #$archiver "/bin")) + + (build-docker-image #$output + (call-with-input-file "profile" + read-reference-graph) + #$profile + #:system (or #$target (utsname:machine (uname))) + #:symlinks '#$symlinks + #:compressor '#$(compressor-command compressor) + #:creation-time (make-time time-utc 0 1)))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -266,6 +367,165 @@ the image." ;;; +;;; Compiling C programs. +;;; + +;; A C compiler. That lowers to a single program that can be passed typical C +;; compiler flags, and it makes sure the whole toolchain is available. +(define-record-type <c-compiler> + (%c-compiler toolchain guile) + c-compiler? + (toolchain c-compiler-toolchain) + (guile c-compiler-guile)) + +(define* (c-compiler #:optional inputs + #:key (guile (default-guile))) + (%c-compiler inputs guile)) + +(define (bootstrap-c-compiler) + "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")))) + + (c-compiler bootstrap-toolchain + #:guile %bootstrap-guile)) + +(define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target) + "Lower COMPILER to a single script that does the right thing." + (define toolchain + (or (c-compiler-toolchain compiler) + (list (first (assoc-ref (standard-packages) "gcc")) + (first (assoc-ref (standard-packages) "ld-wrapper")) + (first (assoc-ref (standard-packages) "binutils")) + (first (assoc-ref (standard-packages) "libc")) + (gexp-input (first (assoc-ref (standard-packages) "libc")) + "static")))) + + (define inputs + (match (append-map package-propagated-inputs + (filter package? toolchain)) + (((labels things . _) ...) + (append toolchain things)))) + + (define search-paths + (cons $PATH + (append-map package-native-search-paths + (filter package? inputs)))) + + (define run + (with-imported-modules (source-module-closure + '((guix build utils) + (guix search-paths))) + #~(begin + (use-modules (guix build utils) (guix search-paths) + (ice-9 match)) + + (define (output-file args) + (let loop ((args args)) + (match args + (() "a.out") + (("-o" file _ ...) file) + ((head rest ...) (loop rest))))) + + (set-search-paths (map sexp->search-path-specification + '#$(map search-path-specification->sexp + search-paths)) + '#$inputs) + + (let ((output (output-file (command-line)))) + (apply invoke "gcc" (cdr (command-line))) + (invoke "strip" output))))) + + (when target + ;; TODO: Yep, we'll have to do it someday! + (leave (G_ "cross-compilation not implemented here; +please email '~a'~%") + (@ (guix config) %guix-bug-report-address))) + + (gexp->script "c-compiler" run + #:guile (c-compiler-guile compiler))) + + +;;; +;;; Wrapped package. +;;; + +(define* (wrapped-package package + #:optional (compiler (c-compiler))) + (define runner + (local-file (search-auxiliary-file "run-in-namespace.c"))) + + (define build + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build union))) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (ice-9 ftw) + (ice-9 match)) + + (define (strip-store-prefix file) + ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return + ;; "/bin/foo". + (let* ((len (string-length (%store-directory))) + (base (string-drop file (+ 1 len)))) + (match (string-index base #\/) + (#f base) + (index (string-drop base index))))) + + (define (build-wrapper program) + ;; Build a user-namespace wrapper for PROGRAM. + (format #t "building wrapper for '~a'...~%" program) + (copy-file #$runner "run.c") + + (substitute* "run.c" + (("@WRAPPED_PROGRAM@") program) + (("@STORE_DIRECTORY@") (%store-directory))) + + (let* ((base (strip-store-prefix program)) + (result (string-append #$output "/" base))) + (mkdir-p (dirname result)) + (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" + "run.c" "-o" result) + (delete-file "run.c"))) + + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) + (else _IOLBF))) + + ;; Link the top-level files of PACKAGE so that search paths are + ;; properly defined in PROFILE/etc/profile. + (mkdir #$output) + (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)) + + (for-each build-wrapper + (append (find-files #$(file-append package "/bin")) + (find-files #$(file-append package "/sbin")) + (find-files #$(file-append package "/libexec"))))))) + + (computed-file (string-append (package-full-name package "-") "R") + build)) + +(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)))) + + +;;; ;;; Command-line options. ;;; @@ -283,6 +543,7 @@ the image." (define %formats ;; Supported pack formats. `((tarball . ,self-contained-tarball) + (squashfs . ,squashfs-image) (docker . ,docker-image))) (define %options @@ -301,6 +562,9 @@ the image." (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '(#\R "relocatable") #f #f + (lambda (opt name arg result) + (alist-cons 'relocatable? #t result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -353,6 +617,8 @@ Create a bundle of PACKAGE.\n")) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " + -R, --relocatable produce relocatable executables")) + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) @@ -397,9 +663,15 @@ Create a bundle of PACKAGE.\n")) (read/eval-package-expression exp)) (x #f))) - (define (manifest-from-args opts) - (let ((packages (filter-map maybe-package-argument opts)) - (manifest-file (assoc-ref opts 'manifest))) + (define (manifest-from-args store opts) + (let* ((transform (options->transformation opts)) + (packages (map (match-lambda + (((? package? package) output) + (list (transform store package) output)) + ((? package? package) + (list (transform store package) "out"))) + (filter-map maybe-package-argument opts))) + (manifest-file (assoc-ref opts 'manifest))) (cond ((and manifest-file (not (null? packages))) (leave (G_ "both a manifest and a package list were given~%"))) @@ -409,39 +681,49 @@ Create a bundle of PACKAGE.\n")) (else (packages->manifest packages))))) (with-error-handling - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (manifest (manifest-from-args opts)) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (tar (if bootstrap? - %bootstrap-coreutils&co - tar)) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format") - format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) - (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - + (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (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) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools-next + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format") + format)))) + (localstatedir? (assoc-ref opts 'localstatedir?))) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest + #:relative-symlinks? relocatable? #:hooks (if bootstrap? '() %default-profile-hooks) @@ -456,8 +738,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? - #:tar - tar))) + #:archiver + archiver))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4f519e6f33..29829f52c8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -64,46 +64,6 @@ ;;; Profiles. ;;; -(define %user-profile-directory - (and=> (getenv "HOME") - (cut string-append <> "/.guix-profile"))) - -(define %profile-directory - (string-append %state-directory "/profiles/" - (or (and=> (or (getenv "USER") - (getenv "LOGNAME")) - (cut string-append "per-user/" <>)) - "default"))) - -(define %current-profile - ;; Call it `guix-profile', not `profile', to allow Guix profiles to - ;; coexist with Nix profiles. - (string-append %profile-directory "/guix-profile")) - -(define (canonicalize-profile profile) - "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise -return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if -'-p' was omitted." ; see <http://bugs.gnu.org/17939> - - ;; Trim trailing slashes so that the basename comparison below works as - ;; intended. - (let ((profile (string-trim-right profile #\/))) - (if (and %user-profile-directory - (string=? (canonicalize-path (dirname profile)) - (dirname %user-profile-directory)) - (string=? (basename profile) (basename %user-profile-directory))) - %current-profile - profile))) - -(define (user-friendly-profile profile) - "Return either ~/.guix-profile if that's what PROFILE refers to, directly or -indirectly, or PROFILE." - (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) profile))) - %user-profile-directory - profile)) - (define (ensure-default-profile) "Ensure the default profile symlink and directory exist and are writable." diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 64c2196e03..499de0ec45 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -25,10 +25,15 @@ #:use-module (guix config) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix profiles) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix scripts build) + #:autoload (guix self) (whole-package) + #:autoload (gnu packages ssh) (guile-ssh) + #:autoload (gnu packages tls) (gnutls) + #:use-module ((guix scripts package) #:select (build-and-use-profile)) #:use-module ((guix build utils) #:select (with-directory-excursion delete-file-recursively)) #:use-module ((guix build download) @@ -158,6 +163,12 @@ Download and deploy the latest version of Guix.\n")) ;; a makefile, and, similarly, is intended to always keep this name. "build-aux/build-self.scm") +(define %pull-version + ;; This is the version of the 'guix pull' protocol. It specifies what's + ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd + ;; place a set of compiled Guile modules in ~/.config/guix/latest. + 1) + (define* (build-from-source source #:key verbose? commit) "Return a derivation to build Guix from SOURCE, using the self-build script @@ -170,35 +181,62 @@ contained therein. Use COMMIT as the version string." (build (primitive-load script))) ;; BUILD must be a monadic procedure of at least one argument: the source ;; tree. - (build source #:verbose? verbose? #:version commit))) + ;; + ;; 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))) + +(define (whole-package-for-legacy name modules) + "Return a full-blown Guix package for MODULES, a derivation that builds Guix +modules in the old ~/.config/guix/latest style." + (whole-package name modules + + ;; In the "old style", %SELF-BUILD-FILE would simply return a + ;; derivation that builds modules. We have to infer what the + ;; dependencies of these modules were. + (list guile-json guile-git guile-bytestructures + guile-ssh gnutls))) + +(define* (derivation->manifest-entry drv + #:key url branch commit) + "Return a manifest entry for DRV, which represents Guix at COMMIT. Record +URL, BRANCH, and COMMIT as a property in the manifest entry." + (mbegin %store-monad + (what-to-build (list drv)) + (built-derivations (list drv)) + (let ((out (derivation->output-path drv))) + (return (manifest-entry + (name "guix") + (version (string-take commit 7)) + (item (if (file-exists? (string-append out "/bin/guix")) + drv + (whole-package-for-legacy (string-append name "-" + version) + drv))) + (properties + `((source (repository + (version 0) + (url ,url) + (branch ,branch) + (commit ,commit)))))))))) (define* (build-and-install source config-dir - #:key verbose? commit) + #:key verbose? url branch commit) "Build the tool from SOURCE, and install it in CONFIG-DIR." - (mlet* %store-monad ((source (build-from-source source - #:commit commit - #:verbose? verbose?)) - (source-dir -> (derivation->output-path source)) - (to-do? (what-to-build (list source))) - (built? (built-derivations (list source)))) - ;; Always update the 'latest' symlink, regardless of whether SOURCE was - ;; already built or not. - (if built? - (mlet* %store-monad - ((latest -> (string-append config-dir "/latest")) - (done (indirect-root-added latest))) - (if (and (file-exists? latest) - (string=? (readlink latest) source-dir)) - (begin - (display (G_ "Guix already up to date\n")) - (return #t)) - (begin - (switch-symlinks latest source-dir) - (format #t - (G_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - (return #t)))) - (leave (G_ "failed to update Guix, check the build log~%"))))) + (define update-profile + (store-lift build-and-use-profile)) + + (mlet* %store-monad ((drv (build-from-source source + #:commit commit + #:verbose? verbose?)) + (entry (derivation->manifest-entry drv + #:url url + #:branch branch + #:commit commit))) + (update-profile (string-append config-dir "/current") + (manifest (list entry))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -279,6 +317,11 @@ certificates~%")) (canonical-package guile-2.2))))) (run-with-store store (build-and-install checkout (config-directory) + #:url url + #:branch (match ref + (('branch . branch) + branch) + (_ #f)) #:commit commit #:verbose? (assoc-ref opts 'verbose?)))))))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index af501eb8f7..14be8ff8cf 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -393,9 +393,11 @@ it atomically, and then run OS's activation script." "~Y-~m-~d ~H:~M"))) (define* (profile-boot-parameters #:optional (profile %system-profile) - (numbers (generation-numbers profile))) - "Return a list of 'boot-parameters' for the generations of PROFILE specified by -NUMBERS, which is a list of generation numbers." + (numbers + (reverse (generation-numbers profile)))) + "Return a list of 'boot-parameters' for the generations of PROFILE specified +by NUMBERS, which is a list of generation numbers. The list is ordered from +the most recent to the oldest profiles." (define (system->boot-parameters system number time) (unless-file-not-found (let* ((params (read-boot-parameters-file system)) @@ -590,17 +592,17 @@ any, are available. Raise an error if they're not." (define labeled (filter (lambda (fs) - (eq? (file-system-title fs) 'label)) + (file-system-label? (file-system-device fs))) relevant)) (define literal (filter (lambda (fs) - (eq? (file-system-title fs) 'device)) + (string? (file-system-device fs))) relevant)) (define uuid (filter (lambda (fs) - (eq? (file-system-title fs) 'uuid)) + (uuid? (file-system-device fs))) relevant)) (define fail? #f) @@ -628,15 +630,15 @@ any, are available. Raise an error if they're not." (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system -label, you need to add @code{(title 'label)} to your @code{file-system} -definition.") - device))))))) +label, write @code{(file-system-label ~s)} in your @code{device} field.") + device device))))))) literal) (for-each (lambda (fs) - (unless (find-partition-by-label (file-system-device fs)) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) - (file-system-device fs)))) + (let ((label (file-system-label->string + (file-system-device fs)))) + (unless (find-partition-by-label label) + (error (G_ "~a: error: file system with label '~a' not found~%") + (file-system-location* fs) label)))) labeled) (for-each (lambda (fs) (unless (find-partition-by-uuid (file-system-device fs)) @@ -677,10 +679,13 @@ available in the initrd. Note that mapped devices are responsible for checking this by themselves in their 'check' procedure." (define (file-system-/dev fs) (let ((device (file-system-device fs))) - (match (file-system-title fs) - ('device device) - ('uuid (find-partition-by-uuid device)) - ('label (find-partition-by-label device))))) + (match device + ((? string?) + device) + ((? uuid?) + (find-partition-by-uuid device)) + ((? file-system-label?) + (find-partition-by-label (file-system-label->string device)))))) (define file-systems (filter file-system-needed-for-boot? @@ -735,7 +740,7 @@ checking this by themselves in their 'check' procedure." ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for ;; a discussion. (define latest - (string-append (config-directory) "/latest")) + (string-append (config-directory) "/current")) (unless (file-exists? latest) (warning (G_ "~a not found: 'guix pull' was never run~%") latest) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index 7229c60a02..955cdd1e95 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,10 +60,8 @@ provided TYPE has a default value." (define (service-type-shepherd-names type) "Return the default names of Shepherd services created for TYPE." - (match (map shepherd-service-provision - (service-type-default-shepherd-services type)) - (((names . _) ...) - names))) + (append-map shepherd-service-provision + (service-type-default-shepherd-services type))) (define* (service-type->recutils type port #:optional (width (%text-width)) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 5c934abaef..d7c2fbea10 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -208,10 +208,10 @@ unavailable)~%")) 0 queue))) (newline) (unless (null? missing) - (let ((missing (length missing))) - (match (queued-subset queue missing) - (#f #f) - ((= length queued) + (match (queued-subset queue missing) + (#f #f) + ((= length queued) + (let ((missing (length missing))) (format #t (G_ " ~,1f% (~h out of ~h) of the missing items \ are queued~%") (* 100. (/ queued missing)) |