Merge remote-tracking branch 'origin/master' into qt-updates

3 files changed, 327 insertions, 14 deletions

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 29829f52c8..b38a55d01c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -190,7 +190,7 @@ do not treat collisions in MANIFEST as an error."
              (let* ((entries (manifest-entries manifest))
                     (count   (length entries)))
                (switch-symlinks name prof)
-               (switch-symlinks profile name)
+               (switch-symlinks profile (basename name))
                (unless (string=? profile %current-profile)
                  (register-gc-root store name))
                (format #t (N_ "~a package in profile~%"
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 7202e3cc16..433502b5de 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -28,9 +28,12 @@
   #:use-module (guix profiles)
   #:use-module (guix gexp)
   #:use-module (guix grafts)
+  #:use-module (guix memoization)
   #:use-module (guix monads)
+  #:autoload   (guix inferior) (open-inferior)
   #:use-module (guix scripts build)
   #:autoload   (guix self) (whole-package)
+  #:use-module (gnu packages)
   #:autoload   (gnu packages ssh) (guile-ssh)
   #:autoload   (gnu packages tls) (gnutls)
   #:use-module ((guix scripts package) #:select (build-and-use-profile))
@@ -45,9 +48,11 @@
   #:use-module ((gnu packages certs) #:select (le-certs))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:export (guix-pull))
 
 (module-autoload! (resolve-module '(guix scripts pull))
@@ -230,12 +235,32 @@ URL, BRANCH, and COMMIT as a property in the manifest entry."
                             (branch ,branch)
                             (commit ,commit))))))))))
 
