Merge branch 'master' into core-updates

5 files changed, 63 insertions, 29 deletions

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 6a67985c8b..329de41143 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -94,7 +94,7 @@ Perform the deployment specified by FILE.\n"))
                         (machine-display-name machine))
                   (parameterize ((%graft? (assq-ref opts 'graft?)))
                     (guard (c ((message-condition? c)
-                               (report-error (G_ "failed to deploy ~a: '~a'~%")
+                               (report-error (G_ "failed to deploy ~a: ~a~%")
                                              (machine-display-name machine)
                                              (condition-message c)))
                               ((deploy-error? c)
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 0b326e1049..c6cc93fad8 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -113,7 +114,8 @@ Run IMPORTER with ARGS.\n"))
                         (pretty-print expr (newline-rewriting-port
                                             (current-output-port))))))
            (match (apply (resolve-importer importer) args)
-             ((and expr ('package _ ...))
+             ((and expr (or ('package _ ...)
+                            ('let _ ...)))
               (print expr))
              ((? list? expressions)
               (for-each (lambda (expr)
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 794fb710cd..b6592f78a9 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +22,7 @@
   #:use-module (guix utils)
   #:use-module (guix scripts)
   #:use-module (guix import cran)
+  #:use-module (guix import utils)
   #:use-module (guix scripts import)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -96,11 +97,7 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
       ((package-name)
        (if (assoc-ref opts 'recursive)
            ;; Recursive import
-           (map (match-lambda
-                  ((and ('package ('name name) . rest) pkg)
-                   `(define-public ,(string->symbol name)
-                      ,pkg))
-                  (_ #f))
+           (map package->definition
                 (reverse
                  (stream->list
                   (cran-recursive-import package-name
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index ee1c826d2e..1668d02992 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -46,9 +46,9 @@
    (lambda (lint-warning)
      (let ((package (lint-warning-package lint-warning))
            (loc     (lint-warning-location lint-warning)))
-       (warning loc (G_ "~a@~a: ~a~%")
-                (package-name package) (package-version package)
-                (lint-warning-message lint-warning))))
+       (info loc (G_ "~a@~a: ~a~%")
+             (package-name package) (package-version package)
+             (lint-warning-message lint-warning))))
    warnings))
 
 (define (run-checkers package checkers)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index f0cf593814..de5b3fc0ff 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -490,7 +490,8 @@ the image."
         #~(begin
             (use-modules (guix docker) (guix build store-copy)
                          (guix profiles) (guix search-paths)
-                         (srfi srfi-19) (ice-9 match))
+                         (srfi srfi-1) (srfi srfi-19)
+                         (ice-9 match))
 
             (define environment
               (map (match-lambda
@@ -499,6 +500,23 @@ the image."
                             value)))
                    (profile-search-paths #$profile)))
 
+            (define symlink->directives
+              ;; Return "populate directives" to make the given symlink and its
+              ;; parent directories.
+              (match-lambda
+                ((source '-> target)
+                 (let ((target (string-append #$profile "/" target))
+                       (parent (dirname source)))
+                   `((directory ,parent)
+                     (,source -> ,target))))))
+
+            (define directives
+              ;; Create a /tmp directory, as some programs expect it, and
+              ;; create SYMLINKS.
+              `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
+                ,@(append-map symlink->directives '#$symlinks)))
+
+
             (setenv "PATH" (string-append #$archiver "/bin"))
 
             (build-docker-image #$output
@@ -513,7 +531,7 @@ the image."
                                 #$(and entry-point
                                        #~(list (string-append #$profile "/"
                                                               #$entry-point)))
-                                #:symlinks '#$symlinks
+                                #:extra-files directives
                                 #:compressor '#$(compressor-command compressor)
                                 #:creation-time (make-time time-utc 0 1))))))
 
@@ -611,8 +629,13 @@ please email '~a'~%")
 ;;;
 
 (define* (wrapped-package package
-                          #:optional (compiler (c-compiler))
+                          #:optional
+                          (output* "out")
+                          (compiler (c-compiler))
                           #:key proot?)
+  "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
+relocatable.  When PROOT? is true, include PRoot in the result and use it as a
+last resort for relocation."
   (define runner
     (local-file (search-auxiliary-file "run-in-namespace.c")))
 
@@ -629,6 +652,14 @@ please email '~a'~%")
                        (ice-9 ftw)
                        (ice-9 match))
 
+          (define input
+            ;; The OUTPUT* output of PACKAGE.
+            (ungexp package output*))
+
+          (define target
+            ;; The output we are producing.
+            (ungexp output output*))
+
           (define (strip-store-prefix file)
             ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
             ;; "/bin/foo".
@@ -648,7 +679,7 @@ please email '~a'~%")
               (("@STORE_DIRECTORY@") (%store-directory)))
 
             (let* ((base   (strip-store-prefix program))
-                   (result (string-append #$output "/" base))
+                   (result (string-append target "/" base))
                    (proot  #$(and proot?
                                   #~(string-drop
                                      #$(file-append (proot) "/bin/proot")
@@ -667,18 +698,18 @@ please email '~a'~%")
 
           ;; Link the top-level files of PACKAGE so that search paths are
           ;; properly defined in PROFILE/etc/profile.
-          (mkdir #$output)
+          (mkdir target)
           (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))
+                        (let ((file* (string-append input "/" file)))
+                          (symlink (relative-file-name target file*)
+                                   (string-append target "/" file)))))
+                    (scandir input))
 
           (for-each build-wrapper
-                    (append (find-files #$(file-append package "/bin"))
-                            (find-files #$(file-append package "/sbin"))
-                            (find-files #$(file-append package "/libexec")))))))
+                    (append (find-files (string-append input "/bin"))
+                            (find-files (string-append input "/sbin"))
+                            (find-files (string-append input "/libexec")))))))
 
   (computed-file (string-append
                   (cond ((package? package)
@@ -691,14 +722,18 @@ please email '~a'~%")
                   "R")
                  build))
 
+(define (wrapped-manifest-entry entry . args)
+  (manifest-entry
+    (inherit entry)
+    (item (apply wrapped-package
+                 (manifest-entry-item entry)
+                 (manifest-entry-output entry)
+                 args))))
+
 (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))))
+   (map proc (manifest-entries manifest))))
 
 
 ;;;
@@ -960,7 +995,7 @@ Create a bundle of PACKAGE.\n"))
                                 ;; 'glibc-bootstrap' lacks 'libc.a'.
                                 (if relocatable?
                                     (map-manifest-entries
-                                     (cut wrapped-package <> #:proot? proot?)
+                                     (cut wrapped-manifest-entry <> #:proot? proot?)
                                      manifest)
                                     manifest)))
                  (pack-format (assoc-ref opts 'format))