Merge branch 'master' into core-updates

4 files changed, 329 insertions, 50 deletions

diff --git a/guix/git-download.scm b/guix/git-download.scm
index 316835502c..5019a3e62f 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:export (git-reference
             git-reference?
@@ -125,45 +127,84 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   "Return the file-name for packages using git-download."
   (string-append name "-" version "-checkout"))
 
+
+;;;
+;;; 'git-predicate'.
+;;;
+
+(define (files->directory-tree files)
+  "Return a tree of vhashes representing the directory listed in FILES, a list
+like '(\"a/b\" \"b/c/d\")."
+  (fold (lambda (file result)
+          (let loop ((file (string-split file #\/))
+                     (result result))
+            (match file
+              ((_)
+               result)
+              ((directory children ...)
+               (match (vhash-assoc directory result)
+                 (#f
+                  (vhash-cons directory (loop children vlist-null)
+                              result))
+                 ((_ . previous)
+                  ;; XXX: 'vhash-delete' is O(n).
+                  (vhash-cons directory (loop children previous)
+                              (vhash-delete directory result)))))
+              (()
+               result))))
+        vlist-null
+        files))
+
+(define (directory-in-tree? tree directory)
+  "Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed
+in TREE."
+  (let loop ((directory (string-split directory #\/))
+             (tree       tree))
+    (match directory
+      (()
+       #t)
+      ((head . tail)
+       (match (vhash-assoc head tree)
+         ((_ . sub-tree) (loop tail sub-tree))
+         (#f #f))))))
+
 (define (git-predicate directory)
   "Return a predicate that returns true if a file is part of the Git checkout
 living at DIRECTORY.  Upon Git failure, return #f instead of a predicate.
 
 The returned predicate takes two arguments FILE and STAT where FILE is an
 absolute file name and STAT is the result of 'lstat'."
-  (define (parent-directory? thing directory)
-    ;; Return #t if DIRECTORY is the parent of THING.
-    (or (string-suffix? thing directory)
-        (and (string-index thing #\/)
-             (parent-directory? (dirname thing) directory))))
-
-  (let* ((pipe        (with-directory-excursion directory
-                        (open-pipe* OPEN_READ "git" "ls-files")))
-         (files       (let loop ((lines '()))
-                        (match (read-line pipe)
-                          ((? eof-object?)
-                           (reverse lines))
-                          (line
-                           (loop (cons line lines))))))
-         (inodes      (map (lambda (file)
-                             (let ((stat (lstat
-                                          (string-append directory "/" file))))
-                               (cons (stat:dev stat) (stat:ino stat))))
-                           files))
-         (status      (close-pipe pipe)))
+  (let* ((pipe           (with-directory-excursion directory
+                           (open-pipe* OPEN_READ "git" "ls-files")))
+         (files          (let loop ((lines '()))
+                           (match (read-line pipe)
+                             ((? eof-object?)
+                              (reverse lines))
+                             (line
+                              (loop (cons line lines))))))
+         (directory-tree (files->directory-tree files))
+         (inodes         (fold (lambda (file result)
+                                 (let ((stat
+                                        (lstat (string-append directory "/"
+                                                              file))))
+                                   (vhash-consv (stat:ino stat) (stat:dev stat)
+                                                result)))
+                               vlist-null
+                               files))
+         (prefix-length  (+ 1 (string-length (canonicalize-path directory))))
+         (status         (close-pipe pipe)))
     (and (zero? status)
          (lambda (file stat)
            (match (stat:type stat)
              ('directory
-              ;; 'git ls-files' does not list directories, only regular files,
-              ;; so we need this special trick.
-              (any (lambda (f) (parent-directory? f file))
-                   files))
+              (directory-in-tree? directory-tree
+                                  (string-drop file prefix-length)))
              ((or 'regular 'symlink)
               ;; Comparing file names is always tricky business so we rely on
               ;; inode numbers instead
-              (member (cons (stat:dev stat) (stat:ino stat))
-                      inodes))
+              (match (vhash-assv (stat:ino stat) inodes)
+                ((_ . dev) (= dev (stat:dev stat)))
+                (#f        #f)))
              (_
               #f))))))
 
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index a41f918049..9ee69e5296 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -296,7 +296,7 @@ META."
        (upstream-source
         (package (package-name package))
         (version version)
-        (urls url))))))
+        (urls (list url)))))))
 
 (define %cpan-updater
   (upstream-updater
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 566d117b02..d3cb64d604 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -400,6 +400,7 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
                                      "cat" "/proc/loadavg"))
             (line (read-line pipe)))
        (close-port pipe)
+       (disconnect! session)
 
        (if (eof-object? line)
            +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
@@ -427,13 +428,9 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
   "Return the name of the file used as a lock when choosing a build machine."
   (string-append %state-directory "/offload/machine-choice.lock"))
 
-
-(define %slots
-  ;; List of acquired build slots (open ports).
-  '())
-
 (define (choose-build-machine machines)
-  "Return the best machine among MACHINES, or #f."
+  "Return two values: the best machine among MACHINES and its build
+slot (which must later be released with 'release-build-slot'), or #f and #f."
 
   ;; Proceed like this:
   ;;   1. Acquire the global machine-choice lock.
@@ -480,14 +477,15 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
                 ;; Release slots from the uninteresting machines.
                 (for-each release-build-slot slots)
 
-                ;; Prevent SLOT from being GC'd.
-                (set! %slots (cons slot %slots))
-                best))
+                ;; The caller must keep SLOT to protect it from GC and to
+                ;; eventually release it.
+                (values best slot)))
              (begin
                ;; BEST is overloaded, so try the next one.
                (release-build-slot slot)
                (loop others))))
-        (() #f)))))
+        (()
+         (values #f #f))))))
 
 (define* (process-request wants-local? system drv features
                           #:key
@@ -505,19 +503,25 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
        ;; We'll never be able to match REQS.
        (display "# decline\n"))
       ((x ...)
-       (let ((machine (choose-build-machine candidates)))
+       (let-values (((machine slot)
+                     (choose-build-machine candidates)))
          (if machine
-             (begin
-               ;; Offload DRV to MACHINE.
-               (display "# accept\n")
-               (let ((inputs  (string-tokenize (read-line)))
-                     (outputs (string-tokenize (read-line))))
-                 (transfer-and-offload drv machine
-                                       #:inputs inputs
-                                       #:outputs outputs
-                                       #:max-silent-time max-silent-time
-                                       #:build-timeout build-timeout
-                                       #:print-build-trace? print-build-trace?)))
+             (dynamic-wind
+               (const #f)
+               (lambda ()
+                 ;; Offload DRV to MACHINE.
+                 (display "# accept\n")
+                 (let ((inputs  (string-tokenize (read-line)))
+                       (outputs (string-tokenize (read-line))))
+                   (transfer-and-offload drv machine
+                                         #:inputs inputs
+                                         #:outputs outputs
+                                         #:max-silent-time max-silent-time
+                                         #:build-timeout build-timeout
+                                         #:print-build-trace?
+                                         print-build-trace?)))
+               (lambda ()
+                 (release-build-slot slot)))
 
              ;; Not now, all the machines are busy.
              (display "# postpone\n")))))))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
new file mode 100644
index 0000000000..4c4dfac8f6
--- /dev/null
+++ b/guix/scripts/weather.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 weather)
+  #:use-module (guix ui)
+  #:use-module (guix scripts)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix derivations)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (guix grafts)
+  #:use-module (guix build syscalls)
+  #:use-module (guix scripts substitute)
+  #:use-module (gnu packages)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:export (guix-weather))
+
+(define (all-packages)
+  "Return the list of public packages we are going to query."
+  (fold-packages (lambda (package result)
+                   (match (package-replacement package)
+                     ((? package? replacement)
+                      (cons* replacement package result))
+                     (#f
+                      (cons package result))))
+                 '()))
+
+(define* (package-outputs packages
+                          #:optional (system (%current-system)))
+  "Return the list of outputs of all of PACKAGES for the given SYSTEM."
+  (let ((packages (filter (cut supported-package? <> system) packages)))
+
+    (define update-progress!
+      (let ((total (length packages))
+            (done  0)
+            (width (max 10 (- (terminal-columns) 10))))
+        (lambda ()
+          (set! done (+ 1 done))
+          (let* ((ratio (/ done total 1.))
+                 (done  (inexact->exact (round (* width ratio))))
+                 (left  (- width done)))
+            (format (current-error-port) "~5,1f% [~a~a]\r"
+                    (* ratio 100.)
+                    (make-string done #\#)
+                    (make-string left #\space))
+            (when (>= done total)
+              (newline (current-error-port)))
+            (force-output (current-error-port))))))
+
+    (format (current-error-port)
+            (G_ "computing ~h package derivations for ~a...~%")
+            (length packages) system)
+
+    (foldm %store-monad
+           (lambda (package result)
+             (mlet %store-monad ((drv (package->derivation package system
+                                                           #:graft? #f)))
+               (update-progress!)
+               (match (derivation->output-paths drv)
+                 (((names . items) ...)
+                  (return (append items result))))))
+           '()
+           packages)))
+
+(cond-expand
+  (guile-2.2
+   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
+   (define time-monotonic time-tai))
+  (else #t))
+
+(define (call-with-time thunk kont)
+  "Call THUNK and pass KONT the elapsed time followed by THUNK's return
+values."
+  (let* ((start  (current-time time-monotonic))
+         (result (call-with-values thunk list))
+         (end    (current-time time-monotonic)))
+    (apply kont (time-difference end start) result)))
+
+(define-syntax-rule (let/time ((time result exp)) body ...)
+  (call-with-time (lambda () exp) (lambda (time result) body ...)))
+
+(define (report-server-coverage server items)
+  "Report the subset of ITEMS available as substitutes on SERVER."
+  (define MiB (* (expt 2 20) 1.))
+
+  (format #t (G_ "looking for ~h store items on ~a...~%")
+          (length items) server)
+
+  (let/time ((time narinfos (lookup-narinfos server items)))
+    (format #t "~a~%" server)
+    (let ((obtained  (length narinfos))
+          (requested (length items))
+          (sizes     (filter-map narinfo-file-size narinfos))
+          (time      (+ (time-second time)
+                        (/ (time-nanosecond time) 1e9))))
+      (format #t (G_ "  ~2,1f% substitutes available (~h out of ~h)~%")
+              (* 100. (/ obtained requested 1.))
+              obtained requested)
+      (let ((total (/ (reduce + 0 sizes) MiB)))
+        (match (length sizes)
+          ((? zero?)
+           (format #t (G_  "  unknown substitute sizes~%")))
+          (len
+           (if (= len obtained)
+               (format #t (G_ "  ~,1h MiB of nars (compressed)~%") total)
+               (format #t (G_ "  at least ~,1h MiB of nars (compressed)~%")
+                       total)))))
+      (format #t (G_ "  ~,1h MiB on disk (uncompressed)~%")
+              (/ (reduce + 0 (map narinfo-size narinfos)) MiB))
+      (format #t (G_ "  ~,3h seconds per request (~,1h seconds in total)~%")
+              (/ time requested 1.) time)
+      (format #t (G_ "  ~,1h requests per second~%")
+              (/ requested time 1.)))))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define (show-help)
+  (display (G_ "Usage: guix weather [OPTIONS]
+Report the availability of substitutes.\n"))
+  (display (G_ "
+      --substitute-urls=URLS
+                         check for available substitutes at URLS"))
+  (display (G_ "
+  -m, --manifest=MANIFEST
+                         look up substitutes for packages specified in MANIFEST"))
+  (display (G_ "
+  -s, --system=SYSTEM    consider substitutes for SYSTEM--e.g., \"i686-linux\""))
+  (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 %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 challenge")))
+
+         (option '("substitute-urls") #t #f
+                 (lambda (opt name arg result . rest)
+                   (let ((urls (string-tokenize arg)))
+                     (for-each (lambda (url)
+                                 (unless (string->uri url)
+                                   (leave (G_ "~a: invalid URL~%") url)))
+                               urls)
+                     (apply values
+                            (alist-cons 'substitute-urls urls
+                                        (alist-delete 'substitute-urls result))
+                            rest))))
+         (option '(#\m "manifest") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'manifest arg result)))
+         (option '(#\s "system") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'system arg result)))))
+
+(define %default-options
+  `((substitute-urls . ,%default-substitute-urls)))
+
+(define (load-manifest file)
+  "Load the manifest from FILE and return the list of packages it refers to."
+  (let* ((user-module (make-user-module '((guix profiles) (gnu))))
+         (manifest    (load* file user-module)))
+    (map manifest-entry-item
+         (manifest-transitive-entries manifest))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-weather . args)
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)))
+           (urls     (assoc-ref opts 'substitute-urls))
+           (systems  (match (filter-map (match-lambda
+                                          (('system . system) system)
+                                          (_ #f))
+                                        opts)
+                       (() (list (%current-system)))
+                       (systems systems)))
+           (packages (let ((file (assoc-ref opts 'manifest)))
+                       (if file
+                           (load-manifest file)
+                           (all-packages))))
+           (items    (with-store store
+                       (parameterize ((%graft? #f))
+                         (concatenate
+                          (run-with-store store
+                            (mapm %store-monad
+                                  (lambda (system)
+                                    (package-outputs packages system))
+                                  systems)))))))
+      (for-each (lambda (server)
+                  (report-server-coverage server items))
+                urls))))
+
+;;; Local Variables:
+;;; eval: (put 'let/time 'scheme-indent-function 1)
+;;; End: