Merge branch 'master' into core-updates

6 files changed, 97 insertions, 45 deletions

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 03f455ab7b..d3b8b57ccc 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -48,7 +48,8 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (srfi srfi-98)
-  #:export (guix-environment))
+  #:export (assert-container-features
+            guix-environment))
 
 ;; Protect some env vars from purification.  Borrowed from nix-shell.
 (define %precious-variables
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 518bf6e7e3..e0f9cc1a12 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -81,6 +82,11 @@
                     #~(#+(file-append xz "/bin/xz") "-e"))
         (compressor "bzip2" ".bz2"
                     #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
+        (compressor "zstd" ".zst"
+                    ;; The default level 3 compresses better than gzip in a
+                    ;; fraction of the time, while the highest level 19
+                    ;; (de)compresses more slowly and worse than xz.
+                    #~(#+(file-append zstd "/bin/zstd") "-3"))
         (compressor "none" "" #f)))
 
 ;; This one is only for use in this module, so don't put it in %compressors.
@@ -140,13 +146,16 @@ dependencies are registered."
             (define (read-closure closure)
               (call-with-input-file closure read-reference-graph))
 
+            (define db-file
+              (store-database-file #:state-directory #$output))
+
+            (sql-schema #$schema)
             (let ((items (append-map read-closure '#$labels)))
-              (register-items items
-                              #:state-directory #$output
-                              #:deduplicate? #f
-                              #:reset-timestamps? #f
-                              #:registration-time %epoch
-                              #:schema #$schema))))))
+              (with-database db-file db
+                (register-items db items
+                                #:deduplicate? #f
+                                #:reset-timestamps? #f
+                                #:registration-time %epoch)))))))
 
   (computed-file "store-database" build
                  #:options `(#:references-graphs ,(zip labels items))))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index c386d81b8e..f953957161 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -82,6 +82,7 @@
     (graft? . #t)
     (debug . 0)
     (verbosity . 1)
+    (authenticate-channels? . #t)
     (validate-pull . ,ensure-forward-channel-update)))
 
 (define (show-help)
@@ -98,6 +99,9 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --allow-downgrades allow downgrades to earlier channel revisions"))
   (display (G_ "
+      --disable-authentication
+                         disable channel authentication"))
+  (display (G_ "
   -N, --news             display news compared to the previous generation"))
   (display (G_ "
   -l, --list-generations[=PATTERN]
@@ -165,6 +169,9 @@ Download and deploy the latest version of Guix.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'validate-pull warn-about-backward-updates
                                result)))
+         (option '("disable-authentication") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'authenticate-channels? #f result)))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'profile (canonicalize-profile arg)
@@ -195,20 +202,18 @@ Download and deploy the latest version of Guix.\n"))
 
          %standard-build-options))
 
-(define (warn-about-backward-updates channel start instance relation)
-  "Warn about non-forward updates of CHANNEL from START to INSTANCE, without
+(define (warn-about-backward-updates channel start commit relation)
+  "Warn about non-forward updates of CHANNEL from START to COMMIT, without
 aborting."
   (match relation
     ((or 'ancestor 'self)
      #t)
     ('descendant
      (warning (G_ "rolling back channel '~a' from ~a to ~a~%")
-              (channel-name channel) start
-              (channel-instance-commit instance)))
+              (channel-name channel) start commit))
     ('unrelated
      (warning (G_ "moving channel '~a' from ~a to unrelated commit ~a~%")
-              (channel-name channel) start
-              (channel-instance-commit instance)))))
+              (channel-name channel) start commit))))
 
 (define* (display-profile-news profile #:key concise?
                                current-is-newer?)
@@ -773,7 +778,8 @@ Use '~/.config/guix/channels.scm' instead."))
             (channels     (channel-list opts))
             (profile      (or (assoc-ref opts 'profile) %current-profile))
             (current-channels (profile-channels profile))
-            (validate-pull    (assoc-ref opts 'validate-pull)))
+            (validate-pull    (assoc-ref opts 'validate-pull))
+            (authenticate?    (assoc-ref opts 'authenticate-channels?)))
        (cond ((assoc-ref opts 'query)
               (process-query opts profile))
              ((assoc-ref opts 'generation)
@@ -795,7 +801,9 @@ Use '~/.config/guix/channels.scm' instead."))
                                                        #:current-channels
                                                        current-channels
                                                        #:validate-pull
-                                                       validate-pull)))
+                                                       validate-pull
+                                                       #:authenticate?
+                                                       authenticate?)))
                         (format (current-error-port)
                                 (N_ "Building from this channel:~%"
                                     "Building from these channels:~%"
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
index ff1f208894..0ea9c3655c 100644
--- a/guix/scripts/repl.scm
+++ b/guix/scripts/repl.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@
   #:use-module (guix scripts)
   #:use-module (guix repl)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
@@ -32,7 +34,8 @@
 
 ;;; Commentary:
 ;;;
-;;; This command provides a Guile REPL
+;;; This command provides a Guile script runner and REPL in an environment
+;;; that contains all the modules comprising Guix.
 
 (define %default-options
   `((type . guile)))
@@ -63,8 +66,9 @@
 
 
 (define (show-help)
-  (display (G_ "Usage: guix repl [OPTIONS...]
-Start a Guile REPL in the Guix execution environment.\n"))
+  (display (G_ "Usage: guix repl [OPTIONS...] [-- FILE ARGS...]
+In the Guix execution environment, run FILE as a Guile script with
+command-line arguments ARGS.  If no FILE is given, start a Guile REPL.\n"))
   (display (G_ "
   -t, --type=TYPE        start a REPL of the given TYPE"))
   (display (G_ "
@@ -135,12 +139,13 @@ call THUNK."
 
 (define (guix-repl . args)
   (define opts
-    ;; Return the list of package names.
     (args-fold* args %options
                 (lambda (opt name arg result)
                   (leave (G_ "~A: unrecognized option~%") name))
                 (lambda (arg result)
-                  (leave (G_ "~A: extraneous argument~%") arg))
+                  (append `((script . ,arg)
+                            (ignore-dot-guile? . #t))
+                          result))
                 %default-options))
 
   (define user-config
@@ -148,28 +153,48 @@ call THUNK."
            (lambda (home)
              (string-append home "/.guile"))))
 
+  (define (set-user-module)
+    (set-current-module user-module)
+    (when (and (not (assoc-ref opts 'ignore-dot-guile?))
+               user-config
+               (file-exists? user-config))
+      (load user-config)))
+
+  (define script
+    (reverse
+     (filter-map (match-lambda
+                   (('script . script) script)
+                   (_ #f))
+                 opts)))
+
   (with-error-handling
-    (let ((type (assoc-ref opts 'type)))
-      (call-with-connection (assoc-ref opts 'listen)
-        (lambda ()
-          (case type
-            ((guile)
-             (save-module-excursion
-              (lambda ()
-                (set-current-module user-module)
-                (when (and (not (assoc-ref opts 'ignore-dot-guile?))
-                           user-config
-                           (file-exists? user-config))
-                  (load user-config))
 
-                ;; Do not exit repl on SIGINT.
-                ((@@ (ice-9 top-repl) call-with-sigint)
-                 (lambda ()
-                   (start-repl))))))
-            ((machine)
-             (machine-repl))
-            (else
-             (leave (G_ "~a: unknown type of REPL~%") type))))))))
+    (unless (null? script)
+      ;; Run script
+      (save-module-excursion
+       (lambda ()
+         (set-program-arguments script)
+         (set-user-module)
+         (load-in-vicinity "." (car script)))))
+
+    (when (null? script)
+      ;; Start REPL
+      (let ((type (assoc-ref opts 'type)))
+        (call-with-connection (assoc-ref opts 'listen)
+          (lambda ()
+            (case type
+              ((guile)
+               (save-module-excursion
+                (lambda ()
+                  (set-user-module)
+                  ;; Do not exit repl on SIGINT.
+                  ((@@ (ice-9 top-repl) call-with-sigint)
+                   (lambda ()
+                     (start-repl))))))
+              ((machine)
+               (machine-repl))
+              (else
+               (leave (G_ "~a: unknown type of REPL~%") type)))))))))
 
 ;; Local Variables:
 ;; eval: (put 'call-with-connection 'scheme-indent-function 1)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 6769a602b1..212b49f008 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -802,8 +802,8 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((target    (current-target-system))
-       (image ->  (find-image file-system-type target))
+      ((target*   (current-target-system))
+       (image ->  (find-image file-system-type target*))
        (sys       (system-derivation-for-action os image action
                                                 #:file-system-type file-system-type
                                                 #:image-size image-size
diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm
index 1e800e160f..f9bcec651a 100644
--- a/guix/scripts/time-machine.scm
+++ b/guix/scripts/time-machine.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Konrad Hinsen <konrad.hinsen@fastmail.net>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -55,6 +55,9 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
       --commit=COMMIT    use the specified COMMIT"))
   (display (G_ "
       --branch=BRANCH    use the tip of the specified BRANCH"))
+  (display (G_ "
+      --disable-authentication
+                         disable channel authentication"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -80,6 +83,9 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
          (option '("branch") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'ref `(branch . ,arg) result)))
+         (option '("disable-authentication") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'authenticate-channels? #f result)))
          (option '(#\h "help") #f #f
                  (lambda args
                    (show-help)
@@ -98,6 +104,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
     (print-build-trace? . #t)
     (print-extended-build-trace? . #t)
     (multiplexed-build-output? . #t)
+    (authenticate-channels? . #t)
     (graft? . #t)
     (debug . 0)
     (verbosity . 1)))
@@ -124,12 +131,14 @@ Execute COMMAND ARGS... in an older version of Guix.\n"))
     (with-git-error-handling
      (let* ((opts         (parse-args args))
             (channels     (channel-list opts))
-            (command-line (assoc-ref opts 'exec)))
+            (command-line (assoc-ref opts 'exec))
+            (authenticate? (assoc-ref opts 'authenticate-channels?)))
        (when command-line
          (let* ((directory
                  (with-store store
                    (with-status-verbosity (assoc-ref opts 'verbosity)
                      (set-build-options-from-command-line store opts)
-                     (cached-channel-instance store channels))))
+                     (cached-channel-instance store channels
+                                              #:authenticate? authenticate?))))
                 (executable (string-append directory "/bin/guix")))
            (apply execl (cons* executable executable command-line))))))))