Merge branch 'master' into staging

5 files changed, 50 insertions, 24 deletions

diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm
index af90a32f59..21d84a179a 100644
--- a/guix/build-system/minify.scm
+++ b/guix/build-system/minify.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,7 +39,6 @@
 (define %minify-build-system-modules
   ;; Build-side modules imported by default.
   `((guix build minify-build-system)
-    (ice-9 popen)
     ,@%gnu-build-system-modules))
 
 (define (default-uglify-js)
diff --git a/guix/download.scm b/guix/download.scm
index 55da2c1d37..5044534bf5 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -66,7 +66,6 @@
        "ftp://gcc.gnu.org/pub/gcc/"
        ,@(map (cut string-append <> "/gcc") gnu-mirrors))
       (gnupg
-       "http://gd.tuwien.ac.at/privacy/gnupg/"
        "http://artfiles.org/gnupg.org"
        "http://www.crysys.hu/"
        "https://gnupg.org/ftp/gcrypt/"
@@ -143,7 +142,6 @@
        "http://apache.belnet.be/"
        "http://mirrors.ircam.fr/pub/apache/"
        "http://apache-mirror.rbc.ru/pub/apache/"
-       "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/"
 
        ;; As a last resort, try the archive.
        "http://archive.apache.org/dist/")
@@ -163,7 +161,6 @@
        "ftp://ftp.piotrkosoft.net/pub/mirrors/ftp.x.org/"
        "ftp://ftp.portal-to-web.de/pub/mirrors/x.org/"
        "ftp://ftp.solnet.ch/mirror/x.org/"
-       "ftp://gd.tuwien.ac.at/X11/"
        "ftp://mi.mirror.garr.it/mirrors/x.org/"
        "ftp://mirror.cict.fr/x.org/"
        "ftp://mirror.switch.ch/mirror/X11/"
diff --git a/guix/git.scm b/guix/git.scm
index fc41e2ace3..d31c35f64f 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +28,8 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:export (%repository-cache-directory
             latest-repository-commit))
 
@@ -94,17 +97,32 @@ create the store directory name."
 
 (define (switch-to-ref repository ref)
   "Switch to REPOSITORY's branch, commit or tag specified by REF."
-  (let* ((oid (match ref
-                (('branch . branch)
-                 (reference-target
-                  (branch-lookup repository branch BRANCH-REMOTE)))
-                (('commit . commit)
-                 (string->oid commit))
-                (('tag    . tag)
-                 (reference-name->oid repository
-                                      (string-append "refs/tags/" tag)))))
-         (obj (object-lookup repository oid)))
-    (reset repository obj RESET_HARD)))
+  (define obj
+    (match ref
+      (('branch . branch)
+       (let ((oid (reference-target
+                   (branch-lookup repository branch BRANCH-REMOTE))))
+         (object-lookup repository oid)))
+      (('commit . commit)
+       (let ((len (string-length commit)))
+         ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
+         ;; can't be sure it's available.  Furthermore, 'string->oid' used to
+         ;; read out-of-bounds when passed a string shorter than 40 chars,
+         ;; which is why we delay calls to it below.
+         (if (< len 40)
+             (if (module-defined? (resolve-interface '(git object))
+                                  'object-lookup-prefix)
+                 (object-lookup-prefix repository (string->oid commit) len)
+                 (raise (condition
+                         (&message
+                          (message "long Git object ID is required")))))
+             (object-lookup repository (string->oid commit)))))
+      (('tag    . tag)
+       (let ((oid (reference-name->oid repository
+                                       (string-append "refs/tags/" tag))))
+         (object-lookup repository oid)))))
+
+  (reset repository obj RESET_HARD))
 
 (define* (latest-repository-commit store url
                                    #:key
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 45a419217c..5d3d04ee7c 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -67,15 +67,15 @@ NAMES (strings)."
         (string-append package-name-prefix (string-downcase name)))))
 
 (define* (elpa-url #:optional (repo 'gnu))
-  "Retrun the URL of REPO."
+  "Retrieve the URL of REPO."
   (let ((elpa-archives
-         '((gnu . "http://elpa.gnu.org/packages")
-           (melpa-stable . "http://stable.melpa.org/packages")
-           (melpa . "http://melpa.org/packages"))))
+         '((gnu . "https://elpa.gnu.org/packages")
+           (melpa-stable . "https://stable.melpa.org/packages")
+           (melpa . "https://melpa.org/packages"))))
     (assq-ref elpa-archives repo)))
 
 (define* (elpa-fetch-archive #:optional (repo 'gnu))
-  "Retrive the archive with the list of packages available from REPO."
+  "Retrieve the archive with the list of packages available from REPO."
   (let ((url (and=> (elpa-url repo)
                     (cut string-append <> "/archive-contents"))))
     (if url
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index acfccce96d..f0c4a2ba1b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -733,7 +733,8 @@ and TARGET arguments."
                       (#$installer #$bootloader #$device #$target))))))
 
 (define* (perform-action action os
-                         #:key install-bootloader?
+                         #:key skip-safety-checks?
+                         install-bootloader?
                          dry-run? derivations-only?
                          use-substitutes? bootloader-target target
                          image-size file-system-type full-boot?
@@ -750,7 +751,10 @@ When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 building anything.
 
 When GC-ROOT is a path, also make that path an indirect root of the build
-output when building a system derivation, such as a disk image."
+output when building a system derivation, such as a disk image.
+
+When SKIP-SAFETY-CHECKS? is true, skip the file system and initrd module
+static checks."
   (define println
     (cut format #t "~a~%" <>))
 
@@ -760,7 +764,8 @@ output when building a system derivation, such as a disk image."
   ;; Check whether the declared file systems exist.  This is better than
   ;; instantiating a broken configuration.  Assume that we can only check if
   ;; running as root.
-  (when (memq action '(init reconfigure))
+  (when (and (not skip-safety-checks?)
+             (memq action '(init reconfigure)))
     (check-mapped-devices os)
     (when (zero? (getuid))
       (check-file-system-availability (operating-system-file-systems os))
@@ -933,6 +938,8 @@ Some ACTIONS support additional ARGS.\n"))
       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
   (display (G_ "
       --full-boot        for 'vm', make a full boot sequence"))
+  (display (G_ "
+      --skip-checks      skip file system and initrd module safety checks"))
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -974,6 +981,9 @@ Some ACTIONS support additional ARGS.\n"))
          (option '("full-boot") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'full-boot? #t result)))
+         (option '("skip-checks") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'skip-safety-checks? #t result)))
 
          (option '("share") #t #f
                  (lambda (opt name arg result)
@@ -1067,6 +1077,8 @@ resulting from command-line parsing."
                              #:derivations-only? (assoc-ref opts
                                                             'derivations-only?)
                              #:use-substitutes? (assoc-ref opts 'substitutes?)
+                             #:skip-safety-checks?
+                             (assoc-ref opts 'skip-safety-checks?)
                              #:file-system-type (assoc-ref opts 'file-system-type)
                              #:image-size (assoc-ref opts 'image-size)
                              #:full-boot? (assoc-ref opts 'full-boot?)