diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-05-25 00:25:15 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-05-25 00:25:15 +0200 |
commit | 57df83e07d4b5e78d9a54c1a88d05b4a9ed65714 (patch) | |
tree | 76684e63965e9ad6e37d9d45bc3159e6c9782cd0 /guix/build | |
parent | 43d9ed7792808638eabb43aa6133f1d6186c520b (diff) | |
parent | 136b7d81f0eb713783e9ea7cf7f260a2b6252dfd (diff) |
Merge branch 'staging' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/bzr.scm | 44 | ||||
-rw-r--r-- | guix/build/cargo-build-system.scm | 2 | ||||
-rw-r--r-- | guix/build/cargo-utils.scm | 11 | ||||
-rw-r--r-- | guix/build/download.scm | 28 | ||||
-rw-r--r-- | guix/build/go-build-system.scm | 42 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 9 |
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))) |