Merge branch 'master' into core-updates-frozen

4 files changed, 74 insertions, 59 deletions

diff --git a/guix/narinfo.scm b/guix/narinfo.scm
index 72e0f75fda..4fc550aa6c 100644
--- a/guix/narinfo.scm
+++ b/guix/narinfo.scm
@@ -144,7 +144,9 @@ must contain the original contents of a narinfo file."
                    (map (lambda (url)
                           (or (string->uri url)
                               (string->uri
-                               (string-append cache-url "/" url))))
+                               (if (string-suffix? "/" cache-url)
+                                   (string-append cache-url url)
+                                   (string-append cache-url "/" url)))))
                         urls)
                    compressions
                    (match file-sizes
diff --git a/guix/progress.scm b/guix/progress.scm
index 0cbc804ec1..4f8e98edc0 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -270,19 +270,25 @@ ABBREVIATION used to shorten FILE for display."
 tasks is performed.  Write PREFIX at the beginning of the line."
   (define done 0)
 
+  (define (draw-bar)
+    (let* ((ratio (* 100. (/ done total))))
+      (erase-current-line port)
+      (if (string-null? prefix)
+          (display (progress-bar ratio (current-terminal-columns)) port)
+          (let ((width (- (current-terminal-columns)
+                          (string-length prefix) 3)))
+            (display prefix port)
+            (display "  " port)
+            (display (progress-bar ratio width) port)))
+      (force-output port)))
+
+  (define draw-bar/rate-limited
+    (rate-limited draw-bar %progress-interval))
+
   (define (report-progress)
     (set! done (+ 1 done))
     (unless (> done total)
-      (let* ((ratio (* 100. (/ done total))))
-        (erase-current-line port)
-        (if (string-null? prefix)
-            (display (progress-bar ratio (current-terminal-columns)) port)
-            (let ((width (- (current-terminal-columns)
-                            (string-length prefix) 3)))
-              (display prefix port)
-              (display "  " port)
-              (display (progress-bar ratio width) port)))
-        (force-output port))))
+      (draw-bar/rate-limited)))
 
   (progress-reporter
    (start (lambda ()
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 69c2781abb..c29d5105ae 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -35,10 +35,10 @@
   #:use-module (gcrypt hash)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
@@ -196,65 +196,68 @@ taken since we do not import the archives."
 
 (define (port-sha256* port size)
   ;; Like 'port-sha256', but limited to SIZE bytes.
-  (let-values (((out get) (open-sha256-port)))
+  (let ((out get (open-sha256-port)))
     (dump-port* port out size)
     (close-port out)
     (get)))
 
 (define (archive-contents port)
-  "Return a list representing the files contained in the nar read from PORT."
-  (fold-archive (lambda (file type contents result)
-                  (match type
-                    ((or 'regular 'executable)
-                     (match contents
-                       ((port . size)
-                        (cons `(,file ,type ,(port-sha256* port size))
-                              result))))
-                    ('directory result)
-                    ('directory-complete result)
-                    ('symlink
-                     (cons `(,file ,type ,contents) result))))
-                '()
-                port
-                ""))
+  "Return a list representing the files contained in the nar read from PORT.
+The list is sorted in canonical order--i.e., the order in which entries appear
+in the nar."
+  (reverse
+   (fold-archive (lambda (file type contents result)
+                   (match type
+                     ((or 'regular 'executable)
+                      (match contents
+                        ((port . size)
+                         (cons `(,file ,type ,(port-sha256* port size))
+                               result))))
+                     ('directory result)
+                     ('directory-complete result)
+                     ('symlink
+                      (cons `(,file ,type ,contents) result))))
+                 '()
+                 port
+                 "")))
 
 (define (store-item-contents item)
   "Return a list of files and contents for ITEM in the same format as
 'archive-contents'."
-  (file-system-fold (const #t)                    ;enter?
-                    (lambda (file stat result)    ;leaf
-                      (define short
-                        (string-drop file (string-length item)))
-
-                      (match (stat:type stat)
-                        ('regular
-                         (let ((size (stat:size stat))
-                               (type (if (zero? (logand (stat:mode stat)
-                                                        #o100))
-                                         'regular
-                                         'executable)))
-                           (cons `(,short ,type
-                                          ,(call-with-input-file file
-                                             (cut port-sha256* <> size)))
-                                 result)))
-                        ('symlink
-                         (cons `(,short symlink ,(readlink file))
-                               result))))
-                    (lambda (directory stat result) result)  ;down
-                    (lambda (directory stat result) result)  ;up
-                    (lambda (file stat result) result)       ;skip
-                    (lambda (file stat errno result) result) ;error
-                    '()
-                    item
-                    lstat))
+  (let loop ((file item))
+    (define stat
+      (lstat file))
+
+    (define short
+      (string-drop file (string-length item)))
+
+    (match (stat:type stat)
+      ('regular
+       (let ((size (stat:size stat))
+             (type (if (zero? (logand (stat:mode stat)
+                                      #o100))
+                       'regular
+                       'executable)))
+         `((,short ,type
+                   ,(call-with-input-file file
+                      (cut port-sha256* <> size))))))
+      ('symlink
+       `((,short symlink ,(readlink file))))
+      ('directory
+       (append-map (match-lambda
+                     ((or "." "..")
+                      '())
+                     (entry
+                      (loop (string-append file "/" entry))))
+                   ;; Traverse entries in canonical order, the same as the
+                   ;; order of entries in nars.
+                   (scandir file (const #t) string<?))))))
 
 (define (call-with-nar narinfo proc)
   "Call PROC with an input port from which it can read the nar pointed to by
 NARINFO."
-  (let*-values (((uri compression size)
-                 (narinfo-best-uri narinfo))
-                ((port actual-size)
-                 (http-fetch uri)))
+  (let* ((uri compression size (narinfo-best-uri narinfo))
+         (port actual-size     (http-fetch uri)))
     (define reporter
       (progress-reporter/file (narinfo-path narinfo)
                               (and size
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index a5c554acff..9014cf61ec 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -156,7 +156,11 @@ indicates that PATH is unavailable at CACHE-URL."
 
 (define (narinfo-request cache-url path)
   "Return an HTTP request for the narinfo of PATH at CACHE-URL."
-  (let* ((base (string->uri cache-url))
+  ;; Ensure BASE has a trailing slash so that REF is correct regardless of
+  ;; whether the user-provided CACHE-URL has a trailing slash.
+  (let* ((base (string->uri (if (string-suffix? "/" cache-url)
+                                cache-url
+                                (string-append cache-url "/"))))
          (ref (build-relative-ref
                #:path (string-append (store-path-hash-part path) ".narinfo")))
          (url (resolve-uri-reference ref base))