[PATCH 00/23] Groundwork for the Guile guix-daemon

+++ b/guix/build/syscalls.scm

+ initialize-loopback

+ (read-utmpx-from-port . read-utmpx)

+ personality

+ ADDR_NO_RANDOMIZE

+ setdomainname

+ UNAME26

+ PER_LINUX32))

+(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)))))

+

+;; 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)))))

+

+++ b/gnu/build/linux-container.scm

+ ;; 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))))

+

+++ b/guix/build/syscalls.scm

+ MS_PRIVATE

+ MS_REC

+(define MS_PRIVATE 262144)

+++ b/guix/store/database.scm

+ #:use-module (guix serialization)

+ #:use-module (guix store)

+ #:use-module (guix derivations)

+ register-derivation-outputs

+ registered-derivation-outputs

+(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))))

+

+ (when (derivation-path? path)

+ (register-derivation-outputs db

+ (read-derivation-from-file

+ path)))

+

+(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)))

+

+++ b/guix/serialization.scm

+ read-string read-byte-string

+ read-latin1-string read-maybe-utf8-string

+++ b/guix/store.scm

+ validate-store-name

+(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)

+

+++ b/guix/store.scm

+(define-public %protocol-version #x164)

+(define-public %worker-magic-1 #x6e697863) ; "nixc"

+(define-public %worker-magic-2 #x6478696f) ; "dxio"

+(define-public (protocol-major magic)

+(define-public (protocol-minor magic)

+(define-public (protocol-version 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

+

+++ b/Makefile.am

+ guix/store/environment.scm \

+ guix/store/build-derivations.scm

+++ b/guix/store/build-derivations.scm

+;;; 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))

+++ b/guix/store.scm

+ text-output-path

+ text-output-path-from-hash

+(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))

+

+++ b/guix/scripts/perform-download.scm

+ #:use-module ((guix store) #:select (%store-prefix derivation-path?

+ store-path?))

+ (and=> (getenv "GUIX_STORE_DIRECTORY")

+ %store-prefix)

+

+++ b/guix/scripts/substitute.scm

+;; Whether to initially prefer fast decompression or not

+(define %default-prefer-fast-decompression? #f)

+

+(define (call-with-cpu-usage-monitoring thunk)

+ (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.))))))))))

+ %default-prefer-fast-decompression?)))

+ (fetch-timeout %fetch-timeout)

+ prefer-fast-decompression?)

+ prefer-fast-decompression?)))

+ ;; Unpack the Nar at INPUT into DESTINATION.

+ (restore-file hashed destination

+ #:dump-file (if (and destination-in-store?

+ deduplicate?)

+ dump-file/deduplicate*

+ dump-file))

+ deduplicate? print-build-trace?

+ prefer-fast-decompression?)

+ #:print-build-trace? print-build-trace?

+ #:prefer-fast-decompression?

+ prefer-fast-decompression?))

+ deduplicate? print-build-trace?

+ prefer-fast-decompression?)

+ print-build-trace?

+ #:prefer-fast-decompression?

+ prefer-fast-decompression?)))

+ #:print-build-trace? print-build-trace?

+ #:prefer-fast-decompression? prefer-fast-decompression?)))

+ (let loop ((prefer-fast-decompression?

+ %default-prefer-fast-decompression?))

+ (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?)))))))))

+++ b/guix/store.scm

+ operation-id

+

+++ b/guix/build/syscalls.scm

+ #:use-module (srfi srfi-71)

+ unshare

+(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))))))))

+

+++ b/guix/store/database.scm

+ call-with-transaction

+ call-with-retrying-transaction

+

+++ b/guix/store/database.scm

+ valid-path

+ all-valid-paths

+ valid-path-from-hash-part

+ all-transitive-inputs

+ valid-path-references))

+(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 (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)))

+++ b/guix/store/database.scm

+ (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))))

+++ b/Makefile.am

+ guix/store/roots.scm \

+ guix/store/environment.scm

+++ b/guix/store.scm

+ compressed-hash

+++ b/guix/store/database.scm

+ #:use-module (ice-9 vlist)

+ #:use-module (system foreign)

+ vacuum-database

+ outputs-exist?

+ file-closure

+ all-transitive-inputs))

+

+(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)))))

+++ b/guix/store/environment.scm

+;;; 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

+

+++ b/guix/http-client.scm

+ ECONNREFUSED EHOSTUNREACH EPIPE

+++ b/guix/scripts/substitute.scm

+ #:key deduplicate? print-build-trace?

+if DESTINATION is in the store, deduplicate its files."

+ (values expected

+ (get-hash)))))

+(define* (process-substitution/fallback narinfo destination

+ ;; Failure, so return two values like download-nar

+ (values #f #f))

+(define* (process-substitution store-item destination

+ (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)))

+ (let ((narinfo

+ expected-hash

+ actual-hash

+ cpu-usage

+ store-path destination

+ (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?)))))))))

+++ b/guix/http-client.scm

+ network-error?

+

+(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)))))))

+++ b/guix/scripts/substitute.scm

+ (guard (c ((or (http-get-error? c)

+ (network-error? c))

+ (c ((or (http-get-error? c)

+ (network-error? c))

+++ b/guix/scripts/substitute.scm

+ (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 ...)))

+ ;; 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))))

+++ b/guix/scripts/substitute.scm

+(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))))))

+

+ prefer-fast-decompression?

+ (open-connection-for-uri guix:open-connection-for-uri))

+ (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)))))

+ prefer-fast-decompression?

+ #:open-connection-for-uri

+ open-connection-for-uri/cached))

+ #:prefer-fast-decompression? prefer-fast-decompression?

+ #:open-connection-for-uri

+ open-connection-for-uri/cached))))

+++ b/guix/scripts/substitute.scm

+ open-connection-for-uri/cached

+ #:keep-alive? #t))

+ open-connection-for-uri/cached

+ #:keep-alive? #t))))

+++ b/guix/substitutes.scm

+ (open-connection-for-uri guix:open-connection-for-uri)

+ (keep-alive? #f))

+ #:keep-alive? keep-alive?

+ ;; 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))

+

+++ b/guix/scripts/substitute.scm

+ #:select (uri-abbreviation

+(define %fetch-timeout

+ ;; Number of seconds after which networking is considered "slow".

+ 5)

+

+++ b/guix/substitutes.scm

+ #:use-module ((guix build utils)

+ #:select (mkdir-p dump-port delete-file-recursively))

+ 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 (srfi srfi-34)

+ #:use-module (srfi srfi-71)

+ lookup-narinfos/diverse

+

+ http-response-error?

+ download-nar))

+(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)

+