+(define (display-profile-news profile)
+  "Display what's up in PROFILE--new packages, and all that."
+  (match (memv (generation-number profile)
+               (reverse (profile-generations profile)))
+    ((current previous _ ...)
+     (newline)
+     (let ((old (fold-packages (lambda (package result)
+                                 (alist-cons (package-name package)
+                                             (package-version package)
+                                             result))
+                               '()))
+           (new (profile-package-alist
+                 (generation-file-name profile current))))
+       (display-new/upgraded-packages old new
+                                      #:heading (G_ "New in this revision:\n"))))
+    (_ #t)))
+
 (define* (build-and-install source config-dir
                             #:key verbose? url branch commit)
   "Build the tool from SOURCE, and install it in CONFIG-DIR."
   (define update-profile
     (store-lift build-and-use-profile))
 
+  (define profile
+    (string-append config-dir "/current"))
+
   (mlet* %store-monad ((drv   (build-from-source source
                                                  #:commit commit
                                                  #:verbose? verbose?))
@@ -243,8 +268,9 @@ URL, BRANCH, and COMMIT as a property in the manifest entry."
                                                           #:url url
                                                           #:branch branch
                                                           #:commit commit)))
-    (update-profile (string-append config-dir "/current")
-                    (manifest (list entry)))))
+    (mbegin %store-monad
+      (update-profile profile (manifest (list entry)))
+      (return (display-profile-news profile)))))
 
 (define (honor-lets-encrypt-certificates! store)
   "Tell Guile-Git to use the Let's Encrypt certificates."
@@ -289,6 +315,7 @@ certificates~%"))
 (define (display-profile-content profile number)
   "Display the packages in PROFILE, generation NUMBER, in a human-readable
 way and displaying details about the channel's source code."
+  (display-generation profile number)
   (for-each (lambda (entry)
               (format #t "  ~a ~a~%"
                       (manifest-entry-name entry)
@@ -310,6 +337,90 @@ way and displaying details about the channel's source code."
              (manifest-entries
               (profile-manifest (generation-file-name profile number))))))
 
+(define (indented-string str indent)
+  "Return STR with each newline preceded by IDENT spaces."
+  (define indent-string
+    (make-list indent #\space))
+
+  (list->string
+   (string-fold-right (lambda (chr result)
+                        (if (eqv? chr #\newline)
+                            (cons chr (append indent-string result))
+                            (cons chr result)))
+                      '()
+                      str)))
+
+(define profile-package-alist
+  (mlambda (profile)
+    "Return a name/version alist representing the packages in PROFILE."
+    (fold (lambda (package lst)
+            (alist-cons (inferior-package-name package)
+                        (inferior-package-version package)
+                        lst))
+          '()
+          (let* ((inferior (open-inferior profile))
+                 (packages (inferior-packages inferior)))
+            (close-inferior inferior)
+            packages))))
+
+(define* (display-new/upgraded-packages alist1 alist2
+                                        #:key (heading ""))
+  "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."
+  (let* ((old      (fold (match-lambda*
+                           (((name . version) table)
+                            (vhash-cons name version table)))
+                         vlist-null
+                         alist1))
+         (new      (remove (match-lambda
+                             ((name . _)
+                              (vhash-assoc name old)))
+                           alist2))
+         (upgraded (filter-map (match-lambda
+                                 ((name . new-version)
+                                  (match (vhash-fold* cons '() name old)
+                                    (() #f)
+                                    ((= (cut sort <> version>?) old-versions)
+                                     (and (version>? new-version
+                                                     (first old-versions))
+                                          (string-append name "@"
+                                                         new-version))))))
+                               alist2)))
+    (unless (and (null? new) (null? upgraded))
+      (display heading))
+
+    (match (length new)
+      (0 #t)
+      (count
+       (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))))
+    (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))))))
+
+(define (display-profile-content-diff profile gen1 gen2)
+  "Display the changes in PROFILE GEN2 compared to generation GEN1."
+  (define (package-alist generation)
+    (profile-package-alist (generation-file-name profile generation)))
+
+  (display-profile-content profile gen2)
+  (display-new/upgraded-packages (package-alist gen1)
+                                 (package-alist gen2)))
+
 (define (process-query opts)
   "Process any query specified by OPTS."
   (define profile
@@ -317,29 +428,32 @@ way and displaying details about the channel's source code."
 
   (match (assoc-ref opts 'query)
     (('list-generations pattern)
-     (define (list-generation display-function number)
-       (unless (zero? number)
-         (display-generation profile number)
-         (display-function profile number)
-         (newline)))
+     (define (list-generations profile numbers)
+       (match numbers
+         ((first rest ...)
+          (display-profile-content profile first)
+          (let loop ((numbers numbers))
+            (match numbers
+              ((first second rest ...)
+               (display-profile-content-diff profile
+                                             first second)
+               (loop (cons second rest)))
+              ((_) #t)
+              (()  #t))))))
 
      (leave-on-EPIPE
       (cond ((not (file-exists? profile))         ; XXX: race condition
              (raise (condition (&profile-not-found-error
                                 (profile profile)))))
             ((string-null? pattern)
-             (for-each (lambda (generation)
-                         (list-generation display-profile-content generation))
-                       (profile-generations profile)))
+             (list-generations profile (profile-generations profile)))
             ((matching-generations pattern profile)
              =>
              (match-lambda
                (()
                 (exit 1))
                ((numbers ...)
-                (for-each (lambda (generation)
-                            (list-generation display-profile-content generation))
-                          numbers)))))))))
+                (list-generations profile numbers)))))))))
 
 
 (define (guix-pull . args)
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
new file mode 100644
index 0000000000..b157833a49
--- /dev/null
+++ b/guix/scripts/repl.scm
@@ -0,0 +1,199 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts repl)
+  #:use-module (guix ui)
+  #:use-module (guix scripts)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (gnu packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:autoload   (system repl repl) (start-repl)
+  #:autoload   (system repl server)
+                  (make-tcp-server-socket make-unix-domain-server-socket)
+  #:export (machine-repl
+            guix-repl))
+
+;;; Commentary:
+;;;
+;;; This command provides a Guile REPL
+
+(define %default-options
+  `((type . guile)))
+
+(define %options
+  (list (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix repl")))
+        (option '(#\t "type") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'type (string->symbol arg) result)))
+        (option '("listen") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'listen arg result)))))
+
+
+(define (show-help)
+  (display (G_ "Usage: guix repl [OPTIONS...]
+Start a Guile REPL in the Guix execution environment.\n"))
+  (display (G_ "
+  -t, --type=TYPE        start a REPL of the given TYPE"))
+  (newline)
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define (self-quoting? x)
+  "Return #t if X is self-quoting."
+  (letrec-syntax ((one-of (syntax-rules ()
+                            ((_) #f)
+                            ((_ pred rest ...)
+                             (or (pred x)
+                                 (one-of rest ...))))))
+    (one-of symbol? string? pair? null? vector?
+            bytevector? number? boolean?)))
+
+(define user-module
+  ;; Module where we execute user code.
+  (let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
+    (beautify-user-module! module)
+    module))
+
+(define* (machine-repl #:optional
+                       (input (current-input-port))
+                       (output (current-output-port)))
+  "Run a machine-usable REPL over ports INPUT and OUTPUT.
+
+The protocol of this REPL is meant to be machine-readable and provides proper
+support to represent multiple-value returns, exceptions, objects that lack a
+read syntax, and so on.  As such it is more convenient and robust than parsing
+Guile's REPL prompt."
+  (define (value->sexp value)
+    (if (self-quoting? value)
+        `(value ,value)
+        `(non-self-quoting ,(object-address value)
+                           ,(object->string value))))
+
+  (write `(repl-version 0 0) output)
+  (newline output)
+  (force-output output)
+
+  (let loop ()
+    (match (read input)
+      ((? eof-object?) #t)
+      (exp
+       (catch #t
+         (lambda ()
+           (let ((results (call-with-values
+                              (lambda ()
+
+                                (primitive-eval exp))
+                            list)))
+             (write `(values ,@(map value->sexp results))
+                    output)
+             (newline output)
+             (force-output output)))
+         (lambda (key . args)
+           (write `(exception ,key ,@(map value->sexp args)))
+           (newline output)
+           (force-output output)))
+       (loop)))))
+
+(define (call-with-connection spec thunk)
+  "Dynamically-bind the current input and output ports according to SPEC and
+call THUNK."
+  (if (not spec)
+      (thunk)
+
+      ;; Note: the "PROTO:" prefix in SPEC is here so that we can eventually
+      ;; parse things like "fd:123" in a non-ambiguous way.
+      (match (string-index spec #\:)
+        (#f
+         (leave (G_ "~A: invalid listen specification~%") spec))
+        (index
+         (let ((protocol (string-take spec index))
+               (address  (string-drop spec (+ index 1))))
+           (define socket
+             (match protocol
+               ("tcp"
+                (make-tcp-server-socket #:port (string->number address)))
+               ("unix"
+                (make-unix-domain-server-socket #:path address))
+               (_
+                (leave (G_ "~A: unsupported protocol family~%")
+                       protocol))))
+
+           (listen socket 10)
+           (let loop ()
+             (match (accept socket)
+               ((connection . address)
+                (if (= AF_UNIX (sockaddr:fam address))
+                    (info (G_ "accepted connection~%"))
+                    (info (G_ "accepted connection from ~a~%")
+                          (inet-ntop (sockaddr:fam address)
+                                     (sockaddr:addr address))))
+                (dynamic-wind
+                  (const #t)
+                  (lambda ()
+                    (parameterize ((current-input-port connection)
+                                   (current-output-port connection))
+                      (thunk)))
+                  (lambda ()
+                    (false-if-exception (close-port connection))
+                    (info (G_ "connection closed~%"))))))
+             (loop)))))))
+
+
+(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))
+                %default-options))
+
+  (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)
+                (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)
+;; End: