03/09: guix archive: Add '--list'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 044277f610b02c3821afa0afdc2b2b140bb92cb4
Author: Ludovic Courtès <address@hidden>
Date:   Wed Dec 4 22:54:05 2019 +0100

    guix archive: Add '--list'.
    
    * guix/scripts/archive.scm (show-help, %options): Add '--list'.
    (list-contents): New procedure.
    (guix-archive): Honor the '--list' option.
    * tests/guix-archive.sh: Test it.
    * doc/guix.texi (Invoking guix archive): Document it.
---
 doc/guix.texi            | 12 ++++++++++++
 guix/scripts/archive.scm | 45 ++++++++++++++++++++++++++++++++++++++++++++-
 tests/guix-archive.sh    |  7 ++++++-
 3 files changed, 62 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 01980bf..cb51878 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4598,6 +4598,18 @@ unsafe.
 The primary purpose of this operation is to facilitate inspection of
 archive contents coming from possibly untrusted substitute servers.
 
+@item --list
+@itemx -t
+Read a single-item archive as served by substitute servers
+(@pxref{Substitutes}) and print the list of files it contains, as in
+this example:
+
+@example
+$ wget -O - \
+  https://@value{SUBSTITUTE-SERVER}/nar/lzip/@dots{}-emacs-26.3 \
+  | lzip -d | guix archive -t
+@end example
+
 @end table
 
 
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 3318ef0..2b4d39c 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -21,7 +21,8 @@
   #:use-module (guix utils)
   #:use-module (guix combinators)
   #:use-module ((guix build utils) #:select (mkdir-p))
-  #:use-module ((guix serialization) #:select (restore-file))
+  #:use-module ((guix serialization)
+                #:select (fold-archive restore-file))
   #:use-module (guix store)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix grafts)
@@ -43,6 +44,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 binary-ports)
+  #:use-module (rnrs bytevectors)
   #:export (guix-archive
             options->derivations+files))
 
@@ -76,6 +78,8 @@ Export/import one or more packages from/to the store.\n"))
       --missing          print the files from stdin that are missing"))
   (display (G_ "
   -x, --extract=DIR      extract the archive on stdin to DIR"))
+  (display (G_ "
+  -t, --list             list the files in the archive on stdin"))
   (newline)
   (display (G_ "
       --generate-key[=PARAMETERS]
@@ -137,6 +141,9 @@ Export/import one or more packages from/to the store.\n"))
          (option '("extract" #\x) #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'extract arg result)))
+         (option '("list" #\t) #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'list #t result)))
          (option '("generate-key") #f #t
                  (lambda (opt name arg result)
                    (catch 'gcry-error
@@ -319,6 +326,40 @@ the input port."
       (with-atomic-file-output %acl-file
         (cut write-acl acl <>)))))
 
+(define (list-contents port)
+  "Read a nar from PORT and print the list of files it contains to the current
+output port."
+  (define (consume-input port size)
+    (let ((bv (make-bytevector 32768)))
+      (let loop ((total size))
+        (unless (zero? total)
+          (let ((n (get-bytevector-n! port bv 0
+                                      (min total (bytevector-length bv)))))
+            (loop (- total n)))))))
+
+  (fold-archive (lambda (file type content result)
+                  (match type
+                    ('directory
+                     (format #t "D ~a~%" file))
+                    ('symlink
+                     (format #t "S ~a -> ~a~%" file content))
+                    ((or 'regular 'executable)
+                     (match content
+                       ((input . size)
+                        (format #t "~a ~60a ~10h B~%"
+                                (if (eq? type 'executable)
+                                    "x" "r")
+                                file size)
+                        (consume-input input size))))))
+                #t
+                port
+                ""))
+
+
+;;;
+;;; Entry point.
+;;;
+
 (define (guix-archive . args)
   (define (lines port)
     ;; Return lines read from PORT.
@@ -353,6 +394,8 @@ the input port."
                                    (missing (remove (cut valid-path? store <>)
                                                     files)))
                               (format #t "~{~a~%~}" missing)))
+                           ((assoc-ref opts 'list)
+                            (list-contents (current-input-port)))
                            ((assoc-ref opts 'extract)
                             =>
                             (lambda (target)
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
index fdaeb98..4c5eea0 100644
--- a/tests/guix-archive.sh
+++ b/tests/guix-archive.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <address@hidden>
 #
 # This file is part of GNU Guix.
 #
@@ -74,5 +74,10 @@ guix archive -x "$tmpdir" < "$archive"
 test -x "$tmpdir/bin/guile"
 test -d "$tmpdir/lib/guile"
 
+# Check '--list'.
+guix archive -t < "$archive" | grep "^D /share/guile"
+guix archive -t < "$archive" | grep "^x /bin/guile"
+guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm"
+
 if echo foo | guix archive --authorize
 then false; else true; fi