gnu: Add myway.

[jackhill/guix/guix.git] / build-aux / check-available-binaries.scm

diff --git a/build-aux/check-available-binaries.scm b/build-aux/check-available-binaries.scm
index 04f88b7..c80db1a 100644 (file)
--- a/build-aux/check-available-binaries.scm
+++ b/build-aux/check-available-binaries.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,16 +17,18 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;;
-;;; Check whether important binaries are available at hydra.gnu.org.
+;;; Check whether important binaries are available.
 ;;;
 
 (use-modules (guix store)
+             (guix grafts)
              (guix packages)
              (guix derivations)
              (gnu packages emacs)
              (gnu packages make-bootstrap)
              (srfi srfi-1)
-             (srfi srfi-26))
+             (srfi srfi-26)
+             (ice-9 format))
 
 (with-store store
   (parameterize ((%graft? #f))
@@ -36,21 +38,21 @@
                                %hydra-supported-systems))
            (cross  (map (cut package-cross-derivation store
                              %bootstrap-tarballs <>)
-                        '("mips64el-linux-gnuabi64")))
+                        '("mips64el-linux-gnu"
+                          "arm-linux-gnueabihf")))
            (total  (append native cross)))
-      (define (warn item system)
-        (format (current-error-port) "~a (~a) is not substitutable~%"
-                item system)
-        #f)
 
-      (set-build-options store #:use-substitutes? #t)
-      (let* ((substitutable? (substitution-oracle store total))
-             (result         (every (lambda (drv)
-                                      (let ((out (derivation->output-path drv)))
-                                        (or (substitutable? out)
-                                            (warn out (derivation-system drv)))))
-                                    total)))
-        (when result
-          (format (current-error-port) "~a packages found substitutable~%"
-                  (length total)))
-        (exit result)))))
+      (set-build-options store
+                         #:use-substitutes? #t
+                         #:substitute-urls %default-substitute-urls)
+      (let* ((total     (map derivation->output-path total))
+             (available (substitutable-paths store total))
+             (missing   (lset-difference string=? total available)))
+        (if (null? missing)
+            (format (current-error-port)
+                    "~a packages found substitutable on~{ ~a~}~%"
+                    (length total) %hydra-supported-systems)
+            (format (current-error-port)
+                    "~a packages are not substitutable:~%~{  ~a~%~}~%"
+                    (length missing) missing))
+        (exit (null? missing))))))