Merge branch 'staging' into core-updates

6 files changed, 113 insertions, 23 deletions

diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm
new file mode 100644
index 0000000000..86ee11391d
--- /dev/null
+++ b/guix/build/bzr.scm
@@ -0,0 +1,44 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; 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 build bzr)
+  #:use-module (guix build utils)
+  #:export (bzr-fetch))
+
+;;; Commentary:
+;;;
+;;; This is the build-side support code of (guix bzr-download).  It allows a
+;;; Bazaar repository to be branched at a specific revision.
+;;;
+;;; Code:
+
+(define* (bzr-fetch url revision directory
+                    #:key (bzr-command "bzr"))
+  "Fetch REVISION from URL into DIRECTORY.  REVISION must be a valid Bazaar
+revision identifier.  Return #t on success, else throw an exception."
+  ;; Do not attempt to write .bzr.log to $HOME, which doesn't exist.
+  (setenv "BZR_LOG" "/dev/null")
+  ;; Disable SSL certificate verification; we rely on the hash instead.
+  (invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
+          "--lightweight" "-r" revision url directory)
+  (with-directory-excursion directory
+    (begin
+      (delete-file-recursively ".bzr")
+      #t)))
+
+;;; bzr.scm ends here
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index b68a1f90d2..9f44bd6ee9 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -131,7 +131,7 @@ directory = '" port)
     ;; to store paths.
     (copy-recursively "." rsrc)
     (touch (string-append rsrc "/.cargo-ok"))
-    (generate-checksums rsrc "/dev/null")
+    (generate-checksums rsrc)
     (install-file "Cargo.toml" rsrc)
     #t))
 
diff --git a/guix/build/cargo-utils.scm b/guix/build/cargo-utils.scm
index 6af572e611..79e5440378 100644
--- a/guix/build/cargo-utils.scm
+++ b/guix/build/cargo-utils.scm
@@ -41,12 +41,10 @@
       (close-pipe port)
       result)))
 
-(define (generate-checksums dir-name src-name)
+(define (generate-checksums dir-name)
   "Given DIR-NAME, a store directory, checksum all the files in it one
 by one and put the result into the file \".cargo-checksum.json\" in
-the same directory.  Also includes the checksum of an extra file
-SRC-NAME as if it was part of the directory DIR-NAME with name
-\"package\"."
+the same directory."
   (let* ((file-names (find-files dir-name "."))
          (dir-prefix-name (string-append dir-name "/"))
          (dir-prefix-name-len (string-length dir-prefix-name))
@@ -62,6 +60,9 @@ SRC-NAME as if it was part of the directory DIR-NAME with name
                   (write file-relative-name port)
                   (display ":" port)
                   (write (file-sha256 file-name) port))) file-names))
+        ;; NB: cargo requires the "package" field in order to check if the Cargo.lock
+        ;; file needs to be regenerated when the value changes. However, it doesn't
+        ;; appear to care what the value is to begin with...
         (display "},\"package\":" port)
-        (write (file-sha256 src-name) port)
+        (write (file-sha256 "/dev/null") port)
         (display "}" port)))))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index a64e0f0bd3..0c9c61de4b 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -380,6 +380,20 @@ ETIMEDOUT error is raised."
               (apply throw args)
               (loop (cdr addresses))))))))
 
