diff options
author | Efraim Flashner <efraim@flashner.co.il> | 2021-03-24 15:28:33 +0200 |
---|---|---|
committer | Efraim Flashner <efraim@flashner.co.il> | 2021-03-24 20:50:44 +0200 |
commit | 2aab587f842908a886e3bd08b028885dddd650e0 (patch) | |
tree | 87c0723a9ae2c69ab6920d90b6e87ad8510492fe /guix/build | |
parent | 5664bcdcb0e4c10dfe48dd5e4730fc3c746a21e2 (diff) | |
parent | 65c46e79e0495fe4d32f6f2725d7233fff10fd70 (diff) | |
download | guix-patches-2aab587f842908a886e3bd08b028885dddd650e0.tar guix-patches-2aab587f842908a886e3bd08b028885dddd650e0.tar.gz |
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/cargo-build-system.scm | 76 | ||||
-rw-r--r-- | guix/build/download.scm | 40 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 78 |
3 files changed, 175 insertions, 19 deletions
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 1d21b33895..0a95672b00 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> -;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Marius Bakke <marius@gnu.org> ;;; @@ -73,6 +73,44 @@ Cargo.toml file present at its root." " | cut -d/ -f2" " | grep -q '^Cargo.toml$'"))))) +(define* (unpack-rust-crates #:key inputs vendor-dir #:allow-other-keys) + (define (inputs->rust-inputs inputs) + "Filter using the label part from INPUTS." + (filter (lambda (input) + (match input + ((name . _) (rust-package? name)))) + inputs)) + (define (inputs->directories inputs) + "Extract the directory part from INPUTS." + (match inputs + (((names . directories) ...) + directories))) + + (let ((rust-inputs (inputs->directories (inputs->rust-inputs inputs)))) + (unless (null? rust-inputs) + (mkdir-p "target/package") + (mkdir-p vendor-dir) + ;; TODO: copy only regular inputs to target/package, not native-inputs. + (for-each + (lambda (input-crate) + (for-each + (lambda (packaged-crate) + (unless + (file-exists? + (string-append "target/package/" (basename packaged-crate))) + (install-file packaged-crate "target/package/"))) + (find-files + (string-append input-crate "/share/cargo/registry") "\\.crate$"))) + (delete-duplicates rust-inputs)) + + (for-each (lambda (crate) + (invoke "tar" "xzf" crate "-C" vendor-dir)) + (find-files "target/package" "\\.crate$")))) + #t) + +(define (rust-package? name) + (string-prefix? "rust-" name)) + (define* (configure #:key inputs (vendor-dir "guix-vendor") #:allow-other-keys) @@ -170,9 +208,27 @@ directory = '" port) (apply invoke "cargo" "test" cargo-test-flags) #t)) -(define* (install #:key inputs outputs skip-build? features #:allow-other-keys) +(define* (package #:key + install-source? + (cargo-package-flags '("--no-metadata" "--no-verify")) + #:allow-other-keys) + "Run 'cargo-package' for a given Cargo package." + (if install-source? + (apply invoke `("cargo" "package" ,@cargo-package-flags)) + (format #t "Not installing cargo sources, skipping `cargo package`.~%")) + #t) + +(define* (install #:key + inputs + outputs + skip-build? + install-source? + features + #:allow-other-keys) "Install a given Cargo package." - (let* ((out (assoc-ref outputs "out"))) + (let* ((out (assoc-ref outputs "out")) + (registry (string-append out "/share/cargo/registry")) + (sources (string-append out "/share/cargo/src"))) (mkdir-p out) ;; Make cargo reuse all the artifacts we just built instead @@ -186,6 +242,18 @@ directory = '" port) (invoke "cargo" "install" "--no-track" "--path" "." "--root" out "--features" (string-join features))) + (when install-source? + ;; Install crate tarballs and unpacked sources for later use. + ;; TODO: Is there a better format/directory for these files? + (mkdir-p sources) + (for-each (lambda (crate) + (install-file crate registry)) + (find-files "target/package" "\\.crate$")) + + (for-each (lambda (crate) + (invoke "tar" "xzf" crate "-C" sources)) + (find-files registry "\\.crate$"))) + #t)) (define %standard-phases @@ -195,6 +263,8 @@ directory = '" port) (replace 'build build) (replace 'check check) (replace 'install install) + (add-after 'build 'package package) + (add-after 'unpack 'unpack-rust-crates unpack-rust-crates) (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) diff --git a/guix/build/download.scm b/guix/build/download.scm index 46af149b2f..a22d4064ca 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; @@ -28,7 +28,6 @@ #:use-module (guix build utils) #:use-module (guix progress) #:use-module (rnrs io ports) - #:use-module ((ice-9 binary-ports) #:select (unget-bytevector)) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -306,14 +305,22 @@ host name without trailing dot." (let ((record (session-record-port session))) (define (read! bv start count) - (define read-bv (get-bytevector-some record)) - (if (eof-object? read-bv) - 0 ; read! returns 0 on eof-object - (let ((read-bv-len (bytevector-length read-bv))) - (bytevector-copy! read-bv 0 bv start (min read-bv-len count)) - (when (< count read-bv-len) - (unget-bytevector record bv count (- read-bv-len count))) - read-bv-len))) + (define read + (catch 'gnutls-error + (lambda () + (get-bytevector-n! record bv start count)) + (lambda (key err proc . rest) + ;; When responding to "Connection: close" requests, some + ;; servers close the connection abruptly after sending the + ;; response body, without doing a proper TLS connection + ;; termination. Treat it as EOF. + (if (eq? err error/premature-termination) + the-eof-object + (apply throw key err proc rest))))) + + (if (eof-object? read) + 0 + read)) (define (write! bv start count) (put-bytevector record bv start count) (force-output record) @@ -328,17 +335,24 @@ host name without trailing dot." (unless (port-closed? record) (close-port record))) + (define (unbuffered port) + (setvbuf port 'none) + port) + (setvbuf record 'block) ;; Return a port that wraps RECORD to ensure that closing it also ;; closes PORT, the actual socket port, and its file descriptor. + ;; Make sure it does not introduce extra buffering (custom ports + ;; are buffered by default as of Guile 3.0.5). ;; XXX: This wrapper would be unnecessary if GnuTLS could ;; automatically close SESSION's file descriptor when RECORD is ;; closed, but that doesn't seem to be possible currently (as of ;; 3.6.9). - (make-custom-binary-input/output-port "gnutls wrapped port" read! write! - get-position set-position! - close)))) + (unbuffered + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close))))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) (cond diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 552343a481..8886fc0fb9 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,21 @@ file-system-fragment-size file-system-mount-flags statfs + + ST_RDONLY + ST_NOSUID + ST_NODEV + ST_NOEXEC + ST_SYNCHRONOUS + ST_MANDLOCK + ST_WRITE + ST_APPEND + ST_IMMUTABLE + ST_NOATIME + ST_NODIRATIME + ST_RELATIME + statfs-flags->mount-flags + free-disk-space device-in-use? add-to-entropy-count @@ -621,8 +637,9 @@ current process." (if (eof-object? line) (reverse result) (match (string-tokenize line) + ;; See the proc(5) man page for a description of the columns. ((id parent-id major:minor root mount-point - options _ type source _ ...) + options _ ... "-" type source _) (let ((devno (string->device-number major:minor))) (loop (cons (%mount (octal-decode source) (octal-decode mount-point) @@ -754,6 +771,56 @@ fdatasync(2) on the underlying file descriptor." (define-syntax fsword ;fsword_t (identifier-syntax long)) +(define linux? (string-contains %host-type "linux-gnu")) + +(define-syntax define-statfs-flags + (syntax-rules (linux hurd) + "Define the statfs mount flags." + ((_ (name (linux linux-value) (hurd hurd-value)) rest ...) + (begin + (define name + (if linux? linux-value hurd-value)) + (define-statfs-flags rest ...))) + ((_ (name value) rest ...) + (begin + (define name value) + (define-statfs-flags rest ...))) + ((_) #t))) + +(define-statfs-flags ;<bits/statfs.h> + (ST_RDONLY 1) + (ST_NOSUID 2) + (ST_NODEV (linux 4) (hurd 0)) + (ST_NOEXEC 8) + (ST_SYNCHRONOUS 16) + (ST_MANDLOCK (linux 64) (hurd 0)) + (ST_WRITE (linux 128) (hurd 0)) + (ST_APPEND (linux 256) (hurd 0)) + (ST_IMMUTABLE (linux 512) (hurd 0)) + (ST_NOATIME (linux 1024) (hurd 32)) + (ST_NODIRATIME (linux 2048) (hurd 0)) + (ST_RELATIME (linux 4096) (hurd 64))) + +(define (statfs-flags->mount-flags flags) + "Convert FLAGS, a logical or of ST_* constants as returned by +'file-system-mount-flags', to the corresponding logical or of MS_* constants." + (letrec-syntax ((match-flags (syntax-rules (=>) + ((_ (statfs => mount) rest ...) + (logior (if (zero? (logand flags statfs)) + 0 + mount) + (match-flags rest ...))) + ((_) + 0)))) + (match-flags + (ST_RDONLY => MS_RDONLY) + (ST_NOSUID => MS_NOSUID) + (ST_NODEV => MS_NODEV) + (ST_NOEXEC => MS_NOEXEC) + (ST_NOATIME => MS_NOATIME) + (ST_NODIRATIME => 0) ;FIXME + (ST_RELATIME => MS_RELATIME)))) + (define-c-struct %statfs ;<bits/statfs.h> sizeof-statfs ;slightly overestimated file-system @@ -769,7 +836,7 @@ fdatasync(2) on the underlying file descriptor." (identifier (array int 2)) (name-length fsword) (fragment-size fsword) - (mount-flags fsword) + (mount-flags fsword) ;ST_* (spare (array fsword 4))) (define statfs @@ -876,7 +943,11 @@ backend device." ;;; ;; From <uapi/linux/random.h>. -(define RNDADDTOENTCNT #x40045201) +(define RNDADDTOENTCNT + ;; Avoid using %current-system here to avoid depending on host-side code. + (if (string-prefix? "powerpc64le" %host-type) + #x80045201 + #x40045201)) (define (add-to-entropy-count port-or-fd n) "Add N to the kernel's entropy count (the value that can be read from @@ -955,6 +1026,7 @@ Turning finalization off shuts down the finalization thread as a side effect." ("mips64" 5055) ("armv7l" 120) ("aarch64" 220) + ("ppc64le" 120) (_ #f)))) (lambda (flags) "Create a new child process by duplicating the current parent process. |