Merge branch 'master' into core-updates

4 files changed, 92 insertions, 31 deletions

diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index d817d7f7ca..98be4ee89f 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,11 +19,13 @@
 
 (define-module (guix scripts describe)
   #:use-module ((guix ui) #:hide (display-profile-content))
+  #:use-module (guix channels)
   #:use-module (guix scripts)
   #:use-module (guix describe)
   #:use-module (guix profiles)
   #:use-module ((guix scripts pull) #:select (display-profile-content))
   #:use-module (git)
+  #:use-module (json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
@@ -38,7 +41,7 @@
   ;; Specifications of the command-line options.
   (list (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
-                  (unless (member arg '("human" "channels"))
+                  (unless (member arg '("human" "channels" "json" "recutils"))
                     (leave (G_ "~a: unsupported output format~%") arg))
                   (alist-cons 'format (string->symbol arg) result)))
         (option '(#\p "profile") #t #f
@@ -84,6 +87,22 @@ Display information about the channels currently in use.\n"))
         (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
                 string))))))
 
+(define (channel->sexp channel)
+  `(channel
+    (name ,(channel-name channel))
+    (url ,(channel-url channel))
+    (commit ,(channel-commit channel))))
+
+(define (channel->json channel)
+  (scm->json-string `((name . ,(channel-name channel))
+                      (url . ,(channel-url channel))
+                      (commit . ,(channel-commit channel)))))
+
+(define (channel->recutils channel port)
+  (format port "name: ~a~%" (channel-name channel))
+  (format port "url: ~a~%" (channel-url channel))
+  (format port "commit: ~a~%" (channel-commit channel)))
+
 (define* (display-checkout-info fmt #:optional directory)
   "Display information about the current checkout according to FMT, a symbol
 denoting the requested format.  Exit if the current directory does not lie
@@ -104,10 +123,19 @@ within a Git checkout."
        (format #t (G_ "  branch: ~a~%") (reference-shorthand head))
        (format #t (G_ "  commit: ~a~%") commit))
       ('channels
-       (pretty-print `(list (channel
-                             (name 'guix)
-                             (url ,(dirname directory))
-                             (commit ,commit))))))
+       (pretty-print `(list ,(channel->sexp (channel (name 'guix)
+                                                     (url (dirname directory))
+                                                     (commit commit))))))
+      ('json
+       (display (channel->json (channel (name 'guix)
+                                        (url (dirname directory))
+                                        (commit commit))))
+       (newline))
+      ('recutils
+       (channel->recutils (channel (name 'guix)
+                                   (url (dirname directory))
+                                   (commit commit))
+                          (current-output-port))))
     (display-package-search-path fmt)))
 
 (define (display-profile-info profile fmt)
@@ -116,34 +144,46 @@ in the format specified by FMT."
   (define number
     (generation-number profile))
 
+  (define channels
+    (map (lambda (entry)
+           (match (assq 'source (manifest-entry-properties entry))
+             (('source ('repository ('version 0)
+                                    ('url url)
+                                    ('branch branch)
+                                    ('commit commit)
+                                    _ ...))
+              (channel (name (string->symbol (manifest-entry-name entry)))
+                       (url url)
+                       (commit commit)))
+
+             ;; Pre-0.15.0 Guix does not provide that information,
+             ;; so there's not much we can do in that case.
+             (_ (channel (name 'guix)
+                         (url "?")
+                         (commit "?")))))
+
+         ;; Show most recently installed packages last.
+         (reverse
+          (manifest-entries
+           (profile-manifest
+            (if (zero? number)
+                profile
+                (generation-file-name profile number)))))))
+
   (match fmt
     ('human
      (display-profile-content profile number))
     ('channels
-     (pretty-print
-      `(list ,@(map (lambda (entry)
-                      (match (assq 'source (manifest-entry-properties entry))
-                        (('source ('repository ('version 0)
-                                               ('url url)
-                                               ('branch branch)
-                                               ('commit commit)
-                                               _ ...))
-                         `(channel (name ',(string->symbol
-                                            (manifest-entry-name entry)))
-                                   (url ,url)
-                                   (commit ,commit)))
-
-                        ;; Pre-0.15.0 Guix does not provide that information,
-                        ;; so there's not much we can do in that case.
-                        (_ '???)))
-
-                    ;; Show most recently installed packages last.
-                    (reverse
-                     (manifest-entries
-                      (profile-manifest
-                       (if (zero? number)
-                           profile
-                           (generation-file-name profile number))))))))))
+     (pretty-print `(list ,@(map channel->sexp channels))))
+    ('json
+     (format #t "[~a]~%" (string-join (map channel->json channels) ",")))
+    ('recutils
+     (format #t "~{~a~%~}"
+             (map (lambda (channel)
+                    (with-output-to-string
+                      (lambda ()
+                        (channel->recutils channel (current-output-port)))))
+                  channels))))
   (display-package-search-path fmt))
 
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a86b95dd38..ce46f549cc 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -149,6 +149,7 @@ dependencies are registered."
 
 (define* (self-contained-tarball name profile
                                  #:key target
+                                 (profile-name "guix-profile")
                                  deduplicate?
                                  (compressor (first %compressors))
                                  localstatedir?
@@ -221,6 +222,7 @@ added to the pack."
           ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
           (populate-single-profile-directory %root
                                              #:profile #$profile
+                                             #:profile-name #$profile-name
                                              #:closure "profile"
                                              #:database #+database)
 
@@ -279,6 +281,7 @@ added to the pack."
 
 (define* (squashfs-image name profile
                          #:key target
+                         (profile-name "guix-profile")
                          (compressor (first %compressors))
                          localstatedir?
                          (symlinks '())
@@ -377,6 +380,7 @@ added to the pack."
 
 (define* (docker-image name profile
                        #:key target
+                       (profile-name "guix-profile")
                        (compressor (first %compressors))
                        localstatedir?
                        (symlinks '())
@@ -587,6 +591,7 @@ please email '~a'~%")
 (define %default-options
   ;; Alist of default option values.
   `((format . tarball)
+    (profile-name . "guix-profile")
     (system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
@@ -658,6 +663,13 @@ please email '~a'~%")
          (option '("localstatedir") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'localstatedir? #t result)))
+         (option '("profile-name") #t #f
+                 (lambda (opt name arg result)
+                   (match arg
+                     ((or "guix-profile" "current-guix")
+                      (alist-cons 'profile-name arg result))
+                     (_
+                      (leave (G_ "~a: unsupported profile name~%") arg)))))
          (option '("bootstrap") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'bootstrap? #t result)))
@@ -691,6 +703,9 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
   (display (G_ "
+      --profile-name=NAME
+                         populate /var/guix/profiles/.../NAME"))
+  (display (G_ "
       --bootstrap        use the bootstrap binaries to build the pack"))
   (newline)
   (display (G_ "
@@ -779,7 +794,8 @@ Create a bundle of PACKAGE.\n"))
                                 (#f
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
-                 (localstatedir? (assoc-ref opts 'localstatedir?)))
+                 (localstatedir? (assoc-ref opts 'localstatedir?))
+                 (profile-name   (assoc-ref opts 'profile-name)))
             (run-with-store store
               (mlet* %store-monad ((profile (profile-derivation
                                              manifest
@@ -798,6 +814,8 @@ Create a bundle of PACKAGE.\n"))
                                                      symlinks
                                                      #:localstatedir?
                                                      localstatedir?
+                                                     #:profile-name
+                                                     profile-name
                                                      #:archiver
                                                      archiver)))
                 (mbegin %store-monad
diff --git a/guix/status.scm b/guix/status.scm
index ffa9d9e93c..2ceb56788a 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -393,6 +393,9 @@ addition to build events."
   expected hash: ~a
   actual hash:   ~a~%"))
              expected actual))
+    (('build-remote drv host _ ...)
+     (format port (info (G_ "offloading build of ~a to '~a'")) drv host)
+     (newline port))
     (('build-log pid line)
      (if (multiplexed-output-supported?)
          (if (not pid)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 38796910da..e6bfbe763e 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -53,7 +53,7 @@
 
 (define sqlite-exec
   ;; XXX: This is was missing from guile-sqlite3 until
-  ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
+  ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
   (let ((exec (pointer->procedure
                int
                (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))