grafts: Avoid 'query-valid-derivers' RPC.

Previously we'd make 502 'query-valid-derivers' RPCs for
"guix build vim -d", and after this patch, we don't do any.

Furthermore, the previous strategy was "stateful" in the sense that
'item->deriver' could return a derivation that is not the one that was
actually computed by this process, but an "equivalent" one (due to
fixed-output derivations); which one is chosen would depend on the state
of the store.

This in turn means that we'd have to call 'read-derivation-from-file' to
actually read .drv files (as opposed to getting them from
%DERIVATION-CACHE).  This is costly and doesn't work with
GUIX_DAEMON_SOCKET=ssh://….

* guix/grafts.scm (item->deriver): Remove.
(reference-origin): New procedure.
(cumulative-grafts): Use it instead of 'item->deriver'.
This commit is contained in:
Ludovic Courtès 2019-06-19 21:50:45 +02:00
parent 2ef22a9f37
commit aad086d871
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -22,9 +22,9 @@ (define-module (guix grafts)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
#:use-module (guix sets)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (ice-9 match)
@ -151,21 +151,6 @@ (define properties
#:substitutable? #f
#:properties properties)))))
(define (item->deriver store item)
"Return two values: the derivation that led to ITEM (a store item), and the
name of the output of that derivation ITEM corresponds to (for example
\"out\"). When ITEM has no deriver, for instance because it is a plain file,
#f and #f are returned."
(match (valid-derivers store item)
(() ;ITEM is a plain file
(values #f #f))
((drv-file _ ...)
(let ((drv (read-derivation-from-file drv-file)))
(values drv
(any (match-lambda
((name . path)
(and (string=? item path) name)))
(derivation->output-paths drv)))))))
(define (non-self-references references drv outputs)
"Return the list of references of the OUTPUTS of DRV, excluding self
@ -230,6 +215,33 @@ (define-syntax-rule (with-cache key exp ...)
(set-current-state (vhash-cons key result cache))
(return result)))))))
(define (reference-origin drv item)
"Return the derivation/output pair among the inputs of DRV, recursively,
that produces ITEM. Return #f if ITEM is not produced by a derivation (i.e.,
it's a content-addressed \"source\"), or if it's not produced by a dependency
of DRV."
;; Perform a breadth-first traversal of the dependency graph of DRV in
;; search of the derivation that produces ITEM.
(let loop ((drv (list drv))
(visited (setq)))
(match drv
(()
#f)
((drv . rest)
(if (set-contains? visited drv)
(loop rest visited)
(let ((inputs (derivation-inputs drv)))
(or (any (lambda (input)
(let ((drv (derivation-input-derivation input)))
(any (match-lambda
((output . file)
(and (string=? file item)
(cons drv output))))
(derivation->output-paths drv))))
inputs)
(loop (append rest (map derivation-input-derivation inputs))
(set-insert drv visited)))))))))
(define* (cumulative-grafts store drv grafts
references
#:key
@ -257,16 +269,17 @@ (define (graft-origin? drv graft)
#f)))
(define (dependency-grafts item)
(let-values (((drv output) (item->deriver store item)))
(if drv
;; If GRAFTS already contains a graft from DRV, do not override it.
(if (find (cut graft-origin? drv <>) grafts)
(state-return grafts)
(cumulative-grafts store drv grafts references
#:outputs (list output)
#:guile guile
#:system system))
(state-return grafts))))
(match (reference-origin drv item)
((drv . output)
;; If GRAFTS already contains a graft from DRV, do not override it.
(if (find (cut graft-origin? drv <>) grafts)
(state-return grafts)
(cumulative-grafts store drv grafts references
#:outputs (list output)
#:guile guile
#:system system)))
(#f
(state-return grafts))))
(with-cache (cons (derivation-file-name drv) outputs)
(match (non-self-references references drv outputs)