* [bug#70494] [PATCH 01/23] store: database: Register derivation outputs.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-07 14:30 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 02/23] gnu: linux-container: Make it more suitable for derivation-building Christopher Baines
` (21 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Christopher Baines, Josselin Poiret,
Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
Simon Tournier, Tobias Geerinckx-Rice
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
* guix/store/database.scm (register-derivation-outputs,
registered-derivation-outputs): New procedures
(register-valid-path): Call register-derivation-outputs for derivations.
Co-authored-by: Christopher Baines <mail@cbaines.net>
Change-Id: Id958709f36f24ee1c9c375807e8146a9d1cc4259
---
guix/store/database.scm | 49 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 49 insertions(+)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index a847f9d2f0..6a9acc2aef 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -22,6 +22,9 @@
(define-module (guix store database)
#:use-module (sqlite3)
#:use-module (guix config)
+ #:use-module (guix serialization)
+ #:use-module (guix store)
+ #:use-module (guix derivations)
#:use-module (guix store deduplication)
#:use-module (guix base16)
#:use-module (guix progress)
@@ -44,7 +47,9 @@ (define-module (guix store database)
valid-path-id
register-valid-path
+ register-derivation-outputs
register-items
+ registered-derivation-outputs
%epoch
reset-timestamps
vacuum-database))
@@ -206,6 +211,26 @@ (define-inlinable (assert-integer proc in-range? key number)
"Integer ~A out of range: ~S" (list key number)
(list number))))
+(define (register-derivation-outputs db drv)
+ "Register all output paths of DRV as being produced by it (note that
+this doesn't mean 'already produced by it', but rather just 'associated with
+it')."
+ (let ((stmt (sqlite-prepare
+ db
+ "
+INSERT OR REPLACE INTO DerivationOutputs (drv, id, path)
+SELECT id, :outid, :outpath FROM ValidPaths WHERE path = :drvpath;"
+ #:cache? #t)))
+ (for-each (match-lambda
+ ((outid . ($ <derivation-output> path))
+ (sqlite-bind-arguments stmt
+ #:drvpath (derivation-file-name
+ drv)
+ #:outid outid
+ #:outpath path)
+ (sqlite-step-and-reset stmt)))
+ (derivation-outputs drv))))
+
(define (add-references db referrer references)
"REFERRER is the id of the referring store item, REFERENCES is a list
ids of items referred to."
@@ -284,6 +309,11 @@ (define* (register-valid-path db #:key path (references '())
(sqlite-step-and-reset stmt)
(last-insert-row-id db)))))
+ (when (derivation-path? path)
+ (register-derivation-outputs db
+ (read-derivation-from-file
+ path)))
+
;; Call 'path-id' on each of REFERENCES. This ensures we get a
;; "non-NULL constraint" failure if one of REFERENCES is unregistered.
(add-references db id
@@ -331,6 +361,25 @@ (define %epoch
;; When it all began.
(make-time time-utc 0 1))
+(define (registered-derivation-outputs db drv)
+ "Get the list of (id, output-path) pairs registered for DRV."
+ (let ((stmt (sqlite-prepare
+ db
+ "
+SELECT id, path
+FROM DerivationOutputs
+WHERE drv in (SELECT id from ValidPaths where path = :drv)"
+ #:cache? #t)))
+ (sqlite-bind-arguments stmt #:drv drv)
+ (let ((result (sqlite-fold (lambda (current prev)
+ (match current
+ (#(id path)
+ (cons (cons id path)
+ prev))))
+ '() stmt)))
+ (sqlite-reset stmt)
+ result)))
+
(define* (register-items db items
#:key prefix
(registration-time (timestamp))
base-commit: 92af4ea17f70207fbbf2513f677f3171d4eafd41
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 01/23] store: database: Register derivation outputs.
2024-04-21 9:42 ` [bug#70494] [PATCH 01/23] store: database: Register derivation outputs Christopher Baines
@ 2024-05-07 14:30 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-07 14:30 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> From: Caleb Ristvedt <caleb.ristvedt@cune.org>
>
> * guix/store/database.scm (register-derivation-outputs,
> registered-derivation-outputs): New procedures
> (register-valid-path): Call register-derivation-outputs for derivations.
>
> Co-authored-by: Christopher Baines <mail@cbaines.net>
> Change-Id: Id958709f36f24ee1c9c375807e8146a9d1cc4259
LGTM… provided we add a couple of tests. :-)
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 02/23] gnu: linux-container: Make it more suitable for derivation-building.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
2024-04-21 9:42 ` [bug#70494] [PATCH 01/23] store: database: Register derivation outputs Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-07 14:28 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 03/23] syscalls: Add missing pieces for derivation build environment Christopher Baines
` (20 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494; +Cc: Christopher Baines
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
* gnu/build/linux-container.scm (mount-file-systems): First remount all
filesystems in the current mount namespace as private (by mounting / with
MS_PRIVATE and MS_REC), so that the set of mounts cannot increase except from
within the container. Also, the tmpfs mounted over the chroot directory now
inherits the chroot directory's permissions (p11-kit, for example, has a test
that assumes that the root directory is not writable for the current user, and
tmpfs is by default 1777 when created).
* guix/build/syscalls.scm (MS_PRIVATE, MS_REC): new variables.
Signed-off-by: Christopher Baines <mail@cbaines.net>
Change-Id: Ie26e3ac4a12bbf9087180c56ab775a0f75c40100
---
gnu/build/linux-container.scm | 9 ++++++++-
guix/build/syscalls.scm | 3 +++
2 files changed, 11 insertions(+), 1 deletion(-)
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index dee6885400..2e4e0d3bf3 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -99,7 +99,14 @@ (define* (mount-file-systems root mounts #:key mount-/sys? mount-/proc?)
;; The container's file system is completely ephemeral, sans directories
;; bind-mounted from the host.
- (mount "none" root "tmpfs")
+ ;; Make this private in the container namespace so everything mounted under
+ ;; it is local to this namespace.
+ (mount "none" "/" "none" (logior MS_REC MS_PRIVATE))
+ (let ((current-perms (stat:perms (stat root))))
+ (mount "none" root "tmpfs" 0 (string-append "mode="
+ (number->string current-perms
+ 8))))
+
;; A proc mount requires a new pid namespace.
(when mount-/proc?
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 39bcffd516..92f2bb21fc 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -54,6 +54,8 @@ (define-module (guix build syscalls)
MS_REC
MS_SHARED
MS_LAZYTIME
+ MS_PRIVATE
+ MS_REC
MNT_FORCE
MNT_DETACH
MNT_EXPIRE
@@ -551,6 +553,7 @@ (define MS_MOVE 8192)
(define MS_REC 16384)
(define MS_SHARED 1048576)
(define MS_RELATIME 2097152)
+(define MS_PRIVATE 262144)
(define MS_STRICTATIME 16777216)
(define MS_LAZYTIME 33554432)
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 02/23] gnu: linux-container: Make it more suitable for derivation-building.
2024-04-21 9:42 ` [bug#70494] [PATCH 02/23] gnu: linux-container: Make it more suitable for derivation-building Christopher Baines
@ 2024-05-07 14:28 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-07 14:28 UTC (permalink / raw)
To: Christopher Baines; +Cc: 70494
Christopher Baines <mail@cbaines.net> skribis:
> From: Caleb Ristvedt <caleb.ristvedt@cune.org>
>
> * gnu/build/linux-container.scm (mount-file-systems): First remount all
> filesystems in the current mount namespace as private (by mounting / with
> MS_PRIVATE and MS_REC), so that the set of mounts cannot increase except from
> within the container. Also, the tmpfs mounted over the chroot directory now
> inherits the chroot directory's permissions (p11-kit, for example, has a test
> that assumes that the root directory is not writable for the current user, and
> tmpfs is by default 1777 when created).
> * guix/build/syscalls.scm (MS_PRIVATE, MS_REC): new variables.
LGTM (though the log seems to describe more than the changes?).
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 03/23] syscalls: Add missing pieces for derivation build environment.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
2024-04-21 9:42 ` [bug#70494] [PATCH 01/23] store: database: Register derivation outputs Christopher Baines
2024-04-21 9:42 ` [bug#70494] [PATCH 02/23] gnu: linux-container: Make it more suitable for derivation-building Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-07 14:27 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 04/23] guix: store: environment: New module Christopher Baines
` (19 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494; +Cc: Christopher Baines
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
* guix/build/syscalls.scm (ADDR_NO_RANDOMIZE, UNAME26, PER_LINUX32): New
variables. Flags needed for improving determinism / impersonating a 32-bit
machine on a 64-bit machine.
(initialize-loopback, setdomainname, personality): New procedures.
(octal-escaped): New procedure.
(mount-points): Use octal-escaped to properly handle unusual characters in
mount point filenames.
Signed-off-by: Christopher Baines <mail@cbaines.net>
Change-Id: I2f2aa38fe8f97f2565461d20331b95040a2d7539
---
guix/build/syscalls.scm | 45 ++++++++++++++++++++++++++++++++++++++++-
1 file changed, 44 insertions(+), 1 deletion(-)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 92f2bb21fc..487ee68b43 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -162,6 +162,7 @@ (define-module (guix build syscalls)
configure-network-interface
add-network-route/gateway
delete-network-route
+ initialize-loopback
interface?
interface-name
@@ -212,7 +213,12 @@ (define-module (guix build syscalls)
utmpx-address
login-type
utmpx-entries
- (read-utmpx-from-port . read-utmpx)))
+ (read-utmpx-from-port . read-utmpx)
+ personality
+ ADDR_NO_RANDOMIZE
+ setdomainname
+ UNAME26
+ PER_LINUX32))
;;; Commentary:
;;;
@@ -1952,6 +1958,16 @@ (define* (set-network-interface-up name
(lambda ()
(close-port sock)))))
+(define (initialize-loopback)
+ (let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_IP)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (set-network-interface-flags sock "lo"
+ (logior IFF_UP IFF_LOOPBACK IFF_RUNNING)))
+ (lambda ()
+ (close sock)))))
+
\f
;;;
;;; Network routes.
@@ -2523,4 +2539,31 @@ (define (read-utmpx-from-port port)
((? bytevector? bv)
(read-utmpx bv))))
+;; TODO: verify these constants are correct on platforms other than x86-64
+(define ADDR_NO_RANDOMIZE #x0040000)
+(define UNAME26 #x0020000)
+(define PER_LINUX32 #x0008)
+
+(define personality
+ (let ((proc (syscall->procedure int "personality" `(,unsigned-long))))
+ (lambda (persona)
+ (let-values (((ret err) (proc persona)))
+ (if (= -1 ret)
+ (throw 'system-error "personality" "~A"
+ (list (strerror err))
+ (list err))
+ ret)))))
+
+(define setdomainname
+ (let ((proc (syscall->procedure int "setdomainname" (list '* int))))
+ (lambda (domain-name)
+ (let-values (((ret err) (proc (string->pointer/utf-8 domain-name)
+ (bytevector-length (string->utf8
+ domain-name)))))
+ (if (= -1 ret)
+ (throw 'system-error "setdomainname" "~A"
+ (list (strerror err))
+ (list err))
+ ret)))))
+
;;; syscalls.scm ends here
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 03/23] syscalls: Add missing pieces for derivation build environment.
2024-04-21 9:42 ` [bug#70494] [PATCH 03/23] syscalls: Add missing pieces for derivation build environment Christopher Baines
@ 2024-05-07 14:27 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-07 14:27 UTC (permalink / raw)
To: Christopher Baines; +Cc: 70494
Hi!
(Starting to review this patch series, it might take a while…)
Christopher Baines <mail@cbaines.net> skribis:
> From: Caleb Ristvedt <caleb.ristvedt@cune.org>
>
> * guix/build/syscalls.scm (ADDR_NO_RANDOMIZE, UNAME26, PER_LINUX32): New
> variables. Flags needed for improving determinism / impersonating a 32-bit
> machine on a 64-bit machine.
> (initialize-loopback, setdomainname, personality): New procedures.
> (octal-escaped): New procedure.
> (mount-points): Use octal-escaped to properly handle unusual characters in
> mount point filenames.
>
> Signed-off-by: Christopher Baines <mail@cbaines.net>
> Change-Id: I2f2aa38fe8f97f2565461d20331b95040a2d7539
[...]
> +(define (initialize-loopback)
> + (let ((sock (socket PF_INET SOCK_DGRAM IPPROTO_IP)))
> + (dynamic-wind
> + (const #t)
> + (lambda ()
> + (set-network-interface-flags sock "lo"
> + (logior IFF_UP IFF_LOOPBACK IFF_RUNNING)))
> + (lambda ()
> + (close sock)))))
Rather ‘set-loopback-interface-up’, by analogy with
‘set-network-interface-up’. Also please add a docstring any maybe a
unit test, if possible.
> +;; TODO: verify these constants are correct on platforms other than x86-64
> +(define ADDR_NO_RANDOMIZE #x0040000)
> +(define UNAME26 #x0020000)
> +(define PER_LINUX32 #x0008)
> +
> +(define personality
> + (let ((proc (syscall->procedure int "personality" `(,unsigned-long))))
> + (lambda (persona)
> + (let-values (((ret err) (proc persona)))
> + (if (= -1 ret)
> + (throw 'system-error "personality" "~A"
> + (list (strerror err))
> + (list err))
> + ret)))))
Please add a docstring and basic unit test.
> +(define setdomainname
> + (let ((proc (syscall->procedure int "setdomainname" (list '* int))))
> + (lambda (domain-name)
> + (let-values (((ret err) (proc (string->pointer/utf-8 domain-name)
> + (bytevector-length (string->utf8
> + domain-name)))))
> + (if (= -1 ret)
> + (throw 'system-error "setdomainname" "~A"
> + (list (strerror err))
> + (list err))
> + ret)))))
Ditto.
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 04/23] guix: store: environment: New module.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (2 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 03/23] syscalls: Add missing pieces for derivation build environment Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-13 15:10 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 05/23] store: build-derivations: " Christopher Baines
` (18 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Christopher Baines, Josselin Poiret,
Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
Simon Tournier, Tobias Geerinckx-Rice
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
* guix/store/environment.scm: New file.
* guix/store.scm: Export compressed-hash.
* guix/store/database.scm (output-path-id-sql, outputs-exist?, references-sql,
file-closure, all-input-output-paths, all-transitive-inputs): New variables.
(outputs-exist?, file-closure, all-transitive-inputs): Export procedures.
* Makefile.am (STORE_MODULES): Add guix/store/environment.scm.
Co-authored-by: Christopher Baines <mail@cbaines.net>
Change-Id: I71ac38fa8596a0c05b34880ca60e8a27ef3892d8
---
Makefile.am | 3 +-
guix/store.scm | 1 +
guix/store/database.scm | 88 ++++++-
guix/store/environment.scm | 484 +++++++++++++++++++++++++++++++++++++
4 files changed, 574 insertions(+), 2 deletions(-)
create mode 100644 guix/store/environment.scm
diff --git a/Makefile.am b/Makefile.am
index 27d76173e5..667f85acc1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -409,7 +409,8 @@ endif BUILD_DAEMON_OFFLOAD
STORE_MODULES = \
guix/store/database.scm \
guix/store/deduplication.scm \
- guix/store/roots.scm
+ guix/store/roots.scm \
+ guix/store/environment.scm
MODULES += $(STORE_MODULES)
diff --git a/guix/store.scm b/guix/store.scm
index a238cb627a..c3b58090e5 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -192,6 +192,7 @@ (define-module (guix store)
grafting?
%store-prefix
+ compressed-hash
store-path
output-path
fixed-output-path
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 6a9acc2aef..07bd501644 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -38,6 +38,8 @@ (define-module (guix store database)
#:use-module (srfi srfi-26)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (system foreign)
#:export (sql-schema
%default-database-file
store-database-file
@@ -52,7 +54,10 @@ (define-module (guix store database)
registered-derivation-outputs
%epoch
reset-timestamps
- vacuum-database))
+ vacuum-database
+ outputs-exist?
+ file-closure
+ all-transitive-inputs))
;;; Code for working with the store database directly.
@@ -441,3 +446,84 @@ (define (vacuum-database)
(let ((db (sqlite-open (store-database-file))))
(sqlite-exec db "VACUUM;")
(sqlite-close db)))
+
+(define (outputs-exist? db drv-path outputs)
+ "Determine whether all output labels in OUTPUTS exist as built outputs of
+DRV-PATH."
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT id
+FROM ValidPaths
+WHERE path IN (
+ SELECT path
+ FROM DerivationOutputs
+ WHERE DerivationOutputs.id = :id
+ AND drv IN (
+ SELECT id FROM ValidPaths WHERE path = :drvpath
+ )
+)"
+ #:cache? #t)))
+ (sqlite-bind-arguments statement #:drvpath drv-path)
+
+ (every (lambda (out-id)
+ (sqlite-bind-arguments statement #:id out-id)
+ (sqlite-step-and-reset statement))
+ outputs)))
+
+(define* (file-closure db path #:key (list-so-far vlist-null))
+ "Return a vlist containing the store paths referenced by PATH, the store
+paths referenced by those paths, and so on."
+ (let ((get-references
+ (sqlite-prepare
+ db
+ "
+SELECT path
+FROM ValidPaths
+WHERE id IN (
+ SELECT reference FROM Refs WHERE referrer IN (
+ SELECT id FROM ValidPaths WHERE path = :path
+ )
+)"
+ #:cache? #t)))
+ ;; to make it possible to go depth-first we need to get all the
+ ;; references of an item first or we'll have re-entrancy issues with
+ ;; the get-references statement.
+ (define (references-of path)
+ ;; There are no problems with resetting an already-reset
+ ;; statement.
+ (sqlite-bind-arguments get-references #:path path)
+ (let ((result
+ (sqlite-fold (lambda (row prev)
+ (cons (vector-ref row 0) prev))
+ '()
+ get-references)))
+ (sqlite-reset get-references)
+ result))
+
+ (let %file-closure ((path path)
+ (references-vlist list-so-far))
+ (if (vhash-assoc path references-vlist)
+ references-vlist
+ (fold %file-closure
+ (vhash-cons path #t references-vlist)
+ (references-of path))))))
+
+(define (all-input-output-paths drv)
+ "Return a list containing the output paths this derivation's inputs need to
+provide."
+ (apply append (map derivation-input-output-paths
+ (derivation-inputs drv))))
+
+(define (all-transitive-inputs db drv)
+ "Produce a list of all inputs and all of their references."
+ (let ((input-paths (all-input-output-paths drv)))
+ (vhash-fold (lambda (key val prev)
+ (cons key prev))
+ '()
+ (fold (lambda (input list-so-far)
+ (file-closure db input #:list-so-far list-so-far))
+ vlist-null
+ `(,@(derivation-sources drv)
+ ,@input-paths)))))
diff --git a/guix/store/environment.scm b/guix/store/environment.scm
new file mode 100644
index 0000000000..b088408ef9
--- /dev/null
+++ b/guix/store/environment.scm
@@ -0,0 +1,484 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;;
+;;; 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/>.
+
+;;; Code for setting up environments, especially build environments. Builds
+;;; on top of (gnu build linux-container).
+
+(define-module (guix store environment)
+ #:use-module (guix records)
+ #:use-module (guix config)
+ #:use-module (gnu build linux-container)
+ #:use-module (gnu system file-systems)
+ #:use-module ((guix build utils) #:select (delete-file-recursively
+ mkdir-p
+ copy-recursively))
+ #:use-module (guix derivations)
+ #:use-module (guix store)
+ #:use-module (guix build syscalls)
+ #:use-module (guix store database)
+ #:use-module (gcrypt hash)
+ #:use-module (guix base32)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-98)
+
+ #:export (<environment>
+ environment
+ environment-namespaces
+ environment-variables
+ environment-temp-dirs
+ environment-filesystems
+ environment-new-session?
+ environment-new-pgroup?
+ environment-setup-i/o-proc
+ environment-preserved-fds
+ environment-chroot
+ environment-personality
+ environment-user
+ environment-group
+ environment-hostname
+ environment-domainname
+ build-environment-vars
+ delete-environment
+ run-in-environment
+ bind-mount
+ standard-i/o-setup
+ %standard-preserved-fds
+ nonchroot-build-environment
+ chroot-build-environment
+ builtin-builder-environment
+ run-standard
+ run-standard-build
+ wait-for-build))
+
+(define %standard-preserved-fds '(0 1 2))
+
+(define-record-type* <environment> environment
+ ;; The defaults are set to be as close to the "current environment" as
+ ;; possible.
+ make-environment
+ environment?
+ (namespaces environment-namespaces (default '())) ; list of symbols
+ ; list of (key . val) pairs
+ (variables environment-variables (default (get-environment-variables)))
+ ; list of (symbol . filename) pairs.
+ (temp-dirs environment-temp-dirs (default '()))
+ ;; list of <file-system> objects. Only used when MNT is in NAMESPACES.
+ (filesystems environment-filesystems (default '()))
+ ; boolean (implies NEW-PGROUP?)
+ (new-session? environment-new-session? (default #f))
+ (new-pgroup? environment-new-pgroup? (default #f)) ; boolean
+ (setup-i/o environment-setup-i/o-proc) ; a thunk or #f
+ ; #f or list of integers (in case of #f, all are preserved)
+ (preserved-fds environment-preserved-fds (default #f))
+ ;; either the chroot directory or #f, must not be #f if MNT is in
+ ;; NAMESPACES! Will be recursively deleted when the environment is
+ ;; destroyed. Ignored if MNT is not in NAMESPACES.
+ (chroot environment-chroot (default #f))
+ (initial-directory environment-initial-directory (default #f)) ; string or #f
+ (personality environment-personality (default #f)) ; integer or #f
+ ;; These are currently naively handled in the case of user namespaces.
+ (user environment-user (default #f)) ; integer or #f
+ (group environment-group (default #f)) ; integer or #f
+ (hostname environment-hostname (default #f)) ; string or #f
+ (domainname environment-domainname (default #f))) ; string or #f
+
+(define (delete-environment env)
+ "Delete all temporary directories used in ENV."
+ (for-each (match-lambda
+ ((id . filename)
+ (delete-file-recursively filename)))
+ (environment-temp-dirs env))
+ (when (environment-chroot env)
+ (delete-file-recursively (environment-chroot env))))
+
+(define (format-file file-name . args)
+ (call-with-output-file file-name
+ (lambda (port)
+ (apply simple-format port args))))
+
+(define* (mkdir-p* dir #:optional permissions)
+ (mkdir-p dir)
+ (when permissions
+ (chmod dir permissions)))
+
+(define (add-core-files environment fixed-output?)
+ "Populate container with miscellaneous files and directories that shouldn't
+be bind-mounted."
+ (let ((uid (environment-user environment))
+ (gid (environment-group environment)))
+ (mkdir-p* "/tmp" #o1777)
+ (mkdir-p* "/etc")
+
+ (unless (or (file-exists? "/etc/passwd")
+ (file-exists? "/etc/group"))
+ (format-file "/etc/passwd"
+ (string-append "nixbld:x:~a:~a:Nix build user:/:/noshell~%"
+ "nobody:x:65534:65534:Nobody:/:/noshell~%")
+ uid gid)
+ (format-file "/etc/group" "nixbld:!:~a:~%" gid))
+
+ (unless (or fixed-output? (file-exists? "/etc/hosts"))
+ (format-file "/etc/hosts" "127.0.0.1 localhost~%"))
+ (when (file-exists? "/dev/pts/ptmx")
+ (chmod "/dev/pts/ptmx" #o0666))))
+
+(define (run-in-environment env thunk . i/o-args)
+ "Run THUNK in ENV with I/O-ARGS passed to the SETUP-I/O procedure of
+ENV. Return the pid of the process THUNK is run in."
+ (match env
+ (($ <environment> namespaces variables temp-dirs
+ filesystems new-session? new-pgroup? setup-i/o
+ preserved-fds chroot current-directory new-personality
+ user group hostname domainname)
+ (when (and new-session? (not new-pgroup?))
+ (throw 'invalid-environment "NEW-SESSION? implies NEW-PGROUP?."))
+ (let ((fixed-output? (not (memq 'net namespaces))))
+ (run-container chroot filesystems namespaces (and user (1+ user))
+ (lambda ()
+ (when hostname (sethostname hostname))
+ (when domainname (setdomainname domainname))
+ ;; setsid / setpgrp as necessary
+ (if new-session?
+ (setsid)
+ (when new-pgroup?
+ (setpgid 0 0)))
+ (when chroot
+ (add-core-files env fixed-output?))
+ ;; set environment variables
+ (when variables
+ (environ (map (match-lambda
+ ((key . val)
+ (string-append key "=" val)))
+ variables)))
+ (when setup-i/o (apply setup-i/o i/o-args))
+ ;; set UID and GID
+ (when current-directory (chdir current-directory))
+ (when group (setgid group))
+ (when user (setuid user))
+ ;; Close unpreserved fds
+ (when preserved-fds
+ (let close-next ((n 0))
+ (when (< n 20) ;; XXX: don't hardcode.
+ (unless (memq n preserved-fds)
+ (false-if-exception (close-fdes n)))
+ (close-next (1+ n)))))
+
+ ;; enact personality
+ (when new-personality (personality new-personality))
+ (thunk)))))))
+
+(define (bind-mount src dest)
+ "Return a <file-system> denoting the bind-mounting of SRC to DEST. Note that
+if this is part of a chroot <environment>, DEST will be the name *inside of*
+the chroot, i.e.
+
+(bind-mount \"/foo/x\" \"/bar/x\")
+
+in an environment with chroot \"/chrootdir\" will bind-mount \"/foo/x\" to
+\"/chrootdir/bar/x\"."
+ (file-system
+ (device src)
+ (mount-point dest)
+ (type "none")
+ (flags '(bind-mount))
+ (check? #f)))
+
+(define input->mount
+ (match-lambda
+ ((source . dest)
+ (bind-mount source dest))
+ (source
+ (bind-mount source source))))
+
+(define (default-files drv)
+ "Return a list of the files to be bind-mounted that aren't store items or
+already added by call-with-container."
+ `(,@(if (file-exists? "/dev/kvm")
+ '("/dev/kvm")
+ '())
+ ,@(if (fixed-output-derivation? drv)
+ '("/etc/resolv.conf"
+ "/etc/nsswitch.conf"
+ "/etc/services"
+ "/etc/hosts")
+ '())))
+
+(define (build-environment-vars drv build-dir)
+ "Return an alist of environment variable / value pairs for every environment
+variable that should be set during the build execution."
+ (let ((leaked-vars (and
+ (fixed-output-derivation? drv)
+ (let ((leak-string
+ (assoc-ref (derivation-builder-environment-vars drv)
+ "impureEnvVars")))
+ (and leak-string
+ (string-tokenize leak-string
+ (char-set-complement
+ (char-set #\space))))))))
+ (append `(("PATH" . "/path-not-set")
+ ("HOME" . "/homeless-shelter")
+ ("NIX_STORE" . ,%store-directory)
+ ;; XXX: make this configurable
+ ("NIX_BUILD_CORES" . "0")
+ ("NIX_BUILD_TOP" . ,build-dir)
+ ("TMPDIR" . ,build-dir)
+ ("TEMPDIR" . ,build-dir)
+ ("TMP" . ,build-dir)
+ ("TEMP" . ,build-dir)
+ ("PWD" . ,build-dir))
+ (if (fixed-output-derivation? drv)
+ (cons '("NIX_OUTPUT_CHECKED" . "1")
+ (if leaked-vars
+ ;; leaked vars might be #f
+ (filter cdr
+ (map (lambda (leaked-var)
+ (cons leaked-var (getenv leaked-var)))
+ leaked-vars))
+ '()))
+ '())
+ (derivation-builder-environment-vars drv))))
+
+(define* (temp-directory tmpdir name #:optional permissions user group)
+ "Create a temporary directory under TMPDIR with permissions PERMISSIONS if
+specified, otherwise default permissions as specified by umask, and belonging
+to user USER and group GROUP (defaulting to current user if not specified or
+#f). Return the full filename of the form <tmpdir>/<name>-<number>."
+ (let try-again ((attempt-number 0))
+ (catch 'system-error
+ (lambda ()
+ (let ((attempt-name (string-append tmpdir "/" name "-"
+ (number->string
+ attempt-number 10))))
+ (mkdir attempt-name permissions)
+ (when permissions
+ ;; the only guarantee we get from mkdir is that the actual
+ ;; permissions are no more permissive than what we specified. In
+ ;; the event we want to be more permissive than the umask, though,
+ ;; this is necessary.
+ (chmod attempt-name permissions))
+ ;; -1 means "unchanged"
+ (chown attempt-name (or user -1) (or group -1))
+ attempt-name))
+ (lambda args
+ (if (= (system-error-errno args) EEXIST)
+ (try-again (+ attempt-number 1))
+ (apply throw args))))))
+
+(define (special-filesystems input-paths)
+ "Return whatever new filesystems need to be created in the container, which
+depends on whether they're already set to be bind-mounted. INPUT-PATHS must
+be a list of paths or pairs of paths."
+ ;; procfs and devpts are already taken care of by run-container
+ `(,@(if (file-exists? "/dev/shm")
+ (list (file-system
+ (device "none")
+ (mount-point "/dev/shm")
+ (type "tmpfs")
+ (check? #f)))
+ '())))
+
+(define (standard-i/o-setup output-port)
+ "Redirect output and error streams to OUTPUT-FD, get input from /dev/null."
+ (define output-fd (port->fdes output-port))
+ (define stdout (fdopen 1 "w"))
+ ;; Useful in case an error happens between here and an exec and it needs to
+ ;; get reported.
+ (set-current-output-port stdout)
+ (set-current-error-port stdout)
+ (dup2 output-fd 1)
+ (dup2 output-fd 2)
+ (call-with-input-file "/dev/null"
+ (lambda (null-port)
+ (dup2 (port->fdes null-port) 0)))
+ (sigaction SIGPIPE SIG_DFL))
+
+
+
+(define (derivation-tempname drv)
+ (string-append "guix-build-"
+ (store-path-package-name (derivation-file-name drv))))
+
+;; We might want to add to this sometime.
+(define %default-chroot-dirs
+ '())
+
+(define* (default-personality drv #:key impersonate-linux-2.6?)
+ (let ((current-personality (personality #xffffffff)))
+ (logior current-personality ADDR_NO_RANDOMIZE
+ (match (cons %system (derivation-system drv))
+ ((or ("x86_64-linux" . "i686-linux")
+ ("aarch64-linux" . "armhf-linux"))
+ PER_LINUX32)
+ (_ 0))
+ (match (cons (derivation-system drv) impersonate-linux-2.6?)
+ (((or "x86_64-linux" "i686-linux") . #t)
+ UNAME26)
+ (_ 0)))))
+
+(define* (make-build-directory drv #:optional uid gid)
+ (let ((build-directory (temp-directory (or (getenv "TMPDIR")
+ "/tmp")
+ (derivation-tempname drv) #o0700
+ uid gid)))
+ ;; XXX: Honor exportReferencesGraph here...
+ build-directory))
+
+(define* (nonchroot-build-environment drv #:key gid uid)
+ "Create and return an <environment> for building DRV outside of a chroot, as
+well as the store inputs the build requires."
+ (let* ((fixed-output? (fixed-output-derivation? drv))
+ (build-directory (make-build-directory drv)))
+ (environment
+ (temp-dirs `((build-directory . ,build-directory)))
+ (initial-directory build-directory)
+ (new-session? #t)
+ (new-pgroup? #t)
+ (variables (build-environment-vars drv build-directory))
+ (preserved-fds %standard-preserved-fds)
+ (setup-i/o standard-i/o-setup)
+ (personality (default-personality drv))
+ (user uid)
+ (group gid))))
+
+(define* (builtin-builder-environment drv #:key gid uid)
+ "Create and return an <environment> for builtin builders, as well as the
+store inputs the build requires."
+ ;; It's just the same as non-chroot-build-environment, but without any
+ ;; environment variables being changed.
+ (let ((env (nonchroot-build-environment drv
+ #:gid gid
+ #:uid uid)))
+ (environment (inherit env)
+ (variables (get-environment-variables)))))
+
+(define* (chroot-build-environment drv #:key gid uid
+ (extra-chroot-dirs '())
+ build-chroot-dirs
+ (tmpdir (or (getenv "TMPDIR")
+ "/tmp")))
+ "Create an <environment> for building DRV with standard in-chroot
+settings (as used by nix daemon). Return said environment as well as the
+store paths that are included in it (useful for reference scanning)."
+ (let* ((tempname (derivation-tempname drv))
+ (store-directory (temp-directory tmpdir
+ (string-append tempname ".store")
+ #o1775 0 gid))
+ (build-directory (make-build-directory drv uid gid))
+ (inside-build-dir (string-append tmpdir "/" tempname "-0"))
+ (fixed-output? (fixed-output-derivation? drv))
+ (input-paths (append (default-files drv)
+ (or build-chroot-dirs
+ %default-chroot-dirs)
+ extra-chroot-dirs)))
+ (environment
+ (namespaces `(mnt pid ipc uts ,@(if fixed-output? '() '(net))))
+ (filesystems
+ (cons* (bind-mount build-directory inside-build-dir)
+ (bind-mount store-directory %store-directory)
+ (append (special-filesystems input-paths)
+ (map input->mount input-paths))))
+ (temp-dirs `((store-directory . ,store-directory)
+ (build-directory . ,build-directory)))
+ (initial-directory inside-build-dir)
+ (new-session? #t)
+ (new-pgroup? #t)
+ (setup-i/o (lambda (output-fd)
+ (unless fixed-output?
+ (initialize-loopback))
+ (standard-i/o-setup output-fd)))
+ (variables (build-environment-vars drv inside-build-dir))
+ (preserved-fds %standard-preserved-fds)
+ (chroot (temp-directory tmpdir (string-append tempname ".chroot")
+ #o750 0 gid))
+ (user uid)
+ (group gid)
+ (personality (default-personality drv))
+ (hostname "localhost")
+ (domainname "(none)"))))
+
+(define (redirected-path drv output)
+ (let* ((original (derivation-output-path (assoc-ref (derivation-outputs drv)
+ output)))
+ (hash
+ (bytevector->nix-base32-string
+ (compressed-hash (sha256 (string-append "rewrite:"
+ (derivation-file-name drv)
+ ":"
+ original))
+ 20))))
+ (string-append (%store-prefix) "/" hash "-"
+ (store-path-package-name original))))
+
+(define (redirect-outputs env drv output-names)
+ "Create a new <environment> based on ENV but modified so that for each
+output-name in OUTPUT-NAMES, the environment variable corresponding to that
+output is set to a newly-generated output path."
+ (environment (inherit env)
+ (variables (append (map (lambda (output)
+ (cons output (redirected-path drv output)))
+ output-names)
+ (remove (lambda (var)
+ (member (car var) output-names))
+ (environment-variables env))))))
+
+(define (run-standard environment thunk)
+ "Run THUNK in ENVIRONMENT. Return the PID it is being run in and the read
+end of the pipe its i/o has been set up with."
+ (match (pipe)
+ ((read . write)
+ (let ((pid (run-in-environment environment
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (thunk)
+ (primitive-exit 0))
+ (lambda args
+ (format #t "Error: ~A~%" args)
+ (primitive-exit 1))))
+ write)))
+ (close-fdes (port->fdes write))
+ (values pid read)))))
+
+(define (run-standard-build drv environment)
+ "Run the builder of DRV in ENVIRONMENT. Return the PID it is being run in
+and the read end of the pipe its i/o has been set up with."
+ (run-standard environment
+ (lambda ()
+ (let ((prog (derivation-builder drv))
+ (args (derivation-builder-arguments drv)))
+ (apply execl prog prog args)))))
+
+(define* (dump-port port #:optional (target-port (current-output-port)))
+ (if (port-eof? port)
+ (force-output target-port)
+ (begin
+ (put-bytevector target-port (get-bytevector-some port))
+ (dump-port port target-port))))
+
+(define (wait-for-build pid read-port)
+ "Dump all input from READ-PORT to (current-output-port), then wait for PID
+to terminate."
+ (dump-port read-port)
+ (close-fdes (port->fdes read-port))
+ ;; Should we wait specifically for PID to die, or just for any state change?
+ (cdr (waitpid pid)))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 04/23] guix: store: environment: New module.
2024-04-21 9:42 ` [bug#70494] [PATCH 04/23] guix: store: environment: New module Christopher Baines
@ 2024-05-13 15:10 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-13 15:10 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Hi Chris,
Christopher Baines <mail@cbaines.net> skribis:
> From: Caleb Ristvedt <caleb.ristvedt@cune.org>
>
> * guix/store/environment.scm: New file.
> * guix/store.scm: Export compressed-hash.
> * guix/store/database.scm (output-path-id-sql, outputs-exist?, references-sql,
> file-closure, all-input-output-paths, all-transitive-inputs): New variables.
> (outputs-exist?, file-closure, all-transitive-inputs): Export procedures.
> * Makefile.am (STORE_MODULES): Add guix/store/environment.scm.
>
> Co-authored-by: Christopher Baines <mail@cbaines.net>
> Change-Id: I71ac38fa8596a0c05b34880ca60e8a27ef3892d8
Very cool. Some comments:
> +++ b/guix/store.scm
> @@ -192,6 +192,7 @@ (define-module (guix store)
> grafting?
>
> %store-prefix
> + compressed-hash
> store-path
> output-path
> fixed-output-path
We can keep it this way for now.
However, the suggestion I made to reepca back then was that we should
move the low-level hashing/file name computation procedures to a
separate module, say (guix store file-names), such that daemon code does
not import (guix store).
(guix store) would only contain client-side code, possibly re-exporting
some of (guix store file-names) for compatibility and convenience.
> +(define* (file-closure db path #:key (list-so-far vlist-null))
> + "Return a vlist containing the store paths referenced by PATH, the store
> +paths referenced by those paths, and so on."
s/file-closure/store-item-closure/ ?
> +(define (all-input-output-paths drv)
> + "Return a list containing the output paths this derivation's inputs need to
> +provide."
> + (apply append (map derivation-input-output-paths
Use ‘append-map’ instead.
> + #:export (<environment>
Don’t export record type descriptors in general as this exposes the ABI.
> + environment-namespaces
> + environment-variables
> + environment-temp-dirs
s/temp-dirs/temporary-directories/
> + environment-filesystems
> + environment-new-session?
> + environment-new-pgroup?
> + environment-setup-i/o-proc
> + environment-preserved-fds
> + environment-chroot
> + environment-personality
> + environment-user
> + environment-group
> + environment-hostname
> + environment-domainname
I’d write “file-systems”, “host-name”, and “domain-name”, to be
consistent with the rest of the code base (we can keep “namespaces”
because that’s how Linux spells it.)
> + build-environment-vars
s/vars/variables/
> +(define-record-type* <environment> environment
We should keep in mind that maybe we’ll want to use that in ‘guix shell
-C’ eventually.
> +(define (delete-environment env)
> + "Delete all temporary directories used in ENV."
s/delete-environment/delete-temporary-directories/
> +(define* (temp-directory tmpdir name #:optional permissions user group)
> + "Create a temporary directory under TMPDIR with permissions PERMISSIONS if
> +specified, otherwise default permissions as specified by umask, and belonging
> +to user USER and group GROUP (defaulting to current user if not specified or
> +#f). Return the full filename of the form <tmpdir>/<name>-<number>."
s/temp-directory/create-temporary-directory/
This procedure missed the fix in commit
ec7fb669945bfb47c5e1fdf7de3a5d07f7002ccf (CVE-2021-27851). It’s fine to
implement it later but we should at least leave a big FIXME comment.
Somewhere we’ll also need the fix for CVE-2024-27297 (commits
ff1251de0bc327ec478fc66a562430fbf35aef42 and
8f4ffb3fae133bb21d7991e97c2f19a7108b1143).
> +(define* (dump-port port #:optional (target-port (current-output-port)))
Use the one from (guix build utils) instead.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 05/23] store: build-derivations: New module.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (3 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 04/23] guix: store: environment: New module Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-13 15:22 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 06/23] store: Export protocol related constants Christopher Baines
` (17 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Christopher Baines, Josselin Poiret,
Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
Simon Tournier, Tobias Geerinckx-Rice
From: Caleb Ristvedt <caleb.ristvedt@cune.org>
* guix/store/build-derivations.scm (get-output-specs, builtin-download,
add-to-trie, make-search-trie, remove-from-trie!, scanning-wrapper-port,
scan-for-references, ensure-input-outputs-exist, build-derivation): New
procedures.
(builtins): New variable.
(<trie-node>): New record types.
* Makefile.am (STORE_MODULES): Add it.
Co-authored-by: Christopher Baines <mail@cbaines.net>
Change-Id: I904b75e3c58c5fb996c0c9d1ca19b2cb2beb90b6
---
Makefile.am | 3 +-
guix/store/build-derivations.scm | 412 +++++++++++++++++++++++++++++++
2 files changed, 414 insertions(+), 1 deletion(-)
create mode 100644 guix/store/build-derivations.scm
diff --git a/Makefile.am b/Makefile.am
index 667f85acc1..c926506b01 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -410,7 +410,8 @@ STORE_MODULES = \
guix/store/database.scm \
guix/store/deduplication.scm \
guix/store/roots.scm \
- guix/store/environment.scm
+ guix/store/environment.scm \
+ guix/store/build-derivations.scm
MODULES += $(STORE_MODULES)
diff --git a/guix/store/build-derivations.scm b/guix/store/build-derivations.scm
new file mode 100644
index 0000000000..d77769528f
--- /dev/null
+++ b/guix/store/build-derivations.scm
@@ -0,0 +1,412 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;;
+;;; 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/>.
+
+;;; For building derivations.
+
+(define-module (guix store build-derivations)
+ #:use-module (guix derivations)
+ #:use-module (guix store database)
+ #:use-module (guix config)
+ #:use-module (guix build syscalls)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 popen)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
+ #:use-module (gcrypt hash)
+ #:use-module (guix serialization)
+ #:use-module (guix base16)
+ #:use-module (guix sets)
+ #:use-module ((guix build utils) #:select (delete-file-recursively
+ mkdir-p
+ copy-recursively))
+ #:use-module ((guix store) #:select (store-path-hash-part))
+ #:use-module (guix build store-copy)
+ #:use-module (gnu system file-systems)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 q)
+ #:use-module (srfi srfi-43)
+ #:use-module (rnrs bytevectors)
+ #:use-module (guix store environment)
+ #:export (builder+environment+inputs
+ build-derivation))
+
+(define (output-paths drv)
+ "Return all store output paths produced by DRV."
+ (match (derivation-outputs drv)
+ (((outid . ($ <derivation-output> output-path)) ...)
+ output-path)))
+
+(define (get-output-specs drv possible-references)
+ "Return a list of <store-info> objects, one for each output of DRV."
+ (map (match-lambda
+ ((outid . ($ <derivation-output> output-path))
+ (let ((references
+ (scan-for-references output-path
+ ;; outputs can reference
+ ;; themselves or other outputs of
+ ;; the same derivation.
+ (append (output-paths drv)
+ possible-references))))
+ (store-info output-path (derivation-file-name drv) references))))
+ (derivation-outputs drv)))
+
+(define (builtin-download drv outputs)
+ "Download DRV outputs OUTPUTS into the store."
+ (setenv "NIX_STORE" %store-directory)
+ ;; XXX: Set _NIX_OPTIONS once client settings are known
+ (spawn "guix"
+ (list "guix perform-download"
+ "perform-download"
+ (derivation-file-name drv)
+ ;; We assume this has only a single output
+ (derivation-output-path (cdr (first outputs))))))
+
+;; if a derivation builder name is in here, it is a builtin. For normal
+;; behavior, make sure everything starts with "builtin:". Also, the procedures
+;; stored in here should take two arguments, the derivation and the list of
+;; (output-name . <derivation-output>)s to be built.
+
+(define builtins
+ (let ((builtins-table (make-hash-table 10)))
+ (hash-set! builtins-table
+ "builtin:download"
+ builtin-download)
+ builtins-table))
+
+(define %keep-build-dir? #t)
+
+;; XXX: make this configurable.
+(define %build-group
+ (make-parameter (false-if-exception (getgrnam "guixbuild"))))
+
+(define (get-build-user)
+ ;; XXX: user namespace to make build-user work instead of having to be root?
+ (or (and=> (%build-group)
+ ;; XXX: Acquire a user via lock files once those are properly
+ ;; implemented. For now, avoid conflict with the existing daemon
+ ;; where possible by picking a build user from the end (last)
+ ;; instead of the front.
+ ;; So in the future, replace LAST with ACQUIRE-BUILD-USER
+ (compose passwd:uid getpwnam last group:mem))
+ (getuid)))
+
+(define (get-build-group)
+ (or (and (zero? (getuid))
+ (group:gid (%build-group)))
+ (getgid)))
+
+(define-record-type <trie-node>
+ (make-trie-node table string-exists?)
+ trie-node?
+ ;; TODO implement skip values. Probably not as big a speed gain as you think
+ ;; it is, since this is I/O-bound.
+ ;; (skip-value node-skip-value set-skip-value!)
+ (table node-table set-node-table!)
+ ;; Technically speaking, it's possible for both CAT and CATTLE to be in a
+ ;; trie at once. Of course, for our purposes, this is
+ (string-exists? node-string-exists? set-string-exists?!))
+
+(define* (add-to-trie trie string #:optional (new-tables-size 2))
+ "Adds STR to TRIE."
+ (let ((str (string->utf8 string)))
+ (let next-node ((position 0)
+ (current-node trie))
+ (if (= position (bytevector-length str))
+ ;; this is it. This is where we need to register that this string is
+ ;; present.
+ (set-string-exists?! current-node #t)
+ (let* ((current-table (node-table current-node))
+ (node (hash-ref current-table
+ (bytevector-u8-ref str position))))
+ (if node
+ (next-node (1+ position)
+ node)
+ (let ((new-node (make-trie-node (make-hash-table new-tables-size)
+ #f)))
+ (hash-set! current-table
+ (bytevector-u8-ref str position)
+ new-node)
+ (next-node (1+ position)
+ new-node))))))))
+
+(define (make-search-trie strings)
+ ;; TODO: make the first few trie levels non-sparse tables to avoid hashing
+ ;; overhead.
+ (let ((root (make-trie-node (make-hash-table) #f)))
+ (for-each (cut add-to-trie root <>)
+ strings)
+ root))
+
+
+(define (remove-from-trie! trie sequence)
+ "Removes SEQUENCE from TRIE. This means that any nodes that are only in the
+path of SEQUENCE are removed. It's an error to use this with a sequence not
+already in TRIE."
+ ;; Hm. Looks like we'll have to recurse all the way down, find where it
+ ;; ends, then stop at the first thing on the way back up that has anything
+ ;; with the same prefix. Or I could do this the right way with an explicit
+ ;; stack. Hm...
+
+ (define (node-stack)
+ (let next ((nodes '())
+ (i 0)
+ (current-node trie))
+ (if (= (bytevector-length sequence) i)
+ (begin
+ ;; it's possible that even though this is the last node of this
+ ;; sequence it can't be deleted. So mark it as not denoting a
+ ;; string.
+ (set-string-exists?! current-node #f)
+ (cons current-node nodes))
+ (let ((next-node (hash-ref (node-table current-node)
+ (bytevector-u8-ref sequence i))))
+ (next (cons current-node nodes)
+ (1+ i)
+ next-node)))))
+
+ (let maybe-delete ((visited-nodes (node-stack))
+ (i (1- (bytevector-length sequence))))
+ (match visited-nodes
+ ((current parent others ...)
+ (when (zero? (hash-count (const #t)
+ (node-table current)))
+
+ (hash-remove! (node-table parent)
+ (bytevector-u8-ref sequence i))
+ (maybe-delete (cdr visited-nodes)
+ (1- i))))
+ ((current)
+ #f))))
+
+(define (scanning-wrapper-port output-port paths)
+ "Creates a wrapper port which passes through bytes to OUTPUT-PORT and
+returns it as well as a procedure which, when called, returns a list of all
+references out of the possibilities enumerated in PATHS that were
+detected. PATHS must not be empty."
+ ;; Not sure if I should be using custom ports or soft ports...
+ (let* ((strings (map store-path-hash-part paths))
+ (string->path (fold (lambda (current prev)
+ (vhash-cons (store-path-hash-part current)
+ current
+ prev))
+ vlist-null
+ paths))
+ (lookback-size (apply max (map (compose bytevector-length string->utf8)
+ strings)))
+ (smallest-length (apply min (map (compose bytevector-length
+ string->utf8)
+ strings)))
+ (lookback-buffer (make-bytevector lookback-size))
+ (search-trie (make-search-trie strings))
+ (buffer-pos 0)
+ (references '()))
+
+ (values
+ (make-custom-binary-output-port
+ "scanning-wrapper"
+ ;; write
+ (lambda (bytes offset count)
+ (define (in-lookback? n)
+ (< n buffer-pos))
+ ;; the "virtual" stuff provides a convenient interface that makes it
+ ;; look like we magically remember the end of the previous buffer.
+ (define (virtual-ref n)
+ (if (in-lookback? n)
+ (bytevector-u8-ref lookback-buffer n)
+ (bytevector-u8-ref bytes (+ (- n buffer-pos)
+ offset))))
+
+
+ (let ((total-length (+ buffer-pos count)))
+
+ (define (virtual-copy! start end target)
+ (let* ((copy-size (- end start)))
+ (let copy-next ((i 0))
+ (unless (= i copy-size)
+ (bytevector-u8-set! target
+ i
+ (virtual-ref (+ start i)))
+ (copy-next (1+ i))))
+ target))
+
+ ;; the gritty reality of that magic
+ (define (remember-end)
+ (let* ((copy-amount (min total-length
+ lookback-size))
+ (start (- total-length copy-amount))
+ (end total-length))
+ (virtual-copy! start end lookback-buffer)
+ (set! buffer-pos copy-amount)))
+
+ (define (attempt-match n trie)
+ (let test-position ((i n)
+ (current-node trie))
+ (if (node-string-exists? current-node)
+ ;; MATCH
+ (virtual-copy! n i (make-bytevector (- i n)))
+ (if (>= i total-length)
+ #f
+ (let ((next-node (hash-ref (node-table current-node)
+ (virtual-ref i))))
+ (if next-node
+ (test-position (1+ i)
+ next-node)
+ #f))))))
+
+
+
+ (define (scan)
+ (let next-char ((i 0))
+ (when (< i (- total-length smallest-length))
+ (let ((match-result (attempt-match i search-trie)))
+ (if match-result
+ (begin
+ (set! references
+ (let ((str-result
+ (cdr (vhash-assoc (utf8->string match-result)
+ string->path))))
+ (format #t "Found reference to: ~a~%" str-result)
+ (cons str-result
+ references)))
+ ;; We're not interested in multiple references, it'd
+ ;; just slow us down.
+ (remove-from-trie! search-trie match-result)
+ (next-char (+ i (bytevector-length match-result))))
+ (next-char (1+ i)))))))
+ (format #t "Scanning chunk of ~a bytes~%" count)
+ (scan)
+ (remember-end)
+ (put-bytevector output-port bytes offset count)
+ count))
+ #f ;; get-position
+ #f ;; set-position
+ (lambda ()
+ (close-port output-port)))
+ (lambda ()
+ references))))
+
+
+;; There are two main approaches we can use here: we can look for the entire
+;; store path of the form "/gnu/store/hashpart-name", which will yield no
+;; false positives and likely be faster due to being more quickly able to rule
+;; out sequences, and we can look for just hashpart, which will be faster to
+;; lookup and may both increase false positives and decrease false negatives
+;; as stuff that gets split up will likely still have the hash part all
+;; together, but adds a chance that 32 random base-32 characters could cause a
+;; false positive, but the chances of that are extremely slim, and an
+;; adversary couldn't really use that.
+(define (scan-for-references file possibilities)
+ "Scans for literal references in FILE as long as they happen to be in
+POSSIBILITIES. Returns the list of references found, the sha256 hash of the
+nar, and the length of the nar."
+ (let*-values (((scanning-port get-references)
+ (scanning-wrapper-port (%make-void-port "w") possibilities)))
+ (write-file file scanning-port)
+ (force-output scanning-port)
+ (get-references)))
+
+(define (copy-outputs drv environment)
+ "Copy output paths produced in ENVIRONMENT from building DRV to the store if
+a fake store was used."
+ (let ((store-dir (assoc-ref (environment-temp-dirs environment)
+ 'store-directory)))
+ (when store-dir
+ (for-each
+ (match-lambda
+ ((outid . ($ <derivation-output> output-path))
+ (copy-recursively
+ (string-append store-dir "/" (basename output-path)) output-path)))
+ (derivation-outputs drv)))))
+
+(define (run-builder builder drv environment store-inputs)
+ "Run the builder BUILDER for DRV in ENVIRONMENT, wait for it to finish, and
+return the list of <store-info>s corresponding to its outputs."
+ (match (status:exit-val (call-with-values
+ (lambda ()
+ (run-standard environment builder))
+ wait-for-build))
+ (0
+ ;; XXX: check that the output paths were produced.
+ (copy-outputs drv environment)
+ (delete-environment environment)
+ (get-output-specs drv store-inputs))
+ (exit-value
+ (format #t "Builder exited with status ~A~%" exit-value)
+ (if %keep-build-dir?
+ (format #t "Note: keeping build directories: ~A~%"
+ (match (environment-temp-dirs environment)
+ (((sym . dir) ...)
+ dir)))
+ (delete-environment environment))
+ #f)))
+
+(define* (builder+environment+inputs drv store-inputs #:key (chroot? #t))
+ "Return a thunk that performs the build action, the environment it should be
+run in, and the store inputs of that environment."
+ (let* ((builtin
+ (hash-ref builtins (derivation-builder drv)))
+ (environment
+ ((if builtin
+ builtin-builder-environment
+ (if chroot?
+ (lambda args
+ (apply chroot-build-environment
+ `(,@args #:extra-chroot-dirs ,store-inputs)))
+ nonchroot-build-environment))
+ drv #:gid (get-build-group) #:uid (get-build-user)))
+ (builder
+ (or
+ (and builtin (lambda ()
+ (builtin drv (derivation-outputs
+ drv))))
+ (lambda ()
+ (let ((prog (derivation-builder drv))
+ (args (derivation-builder-arguments drv)))
+ (apply execl prog prog args))))))
+ (values builder environment)))
+
+(define (build-derivation drv store-inputs)
+ "Given a <derivation> DRV, build the derivation unconditionally even if its
+outputs already exist."
+ ;; Make sure store permissions and ownership are intact (test-env creates a
+ ;; store with wrong permissions, for example).
+ (when (and (zero? (getuid)) (get-build-group))
+ (chown %store-directory 0 (get-build-group)))
+ (chmod %store-directory #o1775)
+ ;; Inputs need to exist regardless of how we're getting the outputs of this
+ ;; derivation.
+ (format #t "Starting build of derivation ~a~%~%" drv)
+ (let* ((builder
+ environment
+ (builder+environment+inputs drv
+ store-inputs
+ #:chroot? (zero? (getuid))))
+ (output-specs
+ (run-builder builder drv environment store-inputs)))
+
+ (unless output-specs
+ (throw 'derivation-build-failed drv))
+
+ output-specs))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 05/23] store: build-derivations: New module.
2024-04-21 9:42 ` [bug#70494] [PATCH 05/23] store: build-derivations: " Christopher Baines
@ 2024-05-13 15:22 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-13 15:22 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> From: Caleb Ristvedt <caleb.ristvedt@cune.org>
>
> * guix/store/build-derivations.scm (get-output-specs, builtin-download,
> add-to-trie, make-search-trie, remove-from-trie!, scanning-wrapper-port,
> scan-for-references, ensure-input-outputs-exist, build-derivation): New
> procedures.
> (builtins): New variable.
> (<trie-node>): New record types.
> * Makefile.am (STORE_MODULES): Add it.
>
> Co-authored-by: Christopher Baines <mail@cbaines.net>
> Change-Id: I904b75e3c58c5fb996c0c9d1ca19b2cb2beb90b6
I think you can add a copyright line for you.
[...]
> +(define-module (guix store build-derivations)
Or just (guix store build)?
> + #:use-module (guix derivations)
As for (guix store), we’ll have to fix it eventually: daemon code should
not import client code.
So I would move the <derivation> record and low-level code to (guix
store derivations). (guix derivations) would import that module.
Anyway, we’ll discuss that separately.
> + #:use-module (guix build store-copy)
> + #:use-module (gnu system file-systems)
It’s a good idea to #:autoload as much as possible, especially (gnu …)
modules that may pull lots of other modules.
It would be good to have tests here: maybe low-level unit tests for the
reference scanner (it’s a fairly critical piece :-)), as well as
integration tests that perform a build or something.
Again maybe that can come later if it’s more convenient.
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 06/23] store: Export protocol related constants.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (4 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 05/23] store: build-derivations: " Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-13 15:58 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 07/23] serialization: Export read-byte-string Christopher Baines
` (16 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/store.scm (%protocol-version, %worker-magic-1, %worker-magic-2): Export
variables.
(protocol-major, protocol-minor, protocol-version): Export procedures.
(%stderr-next, %stderr-read, %stderr-write, %stderr-last, %stderr-error):
Move from process-stderr and export variables.
Change-Id: Id0b1b5e6feeac5260875558f33aa5d923d5e0903
---
guix/store.scm | 26 +++++++++++++-------------
1 file changed, 13 insertions(+), 13 deletions(-)
diff --git a/guix/store.scm b/guix/store.scm
index c3b58090e5..578e46507e 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -206,18 +206,25 @@ (define-module (guix store)
derivation-log-file
log-file))
-(define %protocol-version #x164)
+(define-public %protocol-version #x164)
-(define %worker-magic-1 #x6e697863) ; "nixc"
-(define %worker-magic-2 #x6478696f) ; "dxio"
+(define-public %worker-magic-1 #x6e697863) ; "nixc"
+(define-public %worker-magic-2 #x6478696f) ; "dxio"
-(define (protocol-major magic)
+(define-public (protocol-major magic)
(logand magic #xff00))
-(define (protocol-minor magic)
+(define-public (protocol-minor magic)
(logand magic #x00ff))
-(define (protocol-version major minor)
+(define-public (protocol-version major minor)
(logior major minor))
+;; magic cookies from worker-protocol.hh
+(define-public %stderr-next #x6f6c6d67) ; "olmg", build log
+(define-public %stderr-read #x64617461) ; "data", data needed from source
+(define-public %stderr-write #x64617416) ; "dat\x16", data for sink
+(define-public %stderr-last #x616c7473) ; "alts", we're done
+(define-public %stderr-error #x63787470) ; "cxtp", error reporting
+
(define-syntax define-enumerate-type
(syntax-rules ()
((_ name->int (name id) ...)
@@ -709,13 +716,6 @@ (define* (process-stderr server #:optional user-port)
(define p
(store-connection-socket server))
- ;; magic cookies from worker-protocol.hh
- (define %stderr-next #x6f6c6d67) ; "olmg", build log
- (define %stderr-read #x64617461) ; "data", data needed from source
- (define %stderr-write #x64617416) ; "dat\x16", data for sink
- (define %stderr-last #x616c7473) ; "alts", we're done
- (define %stderr-error #x63787470) ; "cxtp", error reporting
-
(let ((k (read-int p)))
(cond ((= k %stderr-write)
;; Write a byte stream to USER-PORT.
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 06/23] store: Export protocol related constants.
2024-04-21 9:42 ` [bug#70494] [PATCH 06/23] store: Export protocol related constants Christopher Baines
@ 2024-05-13 15:58 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-13 15:58 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> * guix/store.scm (%protocol-version, %worker-magic-1, %worker-magic-2): Export
> variables.
> (protocol-major, protocol-minor, protocol-version): Export procedures.
> (%stderr-next, %stderr-read, %stderr-write, %stderr-last, %stderr-error):
> Move from process-stderr and export variables.
>
> Change-Id: Id0b1b5e6feeac5260875558f33aa5d923d5e0903
> ---
> guix/store.scm | 26 +++++++++++++-------------
> 1 file changed, 13 insertions(+), 13 deletions(-)
>
> diff --git a/guix/store.scm b/guix/store.scm
> index c3b58090e5..578e46507e 100644
> --- a/guix/store.scm
> +++ b/guix/store.scm
> @@ -206,18 +206,25 @@ (define-module (guix store)
> derivation-log-file
> log-file))
>
> -(define %protocol-version #x164)
> +(define-public %protocol-version #x164)
>
> -(define %worker-magic-1 #x6e697863) ; "nixc"
> -(define %worker-magic-2 #x6478696f) ; "dxio"
> +(define-public %worker-magic-1 #x6e697863) ; "nixc"
> +(define-public %worker-magic-2 #x6478696f) ; "dxio"
Two things:
1. This is a case for a new (guix store protocol) module. Preferably
I would keep those constants local to that module and instead
expose higher-level facilities, but we can start by just exporting
these constants.
2. From a cosmetic viewpoint, please use #:export rather than
‘define-public’, for clarity (package modules are the exception).
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 07/23] serialization: Export read-byte-string.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (5 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 06/23] store: Export protocol related constants Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-13 15:58 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 08/23] store: Add text-output-path and text-output-path-from-hash Christopher Baines
` (15 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/serialization.scm (read-byte-string): Export procedure.
Change-Id: Ifcbf06a7b99c938dba66e25ef5adbd5feea8c85c
---
guix/serialization.scm | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 9656e5ac2a..28eefbd398 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -31,7 +31,8 @@ (define-module (guix serialization)
write-long-long read-long-long
write-padding
write-bytevector write-string
- read-string read-latin1-string read-maybe-utf8-string
+ read-string read-byte-string
+ read-latin1-string read-maybe-utf8-string
write-string-list read-string-list
write-string-pairs read-string-pairs
write-store-path read-store-path
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 08/23] store: Add text-output-path and text-output-path-from-hash.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (6 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 07/23] serialization: Export read-byte-string Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-13 15:59 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 09/23] store: Add validate-store-name Christopher Baines
` (14 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/store.scm (text-output-path, text-output-path-from-hash): New
procedures.
Change-Id: I38c3aaa0b304dd4f97a222a1065eb1b7f55bbfad
---
guix/store.scm | 16 ++++++++++++++++
1 file changed, 16 insertions(+)
diff --git a/guix/store.scm b/guix/store.scm
index 578e46507e..b83f205096 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -196,6 +196,8 @@ (define-module (guix store)
store-path
output-path
fixed-output-path
+ text-output-path
+ text-output-path-from-hash
store-path?
direct-store-path?
derivation-path?
@@ -2280,6 +2282,20 @@ (define* (fixed-output-path name hash
(sha256 (string->utf8 tag))
name))))
+(define (text-output-path name text references)
+ (text-output-path-from-hash
+ name
+ (sha256 (string->utf8 text))
+ references))
+
+(define* (text-output-path-from-hash name text-hash references)
+ (store-path
+ (string-append "text" (string-join (sort references string<?)
+ ":"
+ 'prefix))
+ text-hash
+ name))
+
(define (store-path? path)
"Return #t if PATH is a store path."
;; This is a lightweight check, compared to using a regexp, but this has to
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 09/23] store: Add validate-store-name.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (7 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 08/23] store: Add text-output-path and text-output-path-from-hash Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-13 16:04 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 10/23] store: database: Add procedures for querying valid paths Christopher Baines
` (13 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/store.scm (validate-store-name): New procedure.
Change-Id: I507d070d1cfdbd433d93830ee2937b1a1dee315a
---
guix/store.scm | 11 +++++++++++
1 file changed, 11 insertions(+)
diff --git a/guix/store.scm b/guix/store.scm
index b83f205096..096efcd128 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -205,6 +205,7 @@ (define-module (guix store)
store-path-package-name
store-path-hash-part
direct-store-path
+ validate-store-name
derivation-log-file
log-file))
@@ -2303,6 +2304,16 @@ (define (store-path? path)
;; `isStorePath' in Nix does something similar.
(string-prefix? (%store-prefix) path))
+(define (validate-store-name name)
+ (string-for-each
+ (lambda (c)
+ (unless (or (char-alphabetic? c)
+ (char-numeric? c)
+ (member c '(#\+ #\- #\. #\_ #\? #\=)))
+ (error (simple-format #f "invalid character ~A" c))))
+ name)
+ #t)
+
(define (direct-store-path? path)
"Return #t if PATH is a store path, and not a sub-directory of a store path.
This predicate is sometimes needed because files *under* a store path are not
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 09/23] store: Add validate-store-name.
2024-04-21 9:42 ` [bug#70494] [PATCH 09/23] store: Add validate-store-name Christopher Baines
@ 2024-05-13 16:04 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-13 16:04 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> * guix/store.scm (validate-store-name): New procedure.
>
> Change-Id: I507d070d1cfdbd433d93830ee2937b1a1dee315a
> ---
> guix/store.scm | 11 +++++++++++
> 1 file changed, 11 insertions(+)
>
> diff --git a/guix/store.scm b/guix/store.scm
> index b83f205096..096efcd128 100644
> --- a/guix/store.scm
> +++ b/guix/store.scm
> @@ -205,6 +205,7 @@ (define-module (guix store)
> store-path-package-name
> store-path-hash-part
> direct-store-path
> + validate-store-name
> derivation-log-file
> log-file))
>
> @@ -2303,6 +2304,16 @@ (define (store-path? path)
> ;; `isStorePath' in Nix does something similar.
> (string-prefix? (%store-prefix) path))
>
> +(define (validate-store-name name)
> + (string-for-each
> + (lambda (c)
> + (unless (or (char-alphabetic? c)
> + (char-numeric? c)
> + (member c '(#\+ #\- #\. #\_ #\? #\=)))
> + (error (simple-format #f "invalid character ~A" c))))
> + name)
> + #t)
This is not the same as ‘checkStoreName’ in store-api.cc, due to Unicode
support.
So I think you have to specify the complete alphabet like
‘ensure-valid-store-file-name’ in (guix scripts download) does.
Also, distinguish ‘valid-store-name?’ from ‘validate-store-name’.
Raise a dedicated SRFI-35 error condition or use ‘formatted-message’; as
a rule of thumb, never use ‘error’ because it cannot be usefully handled
by callers.
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 10/23] store: database: Add procedures for querying valid paths.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (8 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 09/23] store: Add validate-store-name Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:04 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 11/23] scripts: substitute: Untangle selecting fast vs small compressions Christopher Baines
` (12 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/store/database.scm (valid-path, all-valid-paths,
valid-path-from-hash-part, valid-path-references): New procedures.
Change-Id: Ib08837ee20f5a5a24a8089e611b5d67b003b62cc
---
guix/store/database.scm | 88 ++++++++++++++++++++++++++++++++++++++++-
1 file changed, 87 insertions(+), 1 deletion(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 07bd501644..8a3436368e 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -55,9 +55,13 @@ (define-module (guix store database)
%epoch
reset-timestamps
vacuum-database
+ valid-path
+ all-valid-paths
+ valid-path-from-hash-part
outputs-exist?
file-closure
- all-transitive-inputs))
+ all-transitive-inputs
+ valid-path-references))
;;; Code for working with the store database directly.
@@ -447,6 +451,63 @@ (define (vacuum-database)
(sqlite-exec db "VACUUM;")
(sqlite-close db)))
+(define (valid-path db store-filename)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT id, hash, registrationTime, deriver, narSize
+FROM ValidPaths
+WHERE path = :path"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:path store-filename)
+
+ (let ((result (sqlite-step statement)))
+ (sqlite-reset statement)
+
+ result)))
+
+(define (all-valid-paths db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT path FROM ValidPaths"
+ #:cache? #t)))
+
+ (let ((result
+ (sqlite-map
+ (match-lambda
+ (#(path) path))
+ statement)))
+ (sqlite-reset statement)
+
+ result)))
+
+(define (valid-path-from-hash-part db hash)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT path FROM ValidPaths WHERE path >= :path LIMIT 1"
+ #:cache? #t))
+ (path-prefix
+ (string-append (%store-prefix) "/" hash)))
+
+ (sqlite-bind-arguments
+ statement
+ #:path path-prefix)
+
+ (let ((result
+ (sqlite-step statement)))
+
+ (if (and result (string-prefix? path-prefix result))
+ result
+ #f))))
+
(define (outputs-exist? db drv-path outputs)
"Determine whether all output labels in OUTPUTS exist as built outputs of
DRV-PATH."
@@ -527,3 +588,28 @@ (define (all-transitive-inputs db drv)
vlist-null
`(,@(derivation-sources drv)
,@input-paths)))))
+
+(define (valid-path-references db valid-path-id)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT ValidPaths.path
+FROM Refs
+INNER JOIN ValidPaths ON Refs.reference = ValidPaths.id
+WHERE referrer = :id"
+ #:cache? #t)))
+
+ (sqlite-bind-arguments
+ statement
+ #:id valid-path-id)
+
+ (let ((result (sqlite-fold
+ (lambda (row result)
+ (cons (vector-ref row 0)
+ result))
+ '()
+ statement)))
+ (sqlite-reset statement)
+
+ result)))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 10/23] store: database: Add procedures for querying valid paths.
2024-04-21 9:42 ` [bug#70494] [PATCH 10/23] store: database: Add procedures for querying valid paths Christopher Baines
@ 2024-05-16 16:04 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:04 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Hi again! :-)
Christopher Baines <mail@cbaines.net> skribis:
> * guix/store/database.scm (valid-path, all-valid-paths,
> valid-path-from-hash-part, valid-path-references): New procedures.
>
> Change-Id: Ib08837ee20f5a5a24a8089e611b5d67b003b62cc
[...]
> +(define (valid-path db store-filename)
Please add docstrings to top-level procedures (info "(guix) Formatting
Code").
> + (let ((statement
> + (sqlite-prepare
> + db
> + "
> +SELECT id, hash, registrationTime, deriver, narSize
> +FROM ValidPaths
> +WHERE path = :path"
> + #:cache? #t)))
> +
> + (sqlite-bind-arguments
> + statement
> + #:path store-filename)
> +
> + (let ((result (sqlite-step statement)))
> + (sqlite-reset statement)
> +
> + result)))
Am I right that this returns a vector of 4 elements?
If that’s the case, it should instead return a <valid-path> record (or
similar), and that should be consistent across the interface (except in
case where we explicitly want an ID as input.) We’d rather not expose
SQLite-related implementation details.
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 11/23] scripts: substitute: Untangle selecting fast vs small compressions.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (9 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 10/23] store: database: Add procedures for querying valid paths Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:08 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 12/23] scripts: substitute: Extract script specific output from download-nar Christopher Baines
` (11 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
Pulling the logic up to the script makes this code more portable and not
reliant on setting a global variable.
* guix/scripts/substitute.scm (%prefer-fast-decompression?): Rename to…
(%default-prefer-fast-decompression?): this.
(call-with-cpu-usage-monitoring): Use multiple values to return the results
from the thunk as well as the cpu usage.
(display-narinfo-data): Update accordingly.
(download-nar): Add prefer-fast-decompression? as a keyword argument, remove
code to set! it and monitor the cpu-usage.
(process-substitution, process-substitution/fallback): Accept and pass through
prefer-fast-decompression? to download-nar.
(guix-substitute): Move the cpu usage monitoring and prefer fast decompression
switching logic here.
Change-Id: I4e80b457b55bcda8c0ff4ee224dd94a55e1b24fb
---
guix/scripts/substitute.scm | 126 +++++++++++++++++++++---------------
1 file changed, 73 insertions(+), 53 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index a7ad56dbcd..0d0fd0e73b 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -261,22 +261,24 @@ (define (show-help)
;;; Daemon/substituter protocol.
;;;
-(define %prefer-fast-decompression?
- ;; Whether to prefer fast decompression over good compression ratios. This
- ;; serves in particular to choose between lzip (high compression ratio but
- ;; low decompression throughput) and zstd (lower compression ratio but high
- ;; decompression throughput).
- #f)
-
-(define (call-with-cpu-usage-monitoring proc)
+;; Whether to initially prefer fast decompression or not
+(define %default-prefer-fast-decompression? #f)
+
+(define (call-with-cpu-usage-monitoring thunk)
(let ((before (times)))
- (proc)
- (let ((after (times)))
- (if (= (tms:clock after) (tms:clock before))
- 0
- (/ (- (tms:utime after) (tms:utime before))
- (- (tms:clock after) (tms:clock before))
- 1.)))))
+ (call-with-values thunk
+ (lambda vals
+ (let ((after (times)))
+ (apply
+ values
+ (append
+ (or vals '())
+ (list
+ (if (= (tms:clock after) (tms:clock before))
+ 0
+ (/ (- (tms:utime after) (tms:utime before))
+ (- (tms:clock after) (tms:clock before))
+ 1.))))))))))
(define-syntax-rule (with-cpu-usage-monitoring exp ...)
"Evaluate EXP... Return its CPU usage as a fraction between 0 and 1."
@@ -297,7 +299,7 @@ (define (display-narinfo-data port narinfo)
(let ((uri compression file-size
(narinfo-best-uri narinfo
#:fast-decompression?
- %prefer-fast-decompression?)))
+ %default-prefer-fast-decompression?)))
(format port "~a\n~a\n"
(or file-size 0)
(or (narinfo-size narinfo) 0))))
@@ -453,7 +455,8 @@ (define-syntax-rule (catch-system-error exp)
(define* (download-nar narinfo destination
#:key status-port
deduplicate? print-build-trace?
- (fetch-timeout %fetch-timeout))
+ (fetch-timeout %fetch-timeout)
+ prefer-fast-decompression?)
"Download the nar prescribed in NARINFO, which is assumed to be authentic
and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
if DESTINATION is in the store, deduplicate its files. Print a status line to
@@ -527,7 +530,7 @@ (define* (download-nar narinfo destination
(let ((choices (narinfo-preferred-uris narinfo
#:fast-decompression?
- %prefer-fast-decompression?)))
+ prefer-fast-decompression?)))
;; 'guix publish' without '--cache' doesn't specify a Content-Length, so
;; DOWNLOAD-SIZE is #f in this case.
(let* ((raw uri compression download-size (try-fetch choices))
@@ -560,29 +563,13 @@ (define* (download-nar narinfo destination
;; Compute the actual nar hash as we read it.
(algorithm expected (narinfo-hash-algorithm+value narinfo))
(hashed get-hash (open-hash-input-port algorithm input)))
- ;; Unpack the Nar at INPUT into DESTINATION.
- (define cpu-usage
- (with-cpu-usage-monitoring
- (restore-file hashed destination
- #:dump-file (if (and destination-in-store?
- deduplicate?)
- dump-file/deduplicate*
- dump-file))))
-
- ;; Create a hysteresis: depending on CPU usage, favor compression
- ;; methods with faster decompression (like ztsd) or methods with better
- ;; compression ratios (like lzip). This stems from the observation that
- ;; substitution can be CPU-bound when high-speed networks are used:
- ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
- ;; To simulate "slow" networking or changing conditions, run:
- ;; sudo tc qdisc add dev eno1 root tbf rate 512kbit latency 50ms burst 1540
- ;; and then cancel with:
- ;; sudo tc qdisc del dev eno1 root
- (when (> cpu-usage .8)
- (set! %prefer-fast-decompression? #t))
- (when (< cpu-usage .2)
- (set! %prefer-fast-decompression? #f))
+ ;; Unpack the Nar at INPUT into DESTINATION.
+ (restore-file hashed destination
+ #:dump-file (if (and destination-in-store?
+ deduplicate?)
+ dump-file/deduplicate*
+ dump-file))
(close-port hashed)
(close-port input)
@@ -630,7 +617,8 @@ (define network-error?
(define* (process-substitution/fallback port narinfo destination
#:key cache-urls acl
- deduplicate? print-build-trace?)
+ deduplicate? print-build-trace?
+ prefer-fast-decompression?)
"Attempt to substitute NARINFO, which is assumed to be authorized or
equivalent, by trying to download its nar from each entry in CACHE-URLS.
@@ -664,14 +652,17 @@ (define* (process-substitution/fallback port narinfo destination
(download-nar alternate destination
#:status-port port
#:deduplicate? deduplicate?
- #:print-build-trace? print-build-trace?))
+ #:print-build-trace? print-build-trace?
+ #:prefer-fast-decompression?
+ prefer-fast-decompression?))
(loop rest)))
(()
(loop rest)))))))
(define* (process-substitution port store-item destination
#:key cache-urls acl
- deduplicate? print-build-trace?)
+ deduplicate? print-build-trace?
+ prefer-fast-decompression?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL, and verify its
hash against what appears in the narinfo. When DEDUPLICATE? is true, and if
@@ -703,11 +694,14 @@ (define* (process-substitution port store-item destination
#:acl acl
#:deduplicate? deduplicate?
#:print-build-trace?
- print-build-trace?)))
+ print-build-trace?
+ #:prefer-fast-decompression?
+ prefer-fast-decompression?)))
(download-nar narinfo destination
#:status-port port
#:deduplicate? deduplicate?
- #:print-build-trace? print-build-trace?)))
+ #:print-build-trace? print-build-trace?
+ #:prefer-fast-decompression? prefer-fast-decompression?)))
\f
;;;
@@ -897,18 +891,44 @@ (define-command (guix-substitute . args)
;; Specify the number of columns of the terminal so the progress
;; report displays nicely.
(parameterize ((current-terminal-columns (client-terminal-columns)))
- (let loop ()
+ (let loop ((prefer-fast-decompression?
+ %default-prefer-fast-decompression?))
(match (read-line)
((? eof-object?)
#t)
((= string-tokenize ("substitute" store-path destination))
- (process-substitution reply-port store-path destination
- #:cache-urls (substitute-urls)
- #:acl (current-acl)
- #:deduplicate? deduplicate?
- #:print-build-trace?
- print-build-trace?)
- (loop))))))
+ (let ((cpu-usage
+ (with-cpu-usage-monitoring
+ (process-substitution
+ reply-port store-path destination
+ #:cache-urls (substitute-urls)
+ #:acl (current-acl)
+ #:deduplicate? deduplicate?
+ #:print-build-trace?
+ print-build-trace?
+ #:prefer-fast-decompression?
+ prefer-fast-decompression?))))
+
+ ;; Create a hysteresis: depending on CPU usage, favor
+ ;; compression methods with faster decompression (like ztsd)
+ ;; or methods with better compression ratios (like lzip).
+ ;; This stems from the observation that substitution can be
+ ;; CPU-bound when high-speed networks are used:
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
+ ;; To simulate "slow" networking or changing conditions, run:
+ ;; sudo tc qdisc add dev eno1 root tbf rate 512kbit latency
+ ;; 50ms burst 1540 and then cancel with: sudo tc qdisc del
+ ;; dev eno1 root
+ (loop (cond
+ ;; Whether to prefer fast decompression over good
+ ;; compression ratios. This serves in particular to
+ ;; choose between lzip (high compression ratio but low
+ ;; decompression throughput) and zstd (lower
+ ;; compression ratio but high decompression
+ ;; throughput).
+ ((> cpu-usage .8) #t)
+ ((< cpu-usage .2) #f)
+ (else prefer-fast-decompression?)))))))))
(opts
(leave (G_ "~a: unrecognized options~%") opts))))))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 11/23] scripts: substitute: Untangle selecting fast vs small compressions.
2024-04-21 9:42 ` [bug#70494] [PATCH 11/23] scripts: substitute: Untangle selecting fast vs small compressions Christopher Baines
@ 2024-05-16 16:08 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:08 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> Pulling the logic up to the script makes this code more portable and not
> reliant on setting a global variable.
>
> * guix/scripts/substitute.scm (%prefer-fast-decompression?): Rename to…
> (%default-prefer-fast-decompression?): this.
> (call-with-cpu-usage-monitoring): Use multiple values to return the results
> from the thunk as well as the cpu usage.
> (display-narinfo-data): Update accordingly.
> (download-nar): Add prefer-fast-decompression? as a keyword argument, remove
> code to set! it and monitor the cpu-usage.
> (process-substitution, process-substitution/fallback): Accept and pass through
> prefer-fast-decompression? to download-nar.
> (guix-substitute): Move the cpu usage monitoring and prefer fast decompression
> switching logic here.
>
> Change-Id: I4e80b457b55bcda8c0ff4ee224dd94a55e1b24fb
[...]
> + ;; Create a hysteresis: depending on CPU usage, favor
> + ;; compression methods with faster decompression (like ztsd)
> + ;; or methods with better compression ratios (like lzip).
> + ;; This stems from the observation that substitution can be
> + ;; CPU-bound when high-speed networks are used:
> + ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
> + ;; To simulate "slow" networking or changing conditions, run:
> + ;; sudo tc qdisc add dev eno1 root tbf rate 512kbit latency
> + ;; 50ms burst 1540 and then cancel with: sudo tc qdisc del
> + ;; dev eno1 root
This comment’s formatting was broken (by M-q I guess).
Otherwise LGTM!
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 12/23] scripts: substitute: Extract script specific output from download-nar.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (10 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 11/23] scripts: substitute: Untangle selecting fast vs small compressions Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:13 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 13/23] syscalls: Add unshare Christopher Baines
` (10 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
As this moves download-nar in a direction where it could be used outside the
substitute script.
* guix/scripts/substitute.scm (download-nar): Return expected and actual
hashes and move status-port output to guix-substitute.
(process-substitution/fallback): Remove port argument, and move output to port
to guix-substitute.
(process-substitution): Return hashes from download-nar or
process-substitution/fallback, plus the narinfo.
(guix-substitute): Don't pass the reply-port in to process-substitution and
implement the messages to the reply-port here.
Change-Id: Icbddb9a47620b3520cdd2e8095f37a99824c1ce0
---
guix/scripts/substitute.scm | 162 ++++++++++++++++++++----------------
1 file changed, 90 insertions(+), 72 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 0d0fd0e73b..c2bc16085d 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -453,14 +453,12 @@ (define-syntax-rule (catch-system-error exp)
(const #f)))
(define* (download-nar narinfo destination
- #:key status-port
- deduplicate? print-build-trace?
+ #:key deduplicate? print-build-trace?
(fetch-timeout %fetch-timeout)
prefer-fast-decompression?)
"Download the nar prescribed in NARINFO, which is assumed to be authentic
and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
-if DESTINATION is in the store, deduplicate its files. Print a status line to
-STATUS-PORT."
+if DESTINATION is in the store, deduplicate its files."
(define destination-in-store?
(string-prefix? (string-append (%store-prefix) "/")
destination))
@@ -576,24 +574,8 @@ (define* (download-nar narinfo destination
;; Wait for the reporter to finish.
(every (compose zero? cdr waitpid) pids)
- ;; Skip a line after what 'progress-reporter/file' printed, and another
- ;; one to visually separate substitutions. When PRINT-BUILD-TRACE? is
- ;; true, leave it up to (guix status) to prettify things.
- (newline (current-error-port))
- (unless print-build-trace?
- (newline (current-error-port)))
-
- ;; Check whether we got the data announced in NARINFO.
- (let ((actual (get-hash)))
- (if (bytevector=? actual expected)
- ;; Tell the daemon that we're done.
- (format status-port "success ~a ~a~%"
- (narinfo-hash narinfo) (narinfo-size narinfo))
- ;; The actual data has a different hash than that in NARINFO.
- (format status-port "hash-mismatch ~a ~a ~a~%"
- (hash-algorithm-name algorithm)
- (bytevector->nix-base32-string expected)
- (bytevector->nix-base32-string actual)))))))
+ (values expected
+ (get-hash)))))
(define (system-error? exception)
"Return true if EXCEPTION is a Guile 'system-error exception."
@@ -615,7 +597,7 @@ (define network-error?
'(gnutls-error getaddrinfo-error)))
(http-get-error? exception)))))
-(define* (process-substitution/fallback port narinfo destination
+(define* (process-substitution/fallback narinfo destination
#:key cache-urls acl
deduplicate? print-build-trace?
prefer-fast-decompression?)
@@ -630,9 +612,8 @@ (define* (process-substitution/fallback port narinfo destination
(let loop ((cache-urls cache-urls))
(match cache-urls
(()
- (report-error (G_ "failed to find alternative substitute for '~a'~%")
- (narinfo-path narinfo))
- (display "not-found\n" port))
+ ;; Failure, so return two values like download-nar
+ (values #f #f))
((cache-url rest ...)
(match (lookup-narinfos cache-url
(list (narinfo-path narinfo))
@@ -650,7 +631,6 @@ (define* (process-substitution/fallback port narinfo destination
(http-get-error-reason c)))
(loop rest)))
(download-nar alternate destination
- #:status-port port
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
#:prefer-fast-decompression?
@@ -659,7 +639,7 @@ (define* (process-substitution/fallback port narinfo destination
(()
(loop rest)))))))
-(define* (process-substitution port store-item destination
+(define* (process-substitution store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?
prefer-fast-decompression?)
@@ -680,28 +660,34 @@ (define* (process-substitution port store-item destination
(G_ "no valid substitute for '~a'~%")
store-item)))
- (guard (c ((network-error? c)
- (when (http-get-error? c)
- (warning (G_ "download from '~a' failed: ~a, ~s~%")
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c)))
- (format (current-error-port)
- (G_ "retrying download of '~a' with other substitute URLs...~%")
- store-item)
- (process-substitution/fallback port narinfo destination
- #:cache-urls cache-urls
- #:acl acl
- #:deduplicate? deduplicate?
- #:print-build-trace?
- print-build-trace?
- #:prefer-fast-decompression?
- prefer-fast-decompression?)))
- (download-nar narinfo destination
- #:status-port port
- #:deduplicate? deduplicate?
- #:print-build-trace? print-build-trace?
- #:prefer-fast-decompression? prefer-fast-decompression?)))
+ (let ((expected-hash
+ actual-hash
+ (guard
+ (c ((network-error? c)
+ (when (http-get-error? c)
+ (warning (G_ "download from '~a' failed: ~a, ~s~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c)))
+ (format
+ (current-error-port)
+ (G_ "retrying download of '~a' with other substitute URLs...~%")
+ store-item)
+ (process-substitution/fallback narinfo destination
+ #:cache-urls cache-urls
+ #:acl acl
+ #:deduplicate? deduplicate?
+ #:print-build-trace?
+ print-build-trace?
+ #:prefer-fast-decompression?
+ prefer-fast-decompression?)))
+ (download-nar narinfo destination
+ #:deduplicate? deduplicate?
+ #:print-build-trace? print-build-trace?
+ #:prefer-fast-decompression? prefer-fast-decompression?))))
+ (values narinfo
+ expected-hash
+ actual-hash)))
\f
;;;
@@ -897,10 +883,13 @@ (define-command (guix-substitute . args)
((? eof-object?)
#t)
((= string-tokenize ("substitute" store-path destination))
- (let ((cpu-usage
+ (let ((narinfo
+ expected-hash
+ actual-hash
+ cpu-usage
(with-cpu-usage-monitoring
(process-substitution
- reply-port store-path destination
+ store-path destination
#:cache-urls (substitute-urls)
#:acl (current-acl)
#:deduplicate? deduplicate?
@@ -909,26 +898,55 @@ (define-command (guix-substitute . args)
#:prefer-fast-decompression?
prefer-fast-decompression?))))
- ;; Create a hysteresis: depending on CPU usage, favor
- ;; compression methods with faster decompression (like ztsd)
- ;; or methods with better compression ratios (like lzip).
- ;; This stems from the observation that substitution can be
- ;; CPU-bound when high-speed networks are used:
- ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
- ;; To simulate "slow" networking or changing conditions, run:
- ;; sudo tc qdisc add dev eno1 root tbf rate 512kbit latency
- ;; 50ms burst 1540 and then cancel with: sudo tc qdisc del
- ;; dev eno1 root
- (loop (cond
- ;; Whether to prefer fast decompression over good
- ;; compression ratios. This serves in particular to
- ;; choose between lzip (high compression ratio but low
- ;; decompression throughput) and zstd (lower
- ;; compression ratio but high decompression
- ;; throughput).
- ((> cpu-usage .8) #t)
- ((< cpu-usage .2) #f)
- (else prefer-fast-decompression?)))))))))
+ (if expected-hash
+ (begin
+ ;; Skip a line after what 'progress-reporter/file'
+ ;; printed, and another one to visually separate
+ ;; substitutions. When PRINT-BUILD-TRACE? is true,
+ ;; leave it up to (guix status) to prettify things.
+ (newline (current-error-port))
+ (unless print-build-trace?
+ (newline (current-error-port)))
+
+ ;; Check whether we got the data announced in NARINFO.
+ (if (bytevector=? actual-hash expected-hash)
+ ;; Tell the daemon that we're done.
+ (format reply-port "success ~a ~a~%"
+ (narinfo-hash narinfo) (narinfo-size narinfo))
+ ;; The actual data has a different hash than that in NARINFO.
+ (format reply-port "hash-mismatch ~a ~a ~a~%"
+ (hash-algorithm-name
+ (narinfo-hash-algorithm+value narinfo))
+ (bytevector->nix-base32-string expected-hash)
+ (bytevector->nix-base32-string actual-hash)))
+
+ ;; Create a hysteresis: depending on CPU usage, favor
+ ;; compression methods with faster decompression (like
+ ;; ztsd) or methods with better compression ratios
+ ;; (like lzip). This stems from the observation that
+ ;; substitution can be CPU-bound when high-speed
+ ;; networks are used:
+ ;; <https://lists.gnu.org/archive/html/guix-devel/2020-12/msg00177.html>.
+ ;; To simulate "slow" networking or changing
+ ;; conditions, run: sudo tc qdisc add dev eno1 root tbf
+ ;; rate 512kbit latency 50ms burst 1540 and then cancel
+ ;; with: sudo tc qdisc del dev eno1 root
+ (loop (cond
+ ;; Whether to prefer fast decompression over
+ ;; good compression ratios. This serves in
+ ;; particular to choose between lzip (high
+ ;; compression ratio but low decompression
+ ;; throughput) and zstd (lower compression ratio
+ ;; but high decompression throughput).
+ ((> cpu-usage .8) #t)
+ ((< cpu-usage .2) #f)
+ (else prefer-fast-decompression?))))
+ (begin
+ (report-error (G_ "failed to find alternative substitute for '~a'~%")
+ (narinfo-path narinfo))
+ (display "not-found\n" reply-port)
+
+ (loop prefer-fast-decompression?)))))))))
(opts
(leave (G_ "~a: unrecognized options~%") opts))))))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 12/23] scripts: substitute: Extract script specific output from download-nar.
2024-04-21 9:42 ` [bug#70494] [PATCH 12/23] scripts: substitute: Extract script specific output from download-nar Christopher Baines
@ 2024-05-16 16:13 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:13 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> As this moves download-nar in a direction where it could be used outside the
> substitute script.
Note that there’s already (guix build download-nar), which is less
capable.
> * guix/scripts/substitute.scm (download-nar): Return expected and actual
> hashes and move status-port output to guix-substitute.
> (process-substitution/fallback): Remove port argument, and move output to port
> to guix-substitute.
> (process-substitution): Return hashes from download-nar or
> process-substitution/fallback, plus the narinfo.
> (guix-substitute): Don't pass the reply-port in to process-substitution and
> implement the messages to the reply-port here.
I’m not quite convinced. In particular, procedures returning more than
two values look confusing to me. Maybe it’s not the right level to
generalize things?
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 13/23] syscalls: Add unshare.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (11 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 12/23] scripts: substitute: Extract script specific output from download-nar Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:14 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 14/23] scripts: perform-download: Support configuring the %store-prefix Christopher Baines
` (9 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
* guix/build/syscalls.scm (unshare): New procedure.
Change-Id: I7caad207117b17b349290e680277f650c51d2f3b
---
guix/build/syscalls.scm | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 487ee68b43..492a229938 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -36,6 +36,7 @@ (define-module (guix build syscalls)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@@ -121,6 +122,7 @@ (define-module (guix build syscalls)
mkdtemp!
fdatasync
pivot-root
+ unshare
scandir*
getxattr
setxattr
@@ -1183,6 +1185,16 @@ (define pivot-root
(list new-root put-old (strerror err))
(list err)))))))
+(define unshare
+ (false-if-exception
+ (let ((proc (syscall->procedure int "unshare" (list int))))
+ (lambda (flags)
+ (let ((ret err (proc flags)))
+ (unless (zero? ret)
+ (throw 'system-error "unshare" "~d ~d: ~A"
+ (list flags (strerror err))
+ (list err))))))))
+
\f
;;;
;;; Opendir & co.
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 13/23] syscalls: Add unshare.
2024-04-21 9:42 ` [bug#70494] [PATCH 13/23] syscalls: Add unshare Christopher Baines
@ 2024-05-16 16:14 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:14 UTC (permalink / raw)
To: Christopher Baines; +Cc: 70494
Christopher Baines <mail@cbaines.net> skribis:
> * guix/build/syscalls.scm (unshare): New procedure.
>
> Change-Id: I7caad207117b17b349290e680277f650c51d2f3b
[...]
> +(define unshare
> + (false-if-exception
> + (let ((proc (syscall->procedure int "unshare" (list int))))
> + (lambda (flags)
> + (let ((ret err (proc flags)))
> + (unless (zero? ret)
> + (throw 'system-error "unshare" "~d ~d: ~A"
> + (list flags (strerror err))
> + (list err))))))))
Please remove ‘false-if-exception’, add a docstring, and add a test or
two.
(I find that unshare(2) is not that useful because a process cannot
unshare(2) its PID namespace: it has to fork to do that. At that point,
one might as well call clone(CLONE_NEWPID) directly.)
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 14/23] scripts: perform-download: Support configuring the %store-prefix.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (12 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 13/23] syscalls: Add unshare Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:17 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 15/23] store: Export operation-id Christopher Baines
` (8 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/scripts/perform-download.scm (guix-perform-download): Use
GUIX_STORE_DIRECTORY from the environment if it's set, as this allows using
the perform-download script with a non-default store directory.
Change-Id: Id96bb901a106e1b13be5b21b3ce436c680c616a2
---
guix/scripts/perform-download.scm | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 5079d0ea71..f7f5231f27 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -20,7 +20,8 @@ (define-module (guix scripts perform-download)
#:use-module (guix ui)
#:use-module (guix scripts)
#:use-module (guix derivations)
- #:use-module ((guix store) #:select (derivation-path? store-path?))
+ #:use-module ((guix store) #:select (%store-prefix derivation-path?
+ store-path?))
#:autoload (guix build download) (%download-methods url-fetch)
#:autoload (guix build git) (git-fetch-with-fallback)
#:autoload (guix config) (%git)
@@ -153,6 +154,9 @@ (define-command (guix-perform-download . args)
(#f #f)
(str (string-contains str "print-extended-build-trace=1"))))
+ (and=> (getenv "GUIX_STORE_DIRECTORY")
+ %store-prefix)
+
;; This program must be invoked by guix-daemon under an unprivileged UID to
;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
;; execution via the content-addressed mirror procedures. (That means we
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 14/23] scripts: perform-download: Support configuring the %store-prefix.
2024-04-21 9:42 ` [bug#70494] [PATCH 14/23] scripts: perform-download: Support configuring the %store-prefix Christopher Baines
@ 2024-05-16 16:17 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:17 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> * guix/scripts/perform-download.scm (guix-perform-download): Use
> GUIX_STORE_DIRECTORY from the environment if it's set, as this allows using
> the perform-download script with a non-default store directory.
>
> Change-Id: Id96bb901a106e1b13be5b21b3ce436c680c616a2
[...]
> + (and=> (getenv "GUIX_STORE_DIRECTORY")
> + %store-prefix)
‘%store-prefix’ is a parameter, and it already honors NIX_STORE_DIR by
default. ‘GUIX_STORE_DIRECTORY’ isn’t used anywhere AFAICS.
Maybe let’s stick to what we currently have?
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 15/23] store: Export operation-id.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (13 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 14/23] scripts: perform-download: Support configuring the %store-prefix Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:18 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 16/23] store: database: Log when aborting transactions Christopher Baines
` (7 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/store.scm (operation-id): Export.
Change-Id: I03c83973c9056795fef935016df7321a69c1116d
---
guix/store.scm | 2 ++
1 file changed, 2 insertions(+)
diff --git a/guix/store.scm b/guix/store.scm
index 096efcd128..cbf644ac30 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -101,6 +101,8 @@ (define-module (guix store)
hash-algo
build-mode
+ operation-id
+
connect-to-daemon
open-connection
port->connection
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 16/23] store: database: Log when aborting transactions.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (14 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 15/23] store: Export operation-id Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:20 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 17/23] store: database: Export transaction helpers Christopher Baines
` (6 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
Otherwise this has the effect of masking the backtrace/exception.
* guix/store/database.scm (call-with-transaction): Log when aborting.
Change-Id: Iee31905c4688dc62ef37a85b0208fd324ee67d70
---
guix/store/database.scm | 14 +++++++++++---
1 file changed, 11 insertions(+), 3 deletions(-)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 8a3436368e..b6f87d710f 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -154,9 +154,17 @@ (define* (call-with-transaction db proc #:key restartable?)
(sqlite-exec db (if restartable? "begin;" "begin immediate;"))
(catch #t
(lambda ()
- (let-values ((result (proc)))
- (sqlite-exec db "commit;")
- (apply values result)))
+ (with-throw-handler #t
+ (lambda ()
+ (call-with-values proc
+ (lambda vals
+ (sqlite-exec db "commit;")
+ (apply values vals))))
+ (lambda (key args)
+ (simple-format
+ (current-error-port)
+ "transaction aborted: ~A: ~A\n" key args)
+ (backtrace))))
(lambda args
;; The roll back may or may not have occurred automatically when the
;; error was generated. If it has occurred, this does nothing but signal
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 16/23] store: database: Log when aborting transactions.
2024-04-21 9:42 ` [bug#70494] [PATCH 16/23] store: database: Log when aborting transactions Christopher Baines
@ 2024-05-16 16:20 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:20 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> Otherwise this has the effect of masking the backtrace/exception.
>
> * guix/store/database.scm (call-with-transaction): Log when aborting.
>
> Change-Id: Iee31905c4688dc62ef37a85b0208fd324ee67d70
> + (with-throw-handler #t
> + (lambda ()
> + (call-with-values proc
> + (lambda vals
> + (sqlite-exec db "commit;")
> + (apply values vals))))
> + (lambda (key args)
> + (simple-format
> + (current-error-port)
> + "transaction aborted: ~A: ~A\n" key args)
> + (backtrace))))
I would just let the sqlite exception through, which should have a
similar effect (Guile will exit and display a backtrace).
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 17/23] store: database: Export transaction helpers.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (15 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 16/23] store: database: Log when aborting transactions Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:21 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 18/23] guix: http-client: Add network-error? Christopher Baines
` (5 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
* guix/store/database.scm (call-with-transaction,
call-with-retrying-transaction): Export procedures.
Change-Id: I712f0056f263989769af7cb6f9e395a43f6e36b2
---
guix/store/database.scm | 3 +++
1 file changed, 3 insertions(+)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index b6f87d710f..6c8c07e2de 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -46,6 +46,9 @@ (define-module (guix store database)
call-with-database
with-database
+ call-with-transaction
+ call-with-retrying-transaction
+
valid-path-id
register-valid-path
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 17/23] store: database: Export transaction helpers.
2024-04-21 9:42 ` [bug#70494] [PATCH 17/23] store: database: Export transaction helpers Christopher Baines
@ 2024-05-16 16:21 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:21 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> * guix/store/database.scm (call-with-transaction,
> call-with-retrying-transaction): Export procedures.
I would expect these to remain private here, with the module exporting
all the higher-level procedures to deal with the database, no?
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 18/23] guix: http-client: Add network-error?.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (16 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 17/23] store: database: Export transaction helpers Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:23 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 19/23] http-client: Include EPIPE in network-error? Christopher Baines
` (4 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
Plus remove http-get-error? from network-error? as a http-get-error? doesn't
indicate a network error.
* guix/scripts/substitute.scm (system-error?, network-error?): Move from here.
(process-substitution/fallback, process-substitution): Use http-get-error?
with network-error?.
* guix/http-client.scm: To here, and also don't use http-get-error?.
Change-Id: I61ee9e5fbf90ebb76a34aa8b9ec8f5d74f8a3c54
---
guix/http-client.scm | 23 +++++++++++++++++++++++
guix/scripts/substitute.scm | 26 ++++----------------------
2 files changed, 27 insertions(+), 22 deletions(-)
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 9138a627ac..024705e9ec 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -54,6 +54,8 @@ (define-module (guix http-client)
http-get-error-reason
http-get-error-headers
+ network-error?
+
http-fetch
http-multiple-get
@@ -75,6 +77,27 @@ (define-condition-type &http-get-error &error
(reason http-get-error-reason) ;string
(headers http-get-error-headers)) ;alist
+(define kind-and-args-exception?
+ (exception-predicate &exception-with-kind-and-args))
+
+(define (system-error? exception)
+ "Return true if EXCEPTION is a Guile 'system-error exception."
+ (and (kind-and-args-exception? exception)
+ (eq? 'system-error (exception-kind exception))))
+
+(define network-error?
+ (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))
+ (lambda (exception)
+ "Return true if EXCEPTION denotes a networking error."
+ (or (and (system-error? exception)
+ (let ((errno (system-error-errno
+ (cons 'system-error (exception-args exception)))))
+ (memv errno (list ECONNRESET ECONNABORTED ETIMEDOUT
+ ECONNREFUSED EHOSTUNREACH
+ ENOENT)))) ;for "file://"
+ (and (kind-and-args? exception)
+ (memq (exception-kind exception)
+ '(gnutls-error getaddrinfo-error)))))))
(define* (http-fetch uri #:key port (text? #f) (buffered? #t)
(open-connection guix:open-connection-for-uri)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index c2bc16085d..362d9fbe7a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -577,26 +577,6 @@ (define* (download-nar narinfo destination
(values expected
(get-hash)))))
-(define (system-error? exception)
- "Return true if EXCEPTION is a Guile 'system-error exception."
- (and (kind-and-args-exception? exception)
- (eq? 'system-error (exception-kind exception))))
-
-(define network-error?
- (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))
- (lambda (exception)
- "Return true if EXCEPTION denotes a networking error."
- (or (and (system-error? exception)
- (let ((errno (system-error-errno
- (cons 'system-error (exception-args exception)))))
- (memv errno (list ECONNRESET ECONNABORTED ETIMEDOUT
- ECONNREFUSED EHOSTUNREACH
- ENOENT)))) ;for "file://"
- (and (kind-and-args? exception)
- (memq (exception-kind exception)
- '(gnutls-error getaddrinfo-error)))
- (http-get-error? exception)))))
-
(define* (process-substitution/fallback narinfo destination
#:key cache-urls acl
deduplicate? print-build-trace?
@@ -623,7 +603,8 @@ (define* (process-substitution/fallback narinfo destination
(if (or (equivalent-narinfo? narinfo alternate)
(valid-narinfo? alternate acl)
(%allow-unauthenticated-substitutes?))
- (guard (c ((network-error? c)
+ (guard (c ((or (http-get-error? c)
+ (network-error? c))
(when (http-get-error? c)
(warning (G_ "download from '~a' failed: ~a, ~s~%")
(uri->string (http-get-error-uri c))
@@ -663,7 +644,8 @@ (define* (process-substitution store-item destination
(let ((expected-hash
actual-hash
(guard
- (c ((network-error? c)
+ (c ((or (http-get-error? c)
+ (network-error? c))
(when (http-get-error? c)
(warning (G_ "download from '~a' failed: ~a, ~s~%")
(uri->string (http-get-error-uri c))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 18/23] guix: http-client: Add network-error?.
2024-04-21 9:42 ` [bug#70494] [PATCH 18/23] guix: http-client: Add network-error? Christopher Baines
@ 2024-05-16 16:23 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:23 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> Plus remove http-get-error? from network-error? as a http-get-error? doesn't
> indicate a network error.
>
> * guix/scripts/substitute.scm (system-error?, network-error?): Move from here.
> (process-substitution/fallback, process-substitution): Use http-get-error?
> with network-error?.
> * guix/http-client.scm: To here, and also don't use http-get-error?.
>
> Change-Id: I61ee9e5fbf90ebb76a34aa8b9ec8f5d74f8a3c54
LGTM, but...
> - (guard (c ((network-error? c)
> + (guard (c ((or (http-get-error? c)
> + (network-error? c))
> (when (http-get-error? c)
> (warning (G_ "download from '~a' failed: ~a, ~s~%")
> (uri->string (http-get-error-uri c))
> @@ -663,7 +644,8 @@ (define* (process-substitution store-item destination
> (let ((expected-hash
> actual-hash
> (guard
> - (c ((network-error? c)
> + (c ((or (http-get-error? c)
> + (network-error? c))
These two hunks should probably go to a different commit, because
they’re really fixing a bug.
(The commit log subject line doesn’t need the “guix:” prefix.)
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 19/23] http-client: Include EPIPE in network-error?.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (17 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 18/23] guix: http-client: Add network-error? Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:23 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 20/23] scripts: substitute: Simplify with-timeout usage Christopher Baines
` (3 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
The substitute script checks for EPIPE errors, so this allows using
network-error?.
* guix/http-client.scm (network-error?): Include EPIPE.
Change-Id: I96d76d77997ed21a38bf9c41479fea67ab01e084
---
guix/http-client.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 024705e9ec..a8d7d25762 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -93,7 +93,7 @@ (define network-error?
(let ((errno (system-error-errno
(cons 'system-error (exception-args exception)))))
(memv errno (list ECONNRESET ECONNABORTED ETIMEDOUT
- ECONNREFUSED EHOSTUNREACH
+ ECONNREFUSED EHOSTUNREACH EPIPE
ENOENT)))) ;for "file://"
(and (kind-and-args? exception)
(memq (exception-kind exception)
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 20/23] scripts: substitute: Simplify with-timeout usage.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (18 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 19/23] http-client: Include EPIPE in network-error? Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:27 ` Ludovic Courtès
2024-04-21 9:42 ` [bug#70494] [PATCH 21/23] scripts: substitute: Don't enforce cached connections in download-nar Christopher Baines
` (2 subsequent siblings)
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
To reduce the codepaths in download-nar.
* guix/scripts/substitute.scm (with-timeout): Accept a #f duration and don't
set a timeout.
(download-nar): Remove the if for fetch-timeout.
Change-Id: I4e944a425a8612e96659dd84dd0e315012f080ab
---
guix/scripts/substitute.scm | 93 ++++++++++++++++++-------------------
1 file changed, 45 insertions(+), 48 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 362d9fbe7a..b4bb9d51ff 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -101,34 +101,37 @@ (define %random-state
(define-syntax-rule (with-timeout duration handler body ...)
"Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
again."
- (begin
- (sigaction SIGALRM
- (lambda (signum)
- (sigaction SIGALRM SIG_DFL)
- handler))
- (alarm duration)
- (call-with-values
- (lambda ()
- (let try ()
- (catch 'system-error
- (lambda ()
- body ...)
- (lambda args
- ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
- ;; because of the bug at
- ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
- ;; When that happens, try again. Note: SA_RESTART cannot be
- ;; used because of <http://bugs.gnu.org/14640>.
- (if (= EINTR (system-error-errno args))
- (begin
- ;; Wait a little to avoid bursts.
- (usleep (random 3000000 %random-state))
- (try))
- (apply throw args))))))
- (lambda result
- (alarm 0)
- (sigaction SIGALRM SIG_DFL)
- (apply values result)))))
+ (if duration
+ (begin
+ (sigaction SIGALRM
+ (lambda (signum)
+ (sigaction SIGALRM SIG_DFL)
+ handler))
+ (alarm duration)
+ (call-with-values
+ (lambda ()
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ body ...)
+ (lambda args
+ ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
+ ;; because of the bug at
+ ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
+ ;; When that happens, try again. Note: SA_RESTART cannot be
+ ;; used because of <http://bugs.gnu.org/14640>.
+ (if (= EINTR (system-error-errno args))
+ (begin
+ ;; Wait a little to avoid bursts.
+ (usleep (random 3000000 %random-state))
+ (try))
+ (apply throw args))))))
+ (lambda result
+ (alarm 0)
+ (sigaction SIGALRM SIG_DFL)
+ (apply values result))))
+ (begin
+ body ...)))
(define (at-most max-length lst)
"If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
@@ -475,26 +478,20 @@ (define* (download-nar narinfo destination
(let ((port (open-file (uri-path uri) "r0b")))
(values port (stat:size (stat port)))))
((http https)
- (if fetch-timeout
- ;; Test this with:
- ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
- ;; and then cancel with:
- ;; sudo tc qdisc del dev eth0 root
- (with-timeout %fetch-timeout
- (begin
- (warning (G_ "while fetching ~a: server is somewhat slow~%")
- (uri->string uri))
- (warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (with-cached-connection uri port
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f)))
- (with-cached-connection uri port
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f))))
+ ;; Test this with:
+ ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
+ ;; and then cancel with:
+ ;; sudo tc qdisc del dev eth0 root
+ (with-timeout fetch-timeout
+ (begin
+ (warning (G_ "while fetching ~a: server is somewhat slow~%")
+ (uri->string uri))
+ (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+ (with-cached-connection uri port
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f))))
(else
(raise
(formatted-message
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 20/23] scripts: substitute: Simplify with-timeout usage.
2024-04-21 9:42 ` [bug#70494] [PATCH 20/23] scripts: substitute: Simplify with-timeout usage Christopher Baines
@ 2024-05-16 16:27 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:27 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
Christopher Baines <mail@cbaines.net> skribis:
> To reduce the codepaths in download-nar.
>
> * guix/scripts/substitute.scm (with-timeout): Accept a #f duration and don't
> set a timeout.
> (download-nar): Remove the if for fetch-timeout.
>
> Change-Id: I4e944a425a8612e96659dd84dd0e315012f080ab
[...]
> (define-syntax-rule (with-timeout duration handler body ...)
> "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
> again."
The docstring needs updating.
> + (if duration
> + (begin
> + (sigaction SIGALRM
> + (lambda (signum)
> + (sigaction SIGALRM SIG_DFL)
> + handler))
> + (alarm duration)
> + (call-with-values
> + (lambda ()
> + (let try ()
> + (catch 'system-error
> + (lambda ()
> + body ...)
> + (lambda args
> + ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
> + ;; because of the bug at
> + ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
> + ;; When that happens, try again. Note: SA_RESTART cannot be
> + ;; used because of <http://bugs.gnu.org/14640>.
> + (if (= EINTR (system-error-errno args))
> + (begin
> + ;; Wait a little to avoid bursts.
> + (usleep (random 3000000 %random-state))
> + (try))
> + (apply throw args))))))
> + (lambda result
> + (alarm 0)
> + (sigaction SIGALRM SIG_DFL)
> + (apply values result))))
> + (begin
> + body ...)))
To avoid code bloat due to expanding BODY twice, I think this should be
something like:
(let ((thunk (lambda () body ...)))
(if duration
…
(thunk)))
Otherwise LGTM.
^ permalink raw reply [flat|nested] 45+ messages in thread
* [bug#70494] [PATCH 21/23] scripts: substitute: Don't enforce cached connections in download-nar.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (19 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 20/23] scripts: substitute: Simplify with-timeout usage Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-04-21 9:42 ` [bug#70494] [PATCH 22/23] substitutes: Move download-nar from substitutes script to here Christopher Baines
2024-04-21 9:42 ` [bug#70494] [PATCH 23/23] substitutes: Add #:keep-alive? keyword argument to download-nar Christopher Baines
22 siblings, 0 replies; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
This is in preparation for moving the download-nar procedure out of the
script.
As well as calling open-connection-for-uri/cached, with-cached-connection adds
a single retry to the expression passed in, in the case of a exception that
suggests there's a problem with the cached connection. This is important
because download-nar/http-fetch doesn't check if a connection used for
multiple requests should be closed (because the servers set the relevant
response header).
To make download-nar more generic, have it take open-connection-for-uri as a
keyword argument, and replicate the with-cached-connection single retry by
closing the port in the case of a network error, and recalling
open-connection-for-uri. This will work fine in the case when connection
caching is not in use, as well as when open-connection-for-uri/cached is used,
since open-connection-for-uri/cached will open a new connection if the cached
port is closed.
* guix/scripts/substitute.scm (kind-and-args-exception?): Remove and inline
where necessary.
(call-with-cached-connection): Remove procedure.
(with-cached-connection): Remove syntax rule.
(http-response-error?): New procedure.
(download-nar): Add new #:open-connection-for-uri keyword argument and use it,
also replace with-cached-connection.
(process-substitution/fallback,process-substitution): Pass
#:open-connection-for-uri open-connection-for-uri/cached to download-nar.
Change-Id: I277b1d8dfef79aa1711755b10b9944da7c19157c
---
guix/scripts/substitute.scm | 84 +++++++++++++++----------------------
1 file changed, 33 insertions(+), 51 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index b4bb9d51ff..38975ec366 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -410,55 +410,25 @@ (define open-connection-for-uri/cached
(drain-input socket)
socket))))))))
-(define kind-and-args-exception?
- (exception-predicate &exception-with-kind-and-args))
-
-(define (call-with-cached-connection uri proc)
- (let ((port (open-connection-for-uri/cached uri
- #:verify-certificate? #f)))
- (guard (c ((kind-and-args-exception? c)
- (let ((key (exception-kind c))
- (args (exception-args c)))
- ;; If PORT was cached and the server closed the connection in the
- ;; meantime, we get EPIPE. In that case, open a fresh connection
- ;; and retry. We might also get 'bad-response or a similar
- ;; exception from (web response) later on, once we've sent the
- ;; request, or a ERROR/INVALID-SESSION from GnuTLS.
- (if (or (and (eq? key 'system-error)
- (= EPIPE (system-error-errno `(,key ,@args))))
- (and (eq? key 'gnutls-error)
- (memq (first args)
- (list error/invalid-session
-
- ;; XXX: These two are not properly handled in
- ;; GnuTLS < 3.7.3, in
- ;; 'write_to_session_record_port'; see
- ;; <https://bugs.gnu.org/47867>.
- error/again error/interrupted)))
- (memq key '(bad-response bad-header bad-header-component)))
- (proc (open-connection-for-uri/cached uri
- #:verify-certificate? #f
- #:fresh? #t))
- (raise c))))
- (#t
- ;; An exception that's not handled here, such as
- ;; '&http-get-error'. Re-raise it.
- (raise c)))
- (proc port))))
-
-(define-syntax-rule (with-cached-connection uri port exp ...)
- "Bind PORT with EXP... to a socket connected to URI."
- (call-with-cached-connection uri (lambda (port) exp ...)))
-
(define-syntax-rule (catch-system-error exp)
(catch 'system-error
(lambda () exp)
(const #f)))
+(define http-response-error?
+ (let ((kind-and-args-exception?
+ (exception-predicate &exception-with-kind-and-args)))
+ (lambda (exception)
+ "Return true if EXCEPTION denotes an error with the http response"
+ (->bool
+ (memq (exception-kind exception)
+ '(bad-response bad-header bad-header-component))))))
+
(define* (download-nar narinfo destination
#:key deduplicate? print-build-trace?
(fetch-timeout %fetch-timeout)
- prefer-fast-decompression?)
+ prefer-fast-decompression?
+ (open-connection-for-uri guix:open-connection-for-uri))
"Download the nar prescribed in NARINFO, which is assumed to be authentic
and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
if DESTINATION is in the store, deduplicate its files."
@@ -487,11 +457,22 @@ (define* (download-nar narinfo destination
(warning (G_ "while fetching ~a: server is somewhat slow~%")
(uri->string uri))
(warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (with-cached-connection uri port
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f))))
+ (let loop ((port (open-connection-for-uri uri))
+ (attempt 0))
+ (guard (c ((or (network-error? c)
+ (http-response-error? c))
+ (close-port port)
+
+ ;; Perform a single retry in the case of an error,
+ ;; mostly to mimic the behaviour of
+ ;; with-cached-connection
+ (if (= attempt 0)
+ (loop (open-connection-for-uri uri) 1)
+ (raise c))))
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f)))))
(else
(raise
(formatted-message
@@ -612,7 +593,9 @@ (define* (process-substitution/fallback narinfo destination
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
#:prefer-fast-decompression?
- prefer-fast-decompression?))
+ prefer-fast-decompression?
+ #:open-connection-for-uri
+ open-connection-for-uri/cached))
(loop rest)))
(()
(loop rest)))))))
@@ -663,7 +646,9 @@ (define* (process-substitution store-item destination
(download-nar narinfo destination
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?
- #:prefer-fast-decompression? prefer-fast-decompression?))))
+ #:prefer-fast-decompression? prefer-fast-decompression?
+ #:open-connection-for-uri
+ open-connection-for-uri/cached))))
(values narinfo
expected-hash
actual-hash)))
@@ -930,10 +915,7 @@ (define-command (guix-substitute . args)
(leave (G_ "~a: unrecognized options~%") opts))))))
;;; Local Variables:
-;;; eval: (put 'with-timeout 'scheme-indent-function 1)
;;; eval: (put 'with-redirected-error-port 'scheme-indent-function 0)
-;;; eval: (put 'with-cached-connection 'scheme-indent-function 2)
-;;; eval: (put 'call-with-cached-connection 'scheme-indent-function 1)
;;; End:
;;; substitute.scm ends here
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 22/23] substitutes: Move download-nar from substitutes script to here.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (20 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 21/23] scripts: substitute: Don't enforce cached connections in download-nar Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-04-21 9:42 ` [bug#70494] [PATCH 23/23] substitutes: Add #:keep-alive? keyword argument to download-nar Christopher Baines
22 siblings, 0 replies; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
From the substitutes script. This makes it possible to use download-nar in
the the Guile guix-daemon.
* guix/scripts/substitute.scm (%fetch-timeout): Move down to where it's now
used.
(%random-state, with-timeout, catch-system-error, http-response-error?,
download-nar): Move to…
* guix/substitutes.scm: …here.
Change-Id: I8c09bf4b33cb5c6d042057d4d9adeb36c24c11dc
---
guix/scripts/substitute.scm | 195 +---------------------------------
guix/substitutes.scm | 206 +++++++++++++++++++++++++++++++++++-
2 files changed, 207 insertions(+), 194 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 38975ec366..c74da618b5 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -31,7 +31,6 @@ (define-module (guix scripts substitute)
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module ((guix serialization) #:select (restore-file dump-file))
- #:autoload (guix store deduplication) (dump-file/deduplicate)
#:autoload (guix scripts discover) (read-substitute-urls)
#:use-module (gcrypt hash)
#:use-module (guix base32)
@@ -40,10 +39,9 @@ (define-module (guix scripts substitute)
#:use-module (guix pki)
#:autoload (guix build utils) (mkdir-p delete-file-recursively)
#:use-module ((guix build download)
- #:select (uri-abbreviation nar-uri-abbreviation
+ #:select (uri-abbreviation
(open-connection-for-uri
. guix:open-connection-for-uri)))
- #:autoload (gnutls) (error/invalid-session error/again error/interrupted)
#:use-module (guix progress)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
@@ -91,48 +89,6 @@ (define %allow-unauthenticated-substitutes?
(and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
(cut string-ci=? <> "yes"))))
-(define %fetch-timeout
- ;; Number of seconds after which networking is considered "slow".
- 5)
-
-(define %random-state
- (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
-
-(define-syntax-rule (with-timeout duration handler body ...)
- "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
-again."
- (if duration
- (begin
- (sigaction SIGALRM
- (lambda (signum)
- (sigaction SIGALRM SIG_DFL)
- handler))
- (alarm duration)
- (call-with-values
- (lambda ()
- (let try ()
- (catch 'system-error
- (lambda ()
- body ...)
- (lambda args
- ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
- ;; because of the bug at
- ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
- ;; When that happens, try again. Note: SA_RESTART cannot be
- ;; used because of <http://bugs.gnu.org/14640>.
- (if (= EINTR (system-error-errno args))
- (begin
- ;; Wait a little to avoid bursts.
- (usleep (random 3000000 %random-state))
- (try))
- (apply throw args))))))
- (lambda result
- (alarm 0)
- (sigaction SIGALRM SIG_DFL)
- (apply values result))))
- (begin
- body ...)))
-
(define (at-most max-length lst)
"If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail."
@@ -365,6 +321,10 @@ (define %max-cached-connections
;; 'open-connection-for-uri/cached'.
16)
+(define %fetch-timeout
+ ;; Number of seconds after which networking is considered "slow".
+ 5)
+
(define open-connection-for-uri/cached
(let ((cache '()))
(lambda* (uri #:key fresh? (timeout %fetch-timeout) verify-certificate?)
@@ -410,151 +370,6 @@ (define open-connection-for-uri/cached
(drain-input socket)
socket))))))))
-(define-syntax-rule (catch-system-error exp)
- (catch 'system-error
- (lambda () exp)
- (const #f)))
-
-(define http-response-error?
- (let ((kind-and-args-exception?
- (exception-predicate &exception-with-kind-and-args)))
- (lambda (exception)
- "Return true if EXCEPTION denotes an error with the http response"
- (->bool
- (memq (exception-kind exception)
- '(bad-response bad-header bad-header-component))))))
-
-(define* (download-nar narinfo destination
- #:key deduplicate? print-build-trace?
- (fetch-timeout %fetch-timeout)
- prefer-fast-decompression?
- (open-connection-for-uri guix:open-connection-for-uri))
- "Download the nar prescribed in NARINFO, which is assumed to be authentic
-and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
-if DESTINATION is in the store, deduplicate its files."
- (define destination-in-store?
- (string-prefix? (string-append (%store-prefix) "/")
- destination))
-
- (define (dump-file/deduplicate* . args)
- ;; Make sure deduplication looks at the right store (necessary in test
- ;; environments).
- (apply dump-file/deduplicate
- (append args (list #:store (%store-prefix)))))
-
- (define (fetch uri)
- (case (uri-scheme uri)
- ((file)
- (let ((port (open-file (uri-path uri) "r0b")))
- (values port (stat:size (stat port)))))
- ((http https)
- ;; Test this with:
- ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
- ;; and then cancel with:
- ;; sudo tc qdisc del dev eth0 root
- (with-timeout fetch-timeout
- (begin
- (warning (G_ "while fetching ~a: server is somewhat slow~%")
- (uri->string uri))
- (warning (G_ "try `--no-substitutes' if the problem persists~%")))
- (let loop ((port (open-connection-for-uri uri))
- (attempt 0))
- (guard (c ((or (network-error? c)
- (http-response-error? c))
- (close-port port)
-
- ;; Perform a single retry in the case of an error,
- ;; mostly to mimic the behaviour of
- ;; with-cached-connection
- (if (= attempt 0)
- (loop (open-connection-for-uri uri) 1)
- (raise c))))
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f)))))
- (else
- (raise
- (formatted-message
- (G_ "unsupported substitute URI scheme: ~a~%")
- (uri->string uri))))))
-
- (define (try-fetch choices)
- (match choices
- (((uri compression file-size) rest ...)
- (guard (c ((and (pair? rest)
- (or (http-get-error? c)
- (network-error? c)))
- (warning (G_ "download from '~a' failed, trying next URL~%")
- (uri->string uri))
- (try-fetch rest)))
- (let ((port download-size (fetch uri)))
- (unless print-build-trace?
- (format (current-error-port)
- (G_ "Downloading ~a...~%") (uri->string uri)))
- (values port uri compression download-size))))
- (()
- (raise
- (formatted-message
- (G_ "no valid nar URLs for ~a at ~a~%")
- (narinfo-path narinfo)
- (narinfo-uri-base narinfo))))))
-
- ;; Delete DESTINATION first--necessary when starting over after a failed
- ;; download.
- (catch-system-error (delete-file-recursively destination))
-
- (let ((choices (narinfo-preferred-uris narinfo
- #:fast-decompression?
- prefer-fast-decompression?)))
- ;; 'guix publish' without '--cache' doesn't specify a Content-Length, so
- ;; DOWNLOAD-SIZE is #f in this case.
- (let* ((raw uri compression download-size (try-fetch choices))
- (progress
- (let* ((dl-size (or download-size
- (and (equal? compression "none")
- (narinfo-size narinfo))))
- (reporter (if print-build-trace?
- (progress-reporter/trace
- destination
- (uri->string uri) dl-size
- (current-error-port))
- (progress-reporter/file
- (uri->string uri) dl-size
- (current-error-port)
- #:abbreviation nar-uri-abbreviation))))
- ;; Keep RAW open upon completion so we can later reuse
- ;; the underlying connection. Pass the download size so
- ;; that this procedure won't block reading from RAW.
- (progress-report-port reporter raw
- #:close? #f
- #:download-size dl-size)))
- (input pids
- ;; NOTE: This 'progress' port of current process will be
- ;; closed here, while the child process doing the
- ;; reporting will close it upon exit.
- (decompressed-port (string->symbol compression)
- progress))
-
- ;; Compute the actual nar hash as we read it.
- (algorithm expected (narinfo-hash-algorithm+value narinfo))
- (hashed get-hash (open-hash-input-port algorithm input)))
-
- ;; Unpack the Nar at INPUT into DESTINATION.
- (restore-file hashed destination
- #:dump-file (if (and destination-in-store?
- deduplicate?)
- dump-file/deduplicate*
- dump-file))
- (close-port hashed)
- (close-port input)
-
- ;; Wait for the reporter to finish.
- (every (compose zero? cdr waitpid) pids)
-
- (values expected
- (get-hash)))))
-
(define* (process-substitution/fallback narinfo destination
#:key cache-urls acl
deduplicate? print-build-trace?
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index e732096933..5089f3a6da 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -30,12 +30,18 @@ (define-module (guix substitutes)
#:use-module (gcrypt hash)
#:use-module (guix base32)
#:use-module (guix cache)
- #:use-module ((guix build utils) #:select (mkdir-p dump-port))
+ #:use-module ((guix build utils)
+ #:select (mkdir-p dump-port delete-file-recursively))
#:use-module ((guix build download)
#:select ((open-connection-for-uri
. guix:open-connection-for-uri)
- resolve-uri-reference))
- #:autoload (gnutls) (error->string error/premature-termination)
+ resolve-uri-reference
+ nar-uri-abbreviation))
+ #:use-module ((guix serialization) #:select (restore-file dump-file))
+ #:autoload (gnutls) (error->string error/premature-termination
+ error/invalid-session error/again
+ error/interrupted)
+ #:autoload (guix store deduplication) (dump-file/deduplicate)
#:use-module (guix progress)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
@@ -46,6 +52,8 @@ (define-module (guix substitutes)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-71)
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
@@ -55,7 +63,10 @@ (define-module (guix substitutes)
call-with-connection-error-handling
lookup-narinfos
- lookup-narinfos/diverse))
+ lookup-narinfos/diverse
+
+ http-response-error?
+ download-nar))
(define %narinfo-ttl
;; Number of seconds during which cached narinfo lookups are considered
@@ -391,4 +402,191 @@ (define* (lookup-narinfos/diverse caches paths authorized?
(() ;that's it
(filter-map (select-hit result) hits)))))))
+(define %random-state
+ (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
+
+(define-syntax-rule (with-timeout duration handler body ...)
+ "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
+again."
+ (if duration
+ (begin
+ (sigaction SIGALRM
+ (lambda (signum)
+ (sigaction SIGALRM SIG_DFL)
+ handler))
+ (alarm duration)
+ (call-with-values
+ (lambda ()
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ body ...)
+ (lambda args
+ ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
+ ;; because of the bug at
+ ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
+ ;; When that happens, try again. Note: SA_RESTART cannot be
+ ;; used because of <http://bugs.gnu.org/14640>.
+ (if (= EINTR (system-error-errno args))
+ (begin
+ ;; Wait a little to avoid bursts.
+ (usleep (random 3000000 %random-state))
+ (try))
+ (apply throw args))))))
+ (lambda result
+ (alarm 0)
+ (sigaction SIGALRM SIG_DFL)
+ (apply values result))))
+ (begin
+ body ...)))
+
+(define-syntax-rule (catch-system-error exp)
+ (catch 'system-error
+ (lambda () exp)
+ (const #f)))
+
+(define http-response-error?
+ (let ((kind-and-args-exception?
+ (exception-predicate &exception-with-kind-and-args)))
+ (lambda (exception)
+ "Return true if EXCEPTION denotes an error with the http response"
+ (->bool
+ (memq (exception-kind exception)
+ '(bad-response bad-header bad-header-component))))))
+
+(define %fetch-timeout
+ ;; Number of seconds after which networking is considered "slow".
+ 5)
+
+(define* (download-nar narinfo destination
+ #:key deduplicate? print-build-trace?
+ (fetch-timeout %fetch-timeout)
+ prefer-fast-decompression?
+ (open-connection-for-uri guix:open-connection-for-uri))
+ "Download the nar prescribed in NARINFO, which is assumed to be authentic
+and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
+if DESTINATION is in the store, deduplicate its files."
+ (define destination-in-store?
+ (string-prefix? (string-append (%store-prefix) "/")
+ destination))
+
+ (define (dump-file/deduplicate* . args)
+ ;; Make sure deduplication looks at the right store (necessary in test
+ ;; environments).
+ (apply dump-file/deduplicate
+ (append args (list #:store (%store-prefix)))))
+
+ (define (fetch uri)
+ (case (uri-scheme uri)
+ ((file)
+ (let ((port (open-file (uri-path uri) "r0b")))
+ (values port (stat:size (stat port)))))
+ ((http https)
+ ;; Test this with:
+ ;; sudo tc qdisc add dev eth0 root netem delay 1500ms
+ ;; and then cancel with:
+ ;; sudo tc qdisc del dev eth0 root
+ (with-timeout fetch-timeout
+ (begin
+ (warning (G_ "while fetching ~a: server is somewhat slow~%")
+ (uri->string uri))
+ (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+ (let loop ((port (open-connection-for-uri uri))
+ (attempt 0))
+ (guard (c ((or (network-error? c)
+ (http-response-error? c))
+ (close-port port)
+
+ ;; Perform a single retry in the case of an error,
+ ;; mostly to mimic the behaviour of
+ ;; with-cached-connection
+ (if (= attempt 0)
+ (loop (open-connection-for-uri uri) 1)
+ (raise c))))
+ (http-fetch uri #:text? #f
+ #:port port
+ #:keep-alive? #t
+ #:buffered? #f)))))
+ (else
+ (raise
+ (formatted-message
+ (G_ "unsupported substitute URI scheme: ~a~%")
+ (uri->string uri))))))
+
+ (define (try-fetch choices)
+ (match choices
+ (((uri compression file-size) rest ...)
+ (guard (c ((and (pair? rest)
+ (or (http-get-error? c)
+ (network-error? c)))
+ (warning (G_ "download from '~a' failed, trying next URL~%")
+ (uri->string uri))
+ (try-fetch rest)))
+ (let ((port download-size (fetch uri)))
+ (unless print-build-trace?
+ (format (current-error-port)
+ (G_ "Downloading ~a...~%") (uri->string uri)))
+ (values port uri compression download-size))))
+ (()
+ (raise
+ (formatted-message
+ (G_ "no valid nar URLs for ~a at ~a~%")
+ (narinfo-path narinfo)
+ (narinfo-uri-base narinfo))))))
+
+ ;; Delete DESTINATION first--necessary when starting over after a failed
+ ;; download.
+ (catch-system-error (delete-file-recursively destination))
+
+ (let ((choices (narinfo-preferred-uris narinfo
+ #:fast-decompression?
+ prefer-fast-decompression?)))
+ ;; 'guix publish' without '--cache' doesn't specify a Content-Length, so
+ ;; DOWNLOAD-SIZE is #f in this case.
+ (let* ((raw uri compression download-size (try-fetch choices))
+ (progress
+ (let* ((dl-size (or download-size
+ (and (equal? compression "none")
+ (narinfo-size narinfo))))
+ (reporter (if print-build-trace?
+ (progress-reporter/trace
+ destination
+ (uri->string uri) dl-size
+ (current-error-port))
+ (progress-reporter/file
+ (uri->string uri) dl-size
+ (current-error-port)
+ #:abbreviation nar-uri-abbreviation))))
+ ;; Keep RAW open upon completion so we can later reuse
+ ;; the underlying connection. Pass the download size so
+ ;; that this procedure won't block reading from RAW.
+ (progress-report-port reporter raw
+ #:close? #f
+ #:download-size dl-size)))
+ (input pids
+ ;; NOTE: This 'progress' port of current process will be
+ ;; closed here, while the child process doing the
+ ;; reporting will close it upon exit.
+ (decompressed-port (string->symbol compression)
+ progress))
+
+ ;; Compute the actual nar hash as we read it.
+ (algorithm expected (narinfo-hash-algorithm+value narinfo))
+ (hashed get-hash (open-hash-input-port algorithm input)))
+
+ ;; Unpack the Nar at INPUT into DESTINATION.
+ (restore-file hashed destination
+ #:dump-file (if (and destination-in-store?
+ deduplicate?)
+ dump-file/deduplicate*
+ dump-file))
+ (close-port hashed)
+ (close-port input)
+
+ ;; Wait for the reporter to finish.
+ (every (compose zero? cdr waitpid) pids)
+
+ (values expected
+ (get-hash)))))
+
;;; substitutes.scm ends here
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 23/23] substitutes: Add #:keep-alive? keyword argument to download-nar.
2024-04-21 9:35 [bug#70494] [PATCH 00/23] Groundwork for the Guile guix-daemon Christopher Baines
` (21 preceding siblings ...)
2024-04-21 9:42 ` [bug#70494] [PATCH 22/23] substitutes: Move download-nar from substitutes script to here Christopher Baines
@ 2024-04-21 9:42 ` Christopher Baines
2024-05-16 16:29 ` Ludovic Courtès
22 siblings, 1 reply; 45+ messages in thread
From: Christopher Baines @ 2024-04-21 9:42 UTC (permalink / raw)
To: 70494
Cc: Christopher Baines, Josselin Poiret, Ludovic Courtès,
Mathieu Othacehe, Ricardo Wurmus, Simon Tournier,
Tobias Geerinckx-Rice
To be consistent with other procedures that make network requests.
* guix/substitutes.scm (download-nar): Add #:keep-alive? option.
* guix/scripts/substitute.scm (process-substitution/fallback,
process-substitution): Call download-nar with #:keep-alive? #t.
Change-Id: I83b27d0c3a0916d058fbbbeb7aa77dbb8a742768
---
guix/scripts/substitute.scm | 6 ++++--
guix/substitutes.scm | 11 +++++++++--
2 files changed, 13 insertions(+), 4 deletions(-)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index c74da618b5..68c24820c6 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -410,7 +410,8 @@ (define* (process-substitution/fallback narinfo destination
#:prefer-fast-decompression?
prefer-fast-decompression?
#:open-connection-for-uri
- open-connection-for-uri/cached))
+ open-connection-for-uri/cached
+ #:keep-alive? #t))
(loop rest)))
(()
(loop rest)))))))
@@ -463,7 +464,8 @@ (define* (process-substitution store-item destination
#:print-build-trace? print-build-trace?
#:prefer-fast-decompression? prefer-fast-decompression?
#:open-connection-for-uri
- open-connection-for-uri/cached))))
+ open-connection-for-uri/cached
+ #:keep-alive? #t))))
(values narinfo
expected-hash
actual-hash)))
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index 5089f3a6da..7c8f8cc973 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -462,7 +462,8 @@ (define* (download-nar narinfo destination
#:key deduplicate? print-build-trace?
(fetch-timeout %fetch-timeout)
prefer-fast-decompression?
- (open-connection-for-uri guix:open-connection-for-uri))
+ (open-connection-for-uri guix:open-connection-for-uri)
+ (keep-alive? #f))
"Download the nar prescribed in NARINFO, which is assumed to be authentic
and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and
if DESTINATION is in the store, deduplicate its files."
@@ -505,7 +506,7 @@ (define* (download-nar narinfo destination
(raise c))))
(http-fetch uri #:text? #f
#:port port
- #:keep-alive? #t
+ #:keep-alive? keep-alive?
#:buffered? #f)))))
(else
(raise
@@ -586,6 +587,12 @@ (define* (download-nar narinfo destination
;; Wait for the reporter to finish.
(every (compose zero? cdr waitpid) pids)
+ ;; TODO The port should also be closed if the relevant HTTP response
+ ;; header is set, but http-fetch doesn't currently share that
+ ;; information
+ (unless keep-alive?
+ (close-port raw))
+
(values expected
(get-hash)))))
--
2.41.0
^ permalink raw reply related [flat|nested] 45+ messages in thread* [bug#70494] [PATCH 23/23] substitutes: Add #:keep-alive? keyword argument to download-nar.
2024-04-21 9:42 ` [bug#70494] [PATCH 23/23] substitutes: Add #:keep-alive? keyword argument to download-nar Christopher Baines
@ 2024-05-16 16:29 ` Ludovic Courtès
0 siblings, 0 replies; 45+ messages in thread
From: Ludovic Courtès @ 2024-05-16 16:29 UTC (permalink / raw)
To: Christopher Baines
Cc: Josselin Poiret, 70494, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Ricardo Wurmus, Christopher Baines
I’m skipping patches 21–23 around ‘download-nar’. Let’s postpone those
if you don’t mind!
If you prefer (I think I would), perhaps we can further decompose that.
For example, there were bits about the protocol itself that could be
treated in a patch series of their own.
Anyway, exciting stuff in here, thank you!
Ludo’.
^ permalink raw reply [flat|nested] 45+ messages in thread