Merge branch 'master' into core-updates

10 files changed, 104 insertions, 23 deletions

diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index a569848ae3..a359f405fe 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -53,6 +53,7 @@
   ;; Alist of default option values.
   `((system . ,(%current-system))
     (substitutes? . #t)
+    (build-hook? . #t)
     (graft? . #t)
     (verbosity . 0)))
 
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 9ffffe8ccd..4c85929858 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -150,6 +150,7 @@ Copy ITEMS to or from the specified host over SSH.\n"))
 (define %default-options
   `((system . ,(%current-system))
     (substitutes? . #t)
+    (build-hook? . #t)
     (graft? . #t)
     (verbosity . 0)))
 
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index e1b7feecfa..d2568e6a7d 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -178,6 +178,7 @@ COMMAND or an interactive shell in that environment.\n"))
 (define %default-options
   `((system . ,(%current-system))
     (substitutes? . #t)
+    (build-hook? . #t)
     (graft? . #t)
     (verbosity . 0)))
 
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 378a47d113..a31d2236b0 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -78,6 +78,21 @@ Invoke the garbage collector.\n"))
   (newline)
   (show-bug-report-information))
 
+(define argument->verify-options
+  (let ((not-comma (char-set-complement (char-set #\,)))
+        (validate  (lambda (option)
+                     (unless (memq option '(repair contents))
+                       (leave (G_ "~a: invalid '--verify' option~%")
+                              option)))))
+    (lambda (arg)
+      "Turn ARG into a list of symbols denoting '--verify' options."
+      (if arg
+          (let ((lst (map string->symbol
+                          (string-tokenize arg not-comma))))
+            (for-each validate lst)
+            lst)
+          '()))))
+
 (define %options
   ;; Specification of the command-line options.
   (list (option '(#\h "help") #f #f
@@ -112,16 +127,12 @@ Invoke the garbage collector.\n"))
                   (alist-cons 'action 'optimize
                               (alist-delete 'action result))))
         (option '("verify") #f #t
-                (let ((not-comma (char-set-complement (char-set #\,))))
-                  (lambda (opt name arg result)
-                    (let ((options (if arg
-                                       (map string->symbol
-                                            (string-tokenize arg not-comma))
-                                       '())))
-                      (alist-cons 'action 'verify
-                                  (alist-cons 'verify-options options
-                                              (alist-delete 'action
-                                                            result)))))))
+                (lambda (opt name arg result)
+                  (let ((options (argument->verify-options arg)))
+                    (alist-cons 'action 'verify
+                                (alist-cons 'verify-options options
+                                            (alist-delete 'action
+                                                          result))))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 1b43b0a63c..4ec3267007 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -881,10 +882,16 @@ the NIST server non-fatal."
                                      (or (and=> (package-source package)
                                                 origin-patches)
                                          '())))
+              (known-safe (or (assq-ref (package-properties package)
+                                        'lint-hidden-cve)
+                              '()))
               (unpatched (remove (lambda (vuln)
-                                   (find (cute string-contains
-                                           <> (vulnerability-id vuln))
-                                         patches))
+                                   (let ((id (vulnerability-id vuln)))
+                                     (or
+                                       (find (cute string-contains
+                                                   <> id)
+                                             patches)
+                                       (member id known-safe))))
                                  vulnerabilities)))
          (unless (null? unpatched)
            (emit-warning package
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index ebd0bf783d..7e114fa2c9 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -629,6 +630,32 @@ machine."
       (for-each assert-node-can-import nodes names sockets)
       (for-each assert-node-can-export nodes names sockets))))
 
+(define (check-machine-status machine-file pred)
+  "Print the load of each machine matching PRED in MACHINE-FILE."
+  (define (build-machine=? m1 m2)
+    (and (string=? (build-machine-name m1) (build-machine-name m2))
+         (= (build-machine-port m1) (build-machine-port m2))))
+
+  ;; A given build machine may appear several times (e.g., once for
+  ;; "x86_64-linux" and a second time for "i686-linux"); test them only once.
+  (let ((machines (filter pred
+                          (delete-duplicates (build-machines machine-file)
+                                             build-machine=?))))
+    (info (G_ "getting status of ~a build machines defined in '~a'...~%")
+          (length machines) machine-file)
+    (for-each (lambda (machine)
+                (let* ((node (make-node (open-ssh-session machine)))
+                       (uts (node-eval node '(uname))))
+                  (format #t "~a~%  kernel: ~a ~a~%  architecture: ~a~%\
+  host name: ~a~%  normalized load: ~a~%"
+                          (build-machine-name machine)
+                          (utsname:sysname uts) (utsname:release uts)
+                          (utsname:machine uts)
+                          (utsname:nodename uts)
+                          (parameterize ((current-error-port (%make-void-port "rw+")))
+                                        (machine-load machine)))))
+              machines)))
+
 
 ;;;
 ;;; Entry point.
@@ -691,6 +718,18 @@ machine."
                        (()     (values %machine-file (const #t)))
                        (x      (leave (G_ "wrong number of arguments~%"))))))
          (check-machine-availability (or file %machine-file) pred))))
+    (("status" rest ...)
+     (with-error-handling
+       (let-values (((file pred)
+                     (match rest
+                       ((file regexp)
+                        (values file
+                                (compose (cut string-match regexp <>)
+                                         build-machine-name)))
+                       ((file) (values file (const #t)))
+                       (()     (values %machine-file (const #t)))
+                       (x      (leave (G_ "wrong number of arguments~%"))))))
+         (check-machine-status (or file %machine-file) pred))))
     (("--version")
      (show-version-and-exit "guix offload"))
     (("--help")
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 21fea446a6..a22258d5a6 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -262,6 +262,7 @@ the image."
   `((format . tarball)
     (system . ,(%current-system))
     (substitutes? . #t)
+    (build-hook? . #t)
     (graft? . #t)
     (verbosity . 0)
     (symlinks . ())
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 0a4a07ae2a..617e102d93 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -360,7 +360,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE."
   ;; Alist of default option values.
   `((verbosity . 0)
     (graft? . #t)
-    (substitutes? . #t)))
+    (substitutes? . #t)
+    (build-hook? . #t)))
 
 (define (show-help)
   (display (G_ "Usage: guix package [OPTION]...
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index be0c168444..64c2196e03 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -89,6 +89,7 @@ Install it by running:
     (ref . (branch . "origin/master"))
     (system . ,(%current-system))
     (substitutes? . #t)
+    (build-hook? . #t)
     (graft? . #t)
     (verbosity . 0)))
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e2ff42693f..36aed3331f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -674,9 +674,11 @@ any, are available.  Raise an error if they're not."
 and TARGET arguments."
   (with-monad %store-monad
     (gexp->file "bootloader-installer"
-                (with-imported-modules '((guix build utils))
+                (with-imported-modules '((gnu build bootloader)
+                                         (guix build utils))
                   #~(begin
-                      (use-modules (guix build utils)
+                      (use-modules (gnu build bootloader)
+                                   (guix build utils)
                                    (ice-9 binary-ports))
                       (#$installer #$bootloader #$device #$target))))))
 
@@ -856,6 +858,9 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
   -d, --derivation       return the derivation of the given system"))
   (display (G_ "
+  -e, --expression=EXPR  consider the operating-system EXPR evaluates to
+                         instead of reading FILE, when applicable"))
+  (display (G_ "
       --on-error=STRATEGY
                          apply STRATEGY when an error occurs while reading FILE"))
   (display (G_ "
@@ -893,6 +898,9 @@ Some ACTIONS support additional ARGS.\n"))
          (option '(#\V "version") #f #f
                  (lambda args
                    (show-version-and-exit "guix system")))
+         (option '(#\e "expression") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'expression arg result)))
          (option '(#\d "derivation") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'derivations-only? #t result)))
@@ -942,8 +950,8 @@ Some ACTIONS support additional ARGS.\n"))
   ;; Alist of default option values.
   `((system . ,(%current-system))
     (substitutes? . #t)
-    (graft? . #t)
     (build-hook? . #t)
+    (graft? . #t)
     (verbosity . 0)
     (file-system-type . "ext4")
     (image-size . guess)
@@ -962,11 +970,19 @@ resulting from command-line parsing."
   (let* ((file        (match args
                         (() #f)
                         ((x . _) x)))
+         (expr        (assoc-ref opts 'expression))
          (system      (assoc-ref opts 'system))
-         (os          (if file
-                          (load* file %user-module
-                                 #:on-error (assoc-ref opts 'on-error))
-                          (leave (G_ "no configuration file specified~%"))))
+         (os          (cond
+                       ((and expr file)
+                        (leave
+                         (G_ "both file and expression cannot be specified~%")))
+                       (expr
+                        (read/eval expr))
+                       (file
+                        (load* file %user-module
+                                    #:on-error (assoc-ref opts 'on-error)))
+                       (else
+                        (leave (G_ "no configuration specified~%")))))
 
          (dry?        (assoc-ref opts 'dry-run?))
          (bootloader? (assoc-ref opts 'install-bootloader?))
@@ -1077,7 +1093,8 @@ argument list and OPTS is the option alist."
     ;; Extract the plain arguments from OPTS.
     (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
            (count  (length args))
-           (action (assoc-ref opts 'action)))
+           (action (assoc-ref opts 'action))
+           (expr   (assoc-ref opts 'expression)))
       (define (fail)
         (leave (G_ "wrong number of arguments for action '~a'~%")
                action))
@@ -1091,7 +1108,8 @@ argument list and OPTS is the option alist."
 
       (case action
         ((build container vm vm-image disk-image reconfigure)
-         (unless (= count 1)
+         (unless (or (= count 1)
+                     (and expr (= count 0)))
            (fail)))
         ((init)
          (unless (= count 2)