summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/cargo-build-system.scm76
-rw-r--r--guix/build/download.scm40
-rw-r--r--guix/build/syscalls.scm78
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.
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-03 14:21:44 +0000