Merge branch 'master' into staging

10 files changed, 178 insertions, 108 deletions

diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm
index 8bd41c89f0..6a2f3d16de 100644
--- a/guix/build-system/dune.scm
+++ b/guix/build-system/dune.scm
@@ -87,6 +87,7 @@
                      (build-flags ''())
                      (out-of-source? #t)
                      (jbuild? #f)
+                     (package #f)
                      (tests? #t)
                      (test-flags ''())
                      (test-target "test")
@@ -125,6 +126,7 @@ provides a 'setup.ml' file as its build system."
                    #:build-flags ,build-flags
                    #:out-of-source? ,out-of-source?
                    #:jbuild? ,jbuild?
+                   #:package ,package
                    #:tests? ,tests?
                    #:test-target ,test-target
                    #:install-target ,install-target
diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm
index 00b0c7c406..7e2ec1e3e1 100644
--- a/guix/build/dune-build-system.scm
+++ b/guix/build/dune-build-system.scm
@@ -31,27 +31,30 @@
 ;; Code:
 
 (define* (build #:key (build-flags '()) (jbuild? #f)
-                (use-make? #f) #:allow-other-keys)
+                (use-make? #f) (package #f) #:allow-other-keys)
   "Build the given package."
   (let ((program (if jbuild? "jbuilder" "dune")))
-    (apply invoke program "build" "@install" build-flags))
+    (apply invoke program "build" "@install"
+           (append (if package (list "-p" package) '()) build-flags)))
   #t)
 
 (define* (check #:key (test-flags '()) (test-target "test") tests?
-                  (jbuild? #f) #:allow-other-keys)
+                  (jbuild? #f) (package #f) #:allow-other-keys)
   "Test the given package."
   (when tests?
     (let ((program (if jbuild? "jbuilder" "dune")))
-      (apply invoke program "runtest" test-target test-flags)))
+      (apply invoke program "runtest" test-target
+             (append (if package (list "-p" package) '()) test-flags))))
   #t)
 
 (define* (install #:key outputs (install-target "install") (jbuild? #f)
-                  #:allow-other-keys)
+                  (package #f) #:allow-other-keys)
   "Install the given package."
   (let ((out (assoc-ref outputs "out"))
         (program (if jbuild? "jbuilder" "dune")))
-    (invoke program install-target "--prefix" out "--libdir"
-            (string-append out "/lib/ocaml/site-lib")))
+    (apply invoke program install-target "--prefix" out "--libdir"
+           (string-append out "/lib/ocaml/site-lib")
+           (if package (list package) '())))
   #t)
 
 (define %standard-phases
diff --git a/guix/packages.scm b/guix/packages.scm
index d20a2562c3..c2981dda8b 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -48,6 +48,7 @@
                search-path-specification)         ;for convenience
   #:export (origin
             origin?
+            this-origin
             origin-uri
             origin-method
             origin-sha256
@@ -63,6 +64,7 @@
 
             package
             package?
+            this-package
             package-name
             package-upstream-name
             package-version
@@ -82,7 +84,6 @@
             package-license
             package-home-page
             package-supported-systems
-            package-maintainers
             package-properties
             package-location
             hidden-package
@@ -156,6 +157,7 @@
 (define-record-type* <origin>
   origin make-origin
   origin?
+  this-origin
   (uri       origin-uri)                          ; string
   (method    origin-method)                       ; procedure
   (sha256    origin-sha256)                       ; bytevector
@@ -247,6 +249,7 @@ name of its URI."
 (define-record-type* <package>
   package make-package
   package?
+  this-package
   (name   package-name)                   ; string
   (version package-version)               ; string
   (source package-source)                 ; <origin> instance
@@ -260,9 +263,6 @@ name of its URI."
                      (default '()) (thunked))
   (native-inputs package-native-inputs    ; native input packages/derivations
                  (default '()) (thunked))
-  (self-native-input? package-self-native-input?  ; whether to use itself as
-                                                  ; a native input when cross-
-                      (default #f))               ; compiling
 
   (outputs package-outputs                ; list of strings
            (default '("out")))
@@ -285,7 +285,6 @@ name of its URI."
   (home-page package-home-page)
   (supported-systems package-supported-systems    ; list of strings
                      (default %supported-systems))
-  (maintainers package-maintainers (default '()))
 
   (properties package-properties (default '()))   ; alist for anything else
 
@@ -1025,9 +1024,10 @@ and return it."
             (match (if graft?
                        (or (package-replacement package) package)
                        package)
-              (($ <package> name version source build-system
-                            args inputs propagated-inputs native-inputs
-                            self-native-input? outputs)
+              ((and self
+                    ($ <package> name version source build-system
+                                 args inputs propagated-inputs native-inputs
+                                 outputs))
                ;; Even though we prefer to use "@" to separate the package
                ;; name from the package version in various user-facing parts
                ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
@@ -1036,15 +1036,11 @@ and return it."
                              #:system system
                              #:target target
                              #:source source
-                             #:inputs (append (inputs)
-                                              (propagated-inputs))
+                             #:inputs (append (inputs self)
+                                              (propagated-inputs self))
                              #:outputs outputs
-                             #:native-inputs `(,@(if (and target
-                                                          self-native-input?)
-                                                     `(("self" ,package))
-                                                     '())
-                                               ,@(native-inputs))
-                             #:arguments (args))
+                             #:native-inputs (native-inputs self)
+                             #:arguments (args self))
                    (raise (if target
                               (condition
                                (&package-cross-build-system-error
diff --git a/guix/records.scm b/guix/records.scm
index 0649c90ea3..99507dc384 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -25,6 +25,8 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
   #:export (define-record-type*
+            this-record
+
             alist->record
             object->fields
             recutils->alist
@@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE."
            (()
             #t)))))))
 
+(define-syntax-parameter this-record
+  (lambda (s)
+    "Return the record being defined.  This macro may only be used in the
+context of the definition of a thunked field."
+    (syntax-case s ()
+      (id
+       (identifier? #'id)
+       (syntax-violation 'this-record
+                         "cannot be used outside of a record instantiation"
+                         #'id)))))
+
 (define-syntax make-syntactic-constructor
   (syntax-rules ()
     "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
@@ -105,6 +118,7 @@ of TYPE matches the expansion-time ABI."
     ((_ type name ctor (expected ...)
         #:abi-cookie abi-cookie
         #:thunked thunked
+        #:this-identifier this-identifier
         #:delayed delayed
         #:innate innate
         #:defaults defaults)
@@ -148,7 +162,14 @@ of TYPE matches the expansion-time ABI."
 
          (define (wrap-field-value f value)
            (cond ((thunked-field? f)
-                  #`(lambda () #,value))
+                  #`(lambda (x)
+                      (syntax-parameterize ((#,this-identifier
+                                             (lambda (s)
+                                               (syntax-case s ()
+                                                 (id
+                                                  (identifier? #'id)
+                                                  #'x)))))
+                        #,value)))
                  ((delayed-field? f)
                   #`(delay #,value))
                  (else value)))
@@ -234,6 +255,7 @@ may look like this:
 
   (define-record-type* <thing> thing make-thing
     thing?
+    this-thing
     (name  thing-name (default \"chbouib\"))
     (port  thing-port
            (default (current-output-port)) (thunked))
@@ -253,7 +275,8 @@ default value specified in the 'define-record-type*' form is used:
 
 The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
 actually compute the field's value in the current dynamic extent, which is
-useful when referring to fluids in a field's value.
+useful when referring to fluids in a field's value.  Furthermore, that thunk
+can access the record it belongs to via the 'this-thing' identifier.
 
 A field can also be marked as \"delayed\" instead of \"thunked\", in which
 case its value is effectively wrapped in a (delay …) form.
@@ -308,7 +331,7 @@ inherited."
          (with-syntax ((real-get (wrapped-field-accessor-name field)))
            #'(define-inlinable (get x)
                ;; The real value of that field is a thunk, so call it.
-               ((real-get x)))))))
+               ((real-get x) x))))))
 
     (define (delayed-field-accessor-definition field)
       ;; Return the real accessor for FIELD, which is assumed to be a
@@ -332,7 +355,9 @@ inherited."
 
     (syntax-case s ()
       ((_ type syntactic-ctor ctor pred
+          this-identifier
           (field get properties ...) ...)
+       (identifier? #'this-identifier)
        (let* ((field-spec #'((field get properties ...) ...))
               (thunked    (filter-map thunked-field? field-spec))
               (delayed    (filter-map delayed-field? field-spec))
@@ -361,15 +386,36 @@ inherited."
                  field-spec* ...)
                (define #,(current-abi-identifier #'type)
                  #,cookie)
+
+               #,@(if (free-identifier=? #'this-identifier #'this-record)
+                      #'()
+                      #'((define-syntax-parameter this-identifier
+                           (lambda (s)
+                             "Return the record being defined.  This macro may
+only be used in the context of the definition of a thunked field."
+                             (syntax-case s ()
+                               (id
+                                (identifier? #'id)
+                                (syntax-violation 'this-identifier
+                                                  "cannot be used outside \
+of a record instantiation"
+                                                  #'id)))))))
                thunked-field-accessor ...
                delayed-field-accessor ...
                (make-syntactic-constructor type syntactic-ctor ctor
                                            (field ...)
                                            #:abi-cookie #,cookie
                                            #:thunked #,thunked
+                                           #:this-identifier #'this-identifier
                                            #:delayed #,delayed
                                            #:innate #,innate
-                                           #:defaults #,defaults))))))))
+                                           #:defaults #,defaults)))))
+      ((_ type syntactic-ctor ctor pred
+          (field get properties ...) ...)
+       ;; When no 'this' identifier was specified, use 'this-record'.
+       #'(define-record-type* type syntactic-ctor ctor pred
+           this-record
+           (field get properties ...) ...)))))
 
 (define* (alist->record alist make keys
                         #:optional (multiple-value-keys '()))
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 75d801a466..e4b11d295d 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -173,7 +173,8 @@ Show what and how will/would be built."
                  "Your Guix installation is ~a days old.\n"
                  (seconds->days age))
              (seconds->days age)))
-  (when (or (not age) (>= age old))
+  (when (and (or (not age) (>= age old))
+             (not (getenv "GUIX_UNINSTALLED")))
     (warning (G_ "Consider running 'guix pull' followed by
 '~a' to get up-to-date packages and security updates.\n")
              suggested-command)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 63f6129279..c27edc7982 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -33,6 +33,7 @@
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (gnu build linux-container)
+  #:use-module (gnu build accounts)
   #:use-module (gnu system linux-container)
   #:use-module (gnu system file-systems)
   #:use-module (gnu packages)
@@ -458,10 +459,20 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
     (return
      (let* ((cwd      (getcwd))
             (home     (getenv "HOME"))
-            (passwd   (mock-passwd (getpwuid (getuid))
-                                   user
-                                   bash))
-            (home-dir (passwd:dir passwd))
+            (passwd   (let ((pwd (getpwuid (getuid))))
+                        (password-entry
+                         (name (or user (passwd:name pwd)))
+                         (real-name (if user
+                                        ""
+                                        (passwd:gecos pwd)))
+                         (uid 0) (gid 0) (shell bash)
+                         (directory (if user
+                                        (string-append "/home/" user)
+                                        (passwd:dir pwd))))))
+            (groups   (list (group-entry (name "users") (gid 0))
+                            (group-entry (gid 65534) ;the overflow GID
+                                         (name "overflow"))))
+            (home-dir (password-entry-directory passwd))
             ;; Bind-mount all requisite store items, user-specified mappings,
             ;; /bin/sh, the current working directory, and possibly networking
             ;; configuration files within the container.
@@ -519,17 +530,8 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
             ;; to read it, such as 'git clone' over SSH, a valid use-case when
             ;; sharing the host's network namespace.
             (mkdir-p "/etc")
-            (call-with-output-file "/etc/passwd"
-              (lambda (port)
-                (display (string-join (list (passwd:name passwd)
-                                            "x" ; but there is no shadow
-                                            "0" "0" ; user is now root
-                                            (passwd:gecos passwd)
-                                            (passwd:dir passwd)
-                                            bash)
-                                      ":")
-                         port)
-                (newline port)))
+            (write-passwd (list passwd))
+            (write-group groups)
 
             ;; For convenience, start in the user's current working
             ;; directory rather than the root directory.
@@ -543,32 +545,6 @@ will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
                            (delq 'net %namespaces) ; share host network
                            %namespaces)))))))
 
-(define (mock-passwd passwd user-override shell)
-  "Generate mock information for '/etc/passwd'.  If USER-OVERRIDE is not '#f',
-it is expected to be a string representing the mock username; it will produce
-a user of that name, with a home directory of '/home/USER-OVERRIDE', and no
-GECOS field.  If USER-OVERRIDE is '#f', data will be inherited from PASSWD.
-In either case, the shadow password and UID/GID are cleared, since the user
-runs as root within the container.  SHELL will always be used in place of the
-shell in PASSWD.
-
-The resulting vector is suitable for use with Guile's POSIX user procedures.
-
-See passwd(5) for more information each of the fields."
-  (if user-override
-      (vector
-       user-override
-        "x" "0" "0"  ;; no shadow, user is now root
-        ""           ;; no personal information
-        (user-override-home user-override)
-        shell)
-      (vector
-       (passwd:name passwd)
-        "x" "0" "0"  ;; no shadow, user is now root
-        (passwd:gecos passwd)
-        (passwd:dir passwd)
-        shell)))
-
 (define (user-override-home user)
   "Return home directory for override user USER."
   (string-append "/home/" user))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 730b6a0bf2..2aaf1cc44a 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -181,6 +181,7 @@ Download and deploy the latest version of Guix.\n"))
            (new (profile-package-alist
                  (generation-file-name profile current))))
        (display-new/upgraded-packages old new
+                                      #:concise? #t
                                       #:heading (G_ "New in this revision:\n"))))
     (_ #t)))
 
@@ -377,11 +378,33 @@ of packages upgraded in ALIST2."
                                alist2)))
     (values new upgraded)))
 
+(define* (ellipsis #:optional (port (current-output-port)))
+  "Return HORIZONTAL ELLIPSIS three dots if PORT's encoding cannot represent
+it."
+  (match (port-encoding port)
+    ("UTF-8" "…")
+    (_       "...")))
+
 (define* (display-new/upgraded-packages alist1 alist2
-                                        #:key (heading ""))
+                                        #:key (heading "") concise?)
   "Given the two package name/version alists ALIST1 and ALIST2, display the
 list of new and upgraded packages going from ALIST1 to ALIST2.  When ALIST1
-and ALIST2 differ, display HEADING upfront."
+and ALIST2 differ, display HEADING upfront.  When CONCISE? is true, do not
+display long package lists that would fill the user's screen."
+  (define (pretty str column)
+    (indented-string (fill-paragraph str (- (%text-width) 4)
+                                     column)
+                     4))
+
+  (define list->enumeration
+    (if concise?
+        (lambda* (lst #:optional (max 12))
+          (if (> (length lst) max)
+              (string-append (string-join (take lst max) ", ")
+                             ", " (ellipsis))
+              (string-join lst ", ")))
+        (cut string-join <> ", ")))
+
   (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
     (unless (and (null? new) (null? upgraded))
       (display heading))
@@ -392,21 +415,16 @@ and ALIST2 differ, display HEADING upfront."
        (format #t (N_ "  ~h new package: ~a~%"
                       "  ~h new packages: ~a~%" count)
                count
-               (indented-string
-                (fill-paragraph (string-join (sort (map first new) string<?)
-                                             ", ")
-                                (- (%text-width) 4) 30)
-                4))))
+               (pretty (list->enumeration (sort (map first new) string<?))
+                       30))))
     (match (length upgraded)
       (0 #t)
       (count
        (format #t (N_ "  ~h package upgraded: ~a~%"
                       "  ~h packages upgraded: ~a~%" count)
                count
-               (indented-string
-                (fill-paragraph (string-join (sort upgraded string<?) ", ")
-                                (- (%text-width) 4) 35)
-                4))))))
+               (pretty (list->enumeration (sort upgraded string<?))
+                       35))))))
 
 (define (display-profile-content-diff profile gen1 gen2)
   "Display the changes in PROFILE GEN2 compared to generation GEN1."
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 5b0f345cde..dd7026a6a4 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -297,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 values: 'interactive' (default), 'always', and 'never'.  When WARN? is true,
 warn about packages that have no matching updater."
   (if (lookup-updater package updaters)
-      (let-values (((version tarball changes)
+      (let-values (((version tarball source)
                     (package-update store package updaters
                                     #:key-download key-download))
                    ((loc)
@@ -330,10 +330,10 @@ warn about packages that have no matching updater."
                               (G_ "~a: consider removing this propagated input: ~a~%")))
                            (package-name package)
                            (upstream-input-change-name change)))
-                 (changes))
+                 (upstream-source-input-changes source))
                 (let ((hash (call-with-input-file tarball
                               port-sha256)))
-                  (update-package-source package version hash)))
+                  (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
 downloaded and authenticated; not updating~%")
                        (package-name package) version))))
diff --git a/guix/ui.scm b/guix/ui.scm
index 2fc001d2eb..0070301c47 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1329,8 +1329,14 @@ score, the more relevant OBJ is to REGEXPS."
   ;; Metrics used to compute the "relevance score" of a package against a set
   ;; of regexps.
   `((,package-name . 4)
-    (,package-synopsis-string . 3)
-    (,package-description-string . 2)
+
+    ;; Match regexps on the raw Texinfo since formatting it is quite expensive
+    ;; and doesn't have much of an effect on search results.
+    (,(lambda (package)
+        (and=> (package-synopsis package) P_)) . 3)
+    (,(lambda (package)
+        (and=> (package-description package) P_)) . 2)
+
     (,(lambda (type)
         (match (and=> (package-location type) location-file)
           ((? string? file) (basename file ".scm"))
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 55683dd9b7..1326b3db95 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -39,6 +39,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:export (upstream-source
@@ -344,10 +345,10 @@ values: the item from LST1 and the item from LST2 that match PRED."
 
 (define* (package-update/url-fetch store package source
                                    #:key key-download)
-  "Return the version, tarball, and input changes needed to update PACKAGE to
+  "Return the version, tarball, and SOURCE, to update PACKAGE to
 SOURCE, an <upstream-source>."
   (match source
-    (($ <upstream-source> _ version urls signature-urls changes)
+    (($ <upstream-source> _ version urls signature-urls)
      (let*-values (((archive-type)
                     (match (and=> (package-source package) origin-uri)
                       ((? string? uri)
@@ -371,7 +372,7 @@ SOURCE, an <upstream-source>."
                            (or signature-urls (circular-list #f)))))
        (let ((tarball (download-tarball store url signature-url
                                         #:key-download key-download)))
-         (values version tarball changes))))))
+         (values version tarball source))))))
 
 (define %method-updates
   ;; Mapping of origin methods to source update procedures.
@@ -404,36 +405,57 @@ this method: ~s")
     (#f
      (values #f #f #f))))
 
-(define (update-package-source package version hash)
-  "Modify the source file that defines PACKAGE to refer to VERSION,
-whose tarball has SHA256 HASH (a bytevector).  Return the new version string
-if an update was made, and #f otherwise."
-  (define (update-expression expr old-version version old-hash hash)
-    ;; Update package expression EXPR, replacing occurrences OLD-VERSION by
-    ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation
-    ;; thereof).
-    (let ((old-hash (bytevector->nix-base32-string old-hash))
-          (hash     (bytevector->nix-base32-string hash)))
-      (string-replace-substring
-       (string-replace-substring expr old-hash hash)
-       old-version version)))
+(define* (update-package-source package source hash)
+  "Modify the source file that defines PACKAGE to refer to SOURCE, an
+<upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
+new version string if an update was made, and #f otherwise."
+  (define (update-expression expr replacements)
+    ;; Apply REPLACEMENTS to package expression EXPR, a string.  REPLACEMENTS
+    ;; must be a list of replacement pairs, either bytevectors or strings.
+    (fold (lambda (replacement str)
+            (match replacement
+              (((? bytevector? old-bv) . (? bytevector? new-bv))
+               (string-replace-substring
+                str
+                (bytevector->nix-base32-string old-bv)
+                (bytevector->nix-base32-string new-bv)))
+              ((old . new)
+               (string-replace-substring str old new))))
+          expr
+          replacements))
 
   (let ((name        (package-name package))
+        (version     (upstream-source-version source))
         (version-loc (package-field-location package 'version)))
     (if version-loc
         (let* ((loc         (package-location package))
                (old-version (package-version package))
                (old-hash    (origin-sha256 (package-source package)))
+               (old-url     (match (origin-uri (package-source package))
+                              ((? string? url) url)
+                              (_ #f)))
+               (new-url     (match (upstream-source-urls source)
+                              ((first _ ...) first)))
                (file        (and=> (location-file loc)
                                    (cut search-path %load-path <>))))
           (if file
-              (and (edit-expression
-                    ;; Be sure to use absolute filename.
-                    (assq-set! (location->source-properties loc)
-                               'filename file)
-                    (cut update-expression <>
-                         old-version version old-hash hash))
-                   version)
+              ;; Be sure to use absolute filename.  Replace the URL directory
+              ;; when OLD-URL is available; this is useful notably for
+              ;; mirror://cpan/ URLs where the directory may change as a
+              ;; function of the person who uploads the package.  Note that
+              ;; package definitions usually concatenate fragments of the URL,
+              ;; which is why we only attempt to replace a subset of the URL.
+              (let ((properties (assq-set! (location->source-properties loc)
+                                           'filename file))
+                    (replacements `((,old-version . ,version)
+                                    (,old-hash . ,hash)
+                                    ,@(if (and old-url new-url)
+                                          `((,(dirname old-url) .
+                                             ,(dirname new-url)))
+                                          '()))))
+                (and (edit-expression properties
+                                      (cut update-expression <> replacements))
+                     version))
               (begin
                 (warning (G_ "~a: could not locate source file")
                          (location-file loc))