+(define (setup-http-tunnel port uri)
+  "Establish over PORT an HTTP tunnel to the destination server of URI."
+  (define target
+    (string-append (uri-host uri) ":"
+                   (number->string
+                    (or (uri-port uri)
+                        (match (uri-scheme uri)
+                          ('http 80)
+                          ('https 443))))))
+  (format port "CONNECT ~a HTTP/1.1\r\n" target)
+  (format port "Host: ~a\r\n\r\n" target)
+  (force-output port)
+  (read-response port))
+
 (define* (open-connection-for-uri uri
                                   #:key
                                   timeout
@@ -393,21 +407,20 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
   (define https?
     (eq? 'https (uri-scheme uri)))
 
+  (define https-proxy (let ((proxy (getenv "https_proxy")))
+                        (and (not (equal? proxy ""))
+                             proxy)))
+
   (let-syntax ((with-https-proxy
                 (syntax-rules ()
                   ((_ exp)
                    ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
-                   ;; FIXME: Proxying is not supported for https.
                    (let ((thunk (lambda () exp)))
                      (if (and https?
                               (module-variable
                                (resolve-interface '(web client))
                                'current-http-proxy))
-                         (parameterize ((current-http-proxy #f))
-                           (when (and=> (getenv "https_proxy")
-                                        (negate string-null?))
-                             (format (current-error-port)
-                                     "warning: 'https_proxy' is ignored~%"))
+                         (parameterize ((current-http-proxy https-proxy))
                            (thunk))
                          (thunk)))))))
     (with-https-proxy
@@ -415,6 +428,9 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
        ;; Buffer input and output on this port.
        (setvbuf s 'block %http-receive-buffer-size)
 
+       (when (and https? https-proxy)
+         (setup-http-tunnel s uri))
+
        (if https?
            (tls-wrap s (uri-host uri)
                      #:verify-certificate? verify-certificate?)
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 282df19f24..858068ba98 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Petter <petter@mykolab.ch>
 ;;; Copyright © 2017, 2019 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,7 @@
   #:use-module (guix build union)
   #:use-module (guix build utils)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
   #:use-module (srfi srfi-1)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
@@ -151,22 +153,40 @@ dependencies, so it should be self-contained."
   #t)
 
 (define* (unpack #:key source import-path unpack-path #:allow-other-keys)
-  "Relative to $GOPATH, unpack SOURCE in the UNPACK-PATH, or the IMPORT-PATH is
-the UNPACK-PATH is unset.  When SOURCE is a directory, copy it instead of
+  "Relative to $GOPATH, unpack SOURCE in UNPACK-PATH, or IMPORT-PATH when
+UNPACK-PATH is unset.  If the SOURCE archive has a single top level directory,
+it is stripped so that the sources appear directly under UNPACK-PATH.  When
+SOURCE is a directory, copy its content into UNPACK-PATH instead of
 unpacking."
-  (if (string-null? import-path)
-      ((display "WARNING: The Go import path is unset.\n")))
-  (if (string-null? unpack-path)
-      (set! unpack-path import-path))
+  (define (unpack-maybe-strip source dest)
+    (let* ((scratch-dir (string-append (or (getenv "TMPDIR") "/tmp")
+                                       "/scratch-dir"))
+           (out (mkdir-p scratch-dir)))
+      (with-directory-excursion scratch-dir
+        (if (string-suffix? ".zip" source)
+            (invoke "unzip" source)
+            (invoke "tar" "-xvf" source))
+        (let ((top-level-files (remove (lambda (x)
+                                         (member x '("." "..")))
+                                       (scandir "."))))
+          (match top-level-files
+            ((top-level-file)
+             (when (file-is-directory? top-level-file)
+               (copy-recursively top-level-file dest #:keep-mtime? #t)))
+            (_
+             (copy-recursively "." dest #:keep-mtime? #t)))))
+      (delete-file-recursively scratch-dir)))
+
+  (when (string-null? import-path)
+    (display "WARNING: The Go import path is unset.\n"))
+  (when (string-null? unpack-path)
+    (set! unpack-path import-path))
   (let ((dest (string-append (getenv "GOPATH") "/src/" unpack-path)))
     (mkdir-p dest)
     (if (file-is-directory? source)
-      (begin
         (copy-recursively source dest #:keep-mtime? #t)
-        #t)
-      (if (string-suffix? ".zip" source)
-        (invoke "unzip" "-d" dest source)
-        (invoke "tar" "-C" dest "-xvf" source)))))
+        (unpack-maybe-strip source dest)))
+  #t)
 
 (define (go-package? name)
   (string-prefix? "go-" name))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 749616ceb1..3abe65bc4f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -104,6 +104,7 @@
             network-interface-netmask
             network-interface-running?
             loopback-network-interface?
+            arp-network-interface?
             network-interface-address
             set-network-interface-netmask
             set-network-interface-up
@@ -1160,6 +1161,7 @@ bytes."
 (define-as-needed IFF_BROADCAST #x2)              ;Broadcast address valid.
 (define-as-needed IFF_LOOPBACK #x8)               ;Is a loopback net.
 (define-as-needed IFF_RUNNING #x40)               ;interface RFC2863 OPER_UP
+(define-as-needed IFF_NOARP #x80)                 ;ARP disabled or unsupported
 
 (define IF_NAMESIZE 16)                           ;maximum interface name size
 
@@ -1341,6 +1343,13 @@ interface NAME."
     (close-port sock)
     (not (zero? (logand flags IFF_RUNNING)))))
 
+(define (arp-network-interface? name)
+  "Return true if NAME supports the Address Resolution Protocol."
+  (let* ((sock  (socket SOCK_STREAM AF_INET 0))
+         (flags (network-interface-flags sock name)))
+    (close-port sock)
+    (zero? (logand flags IFF_NOARP))))
+
 (define-as-needed (set-network-interface-flags socket name flags)
   "Set the flag of network interface NAME to FLAGS."
   (let ((req (make-bytevector ifreq-struct-size)))