7bd5f72918
This allows the user of 'cached-channel-instance' to install the build handler of its choice. In particular, it allows "guix time-machine" to install a build notifier with the right options instead of using the defaults that 'cached-channel-instance' would pass to 'show-what-to-build*'. * guix/inferior.scm (cached-channel-instance): Remove call to 'show-what-to-build*'. (inferior-for-channels): Wrap body in 'with-build-handler'. * guix/scripts/time-machine.scm (guix-time-machine): Use 'with-build-handler'.
839 lines
33 KiB
Scheme
839 lines
33 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.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/>.
|
||
|
||
(define-module (guix inferior)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (srfi srfi-9 gnu)
|
||
#:use-module (srfi srfi-34)
|
||
#:use-module (srfi srfi-35)
|
||
#:use-module ((guix diagnostics)
|
||
#:select (source-properties->location))
|
||
#:use-module ((guix utils)
|
||
#:select (%current-system
|
||
call-with-temporary-directory
|
||
version>? version-prefix?
|
||
cache-directory))
|
||
#:use-module ((guix store)
|
||
#:select (store-connection-socket
|
||
store-connection-major-version
|
||
store-connection-minor-version
|
||
store-lift
|
||
&store-protocol-error))
|
||
#:use-module ((guix derivations)
|
||
#:select (read-derivation-from-file))
|
||
#:use-module (guix gexp)
|
||
#:use-module (guix search-paths)
|
||
#:use-module (guix profiles)
|
||
#:use-module (guix channels)
|
||
#:use-module ((guix git) #:select (update-cached-checkout))
|
||
#:use-module (guix monads)
|
||
#:use-module (guix store)
|
||
#:use-module (guix derivations)
|
||
#:use-module (guix base32)
|
||
#:use-module (gcrypt hash)
|
||
#:autoload (guix cache) (maybe-remove-expired-cache-entries
|
||
file-expiration-time)
|
||
#:autoload (guix ui) (build-notifier)
|
||
#:autoload (guix build utils) (mkdir-p)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (srfi srfi-71)
|
||
#:autoload (ice-9 ftw) (scandir)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 popen)
|
||
#:use-module (ice-9 vlist)
|
||
#:use-module (ice-9 binary-ports)
|
||
#:use-module ((rnrs bytevectors) #:select (string->utf8))
|
||
#:export (inferior?
|
||
open-inferior
|
||
port->inferior
|
||
close-inferior
|
||
inferior-eval
|
||
inferior-eval-with-store
|
||
inferior-object?
|
||
inferior-exception?
|
||
inferior-exception-arguments
|
||
inferior-exception-inferior
|
||
inferior-exception-stack
|
||
read-repl-response
|
||
|
||
inferior-packages
|
||
inferior-available-packages
|
||
lookup-inferior-packages
|
||
|
||
inferior-package?
|
||
inferior-package-name
|
||
inferior-package-version
|
||
inferior-package-synopsis
|
||
inferior-package-description
|
||
inferior-package-home-page
|
||
inferior-package-location
|
||
inferior-package-inputs
|
||
inferior-package-native-inputs
|
||
inferior-package-propagated-inputs
|
||
inferior-package-transitive-propagated-inputs
|
||
inferior-package-native-search-paths
|
||
inferior-package-transitive-native-search-paths
|
||
inferior-package-search-paths
|
||
inferior-package-replacement
|
||
inferior-package-provenance
|
||
inferior-package-derivation
|
||
|
||
inferior-package->manifest-entry
|
||
|
||
gexp->derivation-in-inferior
|
||
|
||
%inferior-cache-directory
|
||
cached-channel-instance
|
||
inferior-for-channels))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module provides a way to spawn Guix "inferior" processes and to talk
|
||
;;; to them. It allows us, from one instance of Guix, to interact with
|
||
;;; another instance of Guix coming from a different commit.
|
||
;;;
|
||
;;; Code:
|
||
|
||
;; Inferior Guix process.
|
||
(define-record-type <inferior>
|
||
(inferior pid socket close version packages table)
|
||
inferior?
|
||
(pid inferior-pid)
|
||
(socket inferior-socket)
|
||
(close inferior-close-socket) ;procedure
|
||
(version inferior-version) ;REPL protocol version
|
||
(packages inferior-package-promise) ;promise of inferior packages
|
||
(table inferior-package-table)) ;promise of vhash
|
||
|
||
(define (write-inferior inferior port)
|
||
(match inferior
|
||
(($ <inferior> pid _ _ version)
|
||
(format port "#<inferior ~a ~a ~a>"
|
||
pid version
|
||
(number->string (object-address inferior) 16)))))
|
||
|
||
(set-record-type-printer! <inferior> write-inferior)
|
||
|
||
(define* (inferior-pipe directory command error-port)
|
||
"Return an input/output pipe on the Guix instance in DIRECTORY. This runs
|
||
'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
|
||
it's an old Guix."
|
||
(let ((pipe (with-error-to-port error-port
|
||
(lambda ()
|
||
(open-pipe* OPEN_BOTH
|
||
(string-append directory "/" command)
|
||
"repl" "-t" "machine")))))
|
||
(if (eof-object? (peek-char pipe))
|
||
(begin
|
||
(close-pipe pipe)
|
||
|
||
;; Older versions of Guix didn't have a 'guix repl' command, so
|
||
;; emulate it.
|
||
(with-error-to-port error-port
|
||
(lambda ()
|
||
(open-pipe* OPEN_BOTH "guile"
|
||
"-L" (string-append directory "/share/guile/site/"
|
||
(effective-version))
|
||
"-C" (string-append directory "/share/guile/site/"
|
||
(effective-version))
|
||
"-C" (string-append directory "/lib/guile/"
|
||
(effective-version) "/site-ccache")
|
||
"-c"
|
||
(object->string
|
||
`(begin
|
||
(primitive-load ,(search-path %load-path
|
||
"guix/repl.scm"))
|
||
((@ (guix repl) machine-repl))))))))
|
||
pipe)))
|
||
|
||
(define* (port->inferior pipe #:optional (close close-port))
|
||
"Given PIPE, an input/output port, return an inferior that talks over PIPE.
|
||
PIPE is closed with CLOSE when 'close-inferior' is called on the returned
|
||
inferior."
|
||
(setvbuf pipe 'line)
|
||
|
||
(match (read pipe)
|
||
(('repl-version 0 rest ...)
|
||
(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
|
||
(delay (%inferior-packages result))
|
||
(delay (%inferior-package-table result)))))
|
||
|
||
;; For protocol (0 1) and later, send the protocol version we support.
|
||
(match rest
|
||
((n _ ...)
|
||
(when (>= n 1)
|
||
(send-inferior-request '(() repl-version 0 1 1) result)))
|
||
(_
|
||
#t))
|
||
|
||
(inferior-eval '(use-modules (guix)) result)
|
||
(inferior-eval '(use-modules (gnu)) result)
|
||
(inferior-eval '(use-modules (ice-9 match)) result)
|
||
(inferior-eval '(use-modules (srfi srfi-34)) result)
|
||
(inferior-eval '(define %package-table (make-hash-table))
|
||
result)
|
||
result))
|
||
(_
|
||
#f)))
|
||
|
||
(define* (open-inferior directory
|
||
#:key (command "bin/guix")
|
||
(error-port (%make-void-port "w")))
|
||
"Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
|
||
equivalent. Return #f if the inferior could not be launched."
|
||
(define pipe
|
||
(inferior-pipe directory command error-port))
|
||
|
||
(port->inferior pipe close-pipe))
|
||
|
||
(define (close-inferior inferior)
|
||
"Close INFERIOR."
|
||
(let ((close (inferior-close-socket inferior)))
|
||
(close (inferior-socket inferior))))
|
||
|
||
;; Non-self-quoting object of the inferior.
|
||
(define-record-type <inferior-object>
|
||
(inferior-object address appearance)
|
||
inferior-object?
|
||
(address inferior-object-address)
|
||
(appearance inferior-object-appearance))
|
||
|
||
(define (write-inferior-object object port)
|
||
(match object
|
||
(($ <inferior-object> _ appearance)
|
||
(format port "#<inferior-object ~a>" appearance))))
|
||
|
||
(set-record-type-printer! <inferior-object> write-inferior-object)
|
||
|
||
;; Reified exception thrown by an inferior.
|
||
(define-condition-type &inferior-exception &error
|
||
inferior-exception?
|
||
(arguments inferior-exception-arguments) ;key + arguments
|
||
(inferior inferior-exception-inferior) ;<inferior> | #f
|
||
(stack inferior-exception-stack)) ;list of (FILE COLUMN LINE)
|
||
|
||
(define* (read-repl-response port #:optional inferior)
|
||
"Read a (guix repl) response from PORT and return it as a Scheme object.
|
||
Raise '&inferior-exception' when an exception is read from PORT."
|
||
(define sexp->object
|
||
(match-lambda
|
||
(('value value)
|
||
value)
|
||
(('non-self-quoting address string)
|
||
(inferior-object address string))))
|
||
|
||
(match (read port)
|
||
(('values objects ...)
|
||
(apply values (map sexp->object objects)))
|
||
(('exception ('arguments key objects ...)
|
||
('stack frames ...))
|
||
;; Protocol (0 1 1) and later.
|
||
(raise (condition (&inferior-exception
|
||
(arguments (cons key (map sexp->object objects)))
|
||
(inferior inferior)
|
||
(stack frames)))))
|
||
(('exception key objects ...)
|
||
;; Protocol (0 0).
|
||
(raise (condition (&inferior-exception
|
||
(arguments (cons key (map sexp->object objects)))
|
||
(inferior inferior)
|
||
(stack '())))))))
|
||
|
||
(define (read-inferior-response inferior)
|
||
(read-repl-response (inferior-socket inferior)
|
||
inferior))
|
||
|
||
(define (send-inferior-request exp inferior)
|
||
(write exp (inferior-socket inferior))
|
||
(newline (inferior-socket inferior)))
|
||
|
||
(define (inferior-eval exp inferior)
|
||
"Evaluate EXP in INFERIOR."
|
||
(send-inferior-request exp inferior)
|
||
(read-inferior-response inferior))
|
||
|
||
|
||
;;;
|
||
;;; Inferior packages.
|
||
;;;
|
||
|
||
(define-record-type <inferior-package>
|
||
(inferior-package inferior name version id)
|
||
inferior-package?
|
||
(inferior inferior-package-inferior)
|
||
(name inferior-package-name)
|
||
(version inferior-package-version)
|
||
(id inferior-package-id))
|
||
|
||
(define (write-inferior-package package port)
|
||
(match package
|
||
(($ <inferior-package> _ name version)
|
||
(format port "#<inferior-package ~a@~a ~a>"
|
||
name version
|
||
(number->string (object-address package) 16)))))
|
||
|
||
(set-record-type-printer! <inferior-package> write-inferior-package)
|
||
|
||
(define (%inferior-packages inferior)
|
||
"Compute the list of inferior packages from INFERIOR."
|
||
(let ((result (inferior-eval
|
||
'(fold-packages (lambda (package result)
|
||
(let ((id (object-address package)))
|
||
(hashv-set! %package-table id package)
|
||
(cons (list (package-name package)
|
||
(package-version package)
|
||
id)
|
||
result)))
|
||
'())
|
||
inferior)))
|
||
(map (match-lambda
|
||
((name version id)
|
||
(inferior-package inferior name version id)))
|
||
result)))
|
||
|
||
(define (inferior-packages inferior)
|
||
"Return the list of packages known to INFERIOR."
|
||
(force (inferior-package-promise inferior)))
|
||
|
||
(define (%inferior-package-table inferior)
|
||
"Compute a package lookup table for INFERIOR."
|
||
(fold (lambda (package table)
|
||
(vhash-cons (inferior-package-name package) package
|
||
table))
|
||
vlist-null
|
||
(inferior-packages inferior)))
|
||
|
||
(define (inferior-available-packages inferior)
|
||
"Return the list of name/version pairs corresponding to the set of packages
|
||
available in INFERIOR.
|
||
|
||
This is faster and less resource-intensive than calling 'inferior-packages'."
|
||
(if (inferior-eval '(defined? 'fold-available-packages)
|
||
inferior)
|
||
(inferior-eval '(fold-available-packages
|
||
(lambda* (name version result
|
||
#:key supported? deprecated?
|
||
#:allow-other-keys)
|
||
(if (and supported? (not deprecated?))
|
||
(acons name version result)
|
||
result))
|
||
'())
|
||
inferior)
|
||
|
||
;; As a last resort, if INFERIOR is old and lacks
|
||
;; 'fold-available-packages', fall back to 'inferior-packages'.
|
||
(map (lambda (package)
|
||
(cons (inferior-package-name package)
|
||
(inferior-package-version package)))
|
||
(inferior-packages inferior))))
|
||
|
||
(define* (lookup-inferior-packages inferior name #:optional version)
|
||
"Return the sorted list of inferior packages matching NAME in INFERIOR, with
|
||
highest version numbers first. If VERSION is true, return only packages with
|
||
a version number prefixed by VERSION."
|
||
;; This is the counterpart of 'find-packages-by-name'.
|
||
(sort (filter (lambda (package)
|
||
(or (not version)
|
||
(version-prefix? version
|
||
(inferior-package-version package))))
|
||
(vhash-fold* cons '() name
|
||
(force (inferior-package-table inferior))))
|
||
(lambda (p1 p2)
|
||
(version>? (inferior-package-version p1)
|
||
(inferior-package-version p2)))))
|
||
|
||
(define (inferior-package-field package getter)
|
||
"Return the field of PACKAGE, an inferior package, accessed with GETTER."
|
||
(let ((inferior (inferior-package-inferior package))
|
||
(id (inferior-package-id package)))
|
||
(inferior-eval `(,getter (hashv-ref %package-table ,id))
|
||
inferior)))
|
||
|
||
(define* (inferior-package-synopsis package #:key (translate? #t))
|
||
"Return the Texinfo synopsis of PACKAGE, an inferior package. When
|
||
TRANSLATE? is true, translate it to the current locale's language."
|
||
(inferior-package-field package
|
||
(if translate?
|
||
'(compose (@ (guix ui) P_) package-synopsis)
|
||
'package-synopsis)))
|
||
|
||
(define* (inferior-package-description package #:key (translate? #t))
|
||
"Return the Texinfo description of PACKAGE, an inferior package. When
|
||
TRANSLATE? is true, translate it to the current locale's language."
|
||
(inferior-package-field package
|
||
(if translate?
|
||
'(compose (@ (guix ui) P_) package-description)
|
||
'package-description)))
|
||
|
||
(define (inferior-package-home-page package)
|
||
"Return the home page of PACKAGE."
|
||
(inferior-package-field package 'package-home-page))
|
||
|
||
(define (inferior-package-location package)
|
||
"Return the source code location of PACKAGE, either #f or a <location>
|
||
record."
|
||
(source-properties->location
|
||
(inferior-package-field package
|
||
'(compose (lambda (loc)
|
||
(and loc
|
||
(location->source-properties
|
||
loc)))
|
||
package-location))))
|
||
|
||
(define (inferior-package-input-field package field)
|
||
"Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an
|
||
inferior package."
|
||
(define field*
|
||
`(compose (lambda (inputs)
|
||
(map (match-lambda
|
||
;; XXX: Origins are not handled.
|
||
((label (? package? package) rest ...)
|
||
(let ((id (object-address package)))
|
||
(hashv-set! %package-table id package)
|
||
`(,label (package ,id
|
||
,(package-name package)
|
||
,(package-version package))
|
||
,@rest)))
|
||
(x
|
||
x))
|
||
inputs))
|
||
,field))
|
||
|
||
(define inputs
|
||
(inferior-package-field package field*))
|
||
|
||
(define inferior
|
||
(inferior-package-inferior package))
|
||
|
||
(map (match-lambda
|
||
((label ('package id name version) . rest)
|
||
;; XXX: eq?-ness of inferior packages is not preserved here.
|
||
`(,label ,(inferior-package inferior name version id)
|
||
,@rest))
|
||
(x x))
|
||
inputs))
|
||
|
||
(define inferior-package-inputs
|
||
(cut inferior-package-input-field <> 'package-inputs))
|
||
|
||
(define inferior-package-native-inputs
|
||
(cut inferior-package-input-field <> 'package-native-inputs))
|
||
|
||
(define inferior-package-propagated-inputs
|
||
(cut inferior-package-input-field <> 'package-propagated-inputs))
|
||
|
||
(define inferior-package-transitive-propagated-inputs
|
||
(cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
|
||
|
||
(define (%inferior-package-search-paths package field)
|
||
"Return the list of search path specifications of PACKAGE, an inferior
|
||
package."
|
||
(define paths
|
||
(inferior-package-field package
|
||
`(compose (lambda (paths)
|
||
(map (@ (guix search-paths)
|
||
search-path-specification->sexp)
|
||
paths))
|
||
,field)))
|
||
|
||
(map sexp->search-path-specification paths))
|
||
|
||
(define inferior-package-native-search-paths
|
||
(cut %inferior-package-search-paths <> 'package-native-search-paths))
|
||
|
||
(define inferior-package-search-paths
|
||
(cut %inferior-package-search-paths <> 'package-search-paths))
|
||
|
||
(define inferior-package-transitive-native-search-paths
|
||
(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
|
||
|
||
(define (inferior-package-replacement package)
|
||
"Return the replacement for PACKAGE. This will either be an inferior
|
||
package, or #f."
|
||
(match (inferior-package-field
|
||
package
|
||
'(compose (match-lambda
|
||
((? package? package)
|
||
(let ((id (object-address package)))
|
||
(hashv-set! %package-table id package)
|
||
(list id
|
||
(package-name package)
|
||
(package-version package))))
|
||
(#f #f))
|
||
package-replacement))
|
||
(#f #f)
|
||
((id name version)
|
||
(inferior-package (inferior-package-inferior package)
|
||
name
|
||
version
|
||
id))))
|
||
|
||
(define (inferior-package-provenance package)
|
||
"Return a \"provenance sexp\" for PACKAGE, an inferior package. The result
|
||
is similar to the sexp returned by 'package-provenance' for regular packages."
|
||
(inferior-package-field package
|
||
'(let* ((describe
|
||
(false-if-exception
|
||
(resolve-interface '(guix describe))))
|
||
(provenance
|
||
(false-if-exception
|
||
(module-ref describe
|
||
'package-provenance))))
|
||
(or provenance (const #f)))))
|
||
|
||
(define (proxy client backend) ;adapted from (guix ssh)
|
||
"Proxy communication between CLIENT and BACKEND until CLIENT closes the
|
||
connection, at which point CLIENT is closed (both CLIENT and BACKEND must be
|
||
input/output ports.)"
|
||
;; Use buffered ports so that 'get-bytevector-some' returns up to the
|
||
;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>.
|
||
(setvbuf client 'block 65536)
|
||
(setvbuf backend 'block 65536)
|
||
|
||
(let loop ()
|
||
(match (select (list client backend) '() '())
|
||
((reads () ())
|
||
(when (memq client reads)
|
||
(match (get-bytevector-some client)
|
||
((? eof-object?)
|
||
(close-port client))
|
||
(bv
|
||
(put-bytevector backend bv)
|
||
(force-output backend))))
|
||
(when (memq backend reads)
|
||
(match (get-bytevector-some backend)
|
||
(bv
|
||
(put-bytevector client bv)
|
||
(force-output client))))
|
||
(unless (port-closed? client)
|
||
(loop))))))
|
||
|
||
(define (inferior-eval-with-store inferior store code)
|
||
"Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must
|
||
thus be the code of a one-argument procedure that accepts a store."
|
||
;; Create a named socket in /tmp and let INFERIOR connect to it and use it
|
||
;; as its store. This ensures the inferior uses the same store, with the
|
||
;; same options, the same per-session GC roots, etc.
|
||
;; FIXME: This strategy doesn't work for remote inferiors (SSH).
|
||
(call-with-temporary-directory
|
||
(lambda (directory)
|
||
(chmod directory #o700)
|
||
(let* ((name (string-append directory "/inferior"))
|
||
(socket (socket AF_UNIX SOCK_STREAM 0))
|
||
(major (store-connection-major-version store))
|
||
(minor (store-connection-minor-version store))
|
||
(proto (logior major minor)))
|
||
(bind socket AF_UNIX name)
|
||
(listen socket 1024)
|
||
(send-inferior-request
|
||
`(let ((proc ,code)
|
||
(socket (socket AF_UNIX SOCK_STREAM 0))
|
||
(error? (if (defined? 'store-protocol-error?)
|
||
store-protocol-error?
|
||
nix-protocol-error?))
|
||
(error-message (if (defined? 'store-protocol-error-message)
|
||
store-protocol-error-message
|
||
nix-protocol-error-message)))
|
||
(connect socket AF_UNIX ,name)
|
||
|
||
;; 'port->connection' appeared in June 2018 and we can hardly
|
||
;; emulate it on older versions. Thus fall back to
|
||
;; 'open-connection', at the risk of talking to the wrong daemon or
|
||
;; having our build result reclaimed (XXX).
|
||
(let ((store (if (defined? 'port->connection)
|
||
(port->connection socket #:version ,proto)
|
||
(open-connection))))
|
||
(dynamic-wind
|
||
(const #t)
|
||
(lambda ()
|
||
;; Serialize '&store-protocol-error' conditions. The
|
||
;; exception serialization mechanism that
|
||
;; 'read-repl-response' expects is unsuitable for SRFI-35
|
||
;; error conditions, hence this special case.
|
||
(guard (c ((error? c)
|
||
`(store-protocol-error ,(error-message c))))
|
||
`(result ,(proc store))))
|
||
(lambda ()
|
||
(close-connection store)
|
||
(close-port socket)))))
|
||
inferior)
|
||
(match (accept socket)
|
||
((client . address)
|
||
(proxy client (store-connection-socket store))))
|
||
(close-port socket)
|
||
|
||
(match (read-inferior-response inferior)
|
||
(('store-protocol-error message)
|
||
(raise (condition
|
||
(&store-protocol-error (message message)
|
||
(status 1)))))
|
||
(('result result)
|
||
result))))))
|
||
|
||
(define* (inferior-package-derivation store package
|
||
#:optional
|
||
(system (%current-system))
|
||
#:key target)
|
||
"Return the derivation for PACKAGE, an inferior package, built for SYSTEM
|
||
and cross-built for TARGET if TARGET is true. The inferior corresponding to
|
||
PACKAGE must be live."
|
||
(define proc
|
||
`(lambda (store)
|
||
(let* ((package (hashv-ref %package-table
|
||
,(inferior-package-id package)))
|
||
(drv ,(if target
|
||
`(package-cross-derivation store package
|
||
,target
|
||
,system)
|
||
`(package-derivation store package
|
||
,system))))
|
||
(derivation-file-name drv))))
|
||
|
||
(and=> (inferior-eval-with-store (inferior-package-inferior package) store
|
||
proc)
|
||
read-derivation-from-file))
|
||
|
||
(define inferior-package->derivation
|
||
(store-lift inferior-package-derivation))
|
||
|
||
(define-gexp-compiler (package-compiler (package <inferior-package>) system
|
||
target)
|
||
;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
|
||
(inferior-package->derivation package system #:target target))
|
||
|
||
(define* (gexp->derivation-in-inferior name exp guix
|
||
#:key silent-failure?
|
||
#:allow-other-keys
|
||
#:rest rest)
|
||
"Return a derivation that evaluates EXP with GUIX, an instance of Guix as
|
||
returned for example by 'channel-instances->derivation'. Other arguments are
|
||
passed as-is to 'gexp->derivation'.
|
||
|
||
When SILENT-FAILURE? is true, create an empty output directory instead of
|
||
failing when GUIX is too old and lacks the 'guix repl' command."
|
||
(define script
|
||
;; EXP wrapped with a proper (set! %load-path …) prologue.
|
||
(scheme-file "inferior-script.scm" exp))
|
||
|
||
(define trampoline
|
||
;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and
|
||
;; make 'guix repl' the "builder"; this will require "opening up" the
|
||
;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'.
|
||
#~(begin
|
||
(use-modules (ice-9 popen))
|
||
|
||
(let ((pipe (open-pipe* OPEN_WRITE
|
||
#+(file-append guix "/bin/guix")
|
||
"repl" "-t" "machine")))
|
||
|
||
;; XXX: EXP presumably refers to #$output but that reference is lost
|
||
;; so explicitly reference it here.
|
||
#$output
|
||
|
||
(write `(primitive-load #$script) pipe)
|
||
|
||
(unless (zero? (close-pipe pipe))
|
||
(if #$silent-failure?
|
||
(mkdir #$output)
|
||
(error "inferior failed" #+guix))))))
|
||
|
||
(define (drop-extra-keyword lst)
|
||
(let loop ((lst lst)
|
||
(result '()))
|
||
(match lst
|
||
(()
|
||
(reverse result))
|
||
((#:silent-failure? _ . rest)
|
||
(loop rest result))
|
||
((kw value . tail)
|
||
(loop tail (cons* value kw result))))))
|
||
|
||
(apply gexp->derivation name trampoline
|
||
(drop-extra-keyword rest)))
|
||
|
||
|
||
;;;
|
||
;;; Manifest entries.
|
||
;;;
|
||
|
||
(define* (inferior-package->manifest-entry package
|
||
#:optional (output "out")
|
||
#:key (properties '()))
|
||
"Return a manifest entry for the OUTPUT of package PACKAGE."
|
||
(define cache
|
||
(make-hash-table))
|
||
|
||
(define-syntax-rule (memoized package output exp)
|
||
;; Memoize the entry returned by EXP for PACKAGE/OUTPUT. This is
|
||
;; important as the same package may be traversed many times through
|
||
;; propagated inputs, and querying the inferior is costly. Use
|
||
;; 'hash'/'equal?', which is okay since <inferior-package> is simple.
|
||
(let ((compute (lambda () exp))
|
||
(key (cons package output)))
|
||
(or (hash-ref cache key)
|
||
(let ((result (compute)))
|
||
(hash-set! cache key result)
|
||
result))))
|
||
|
||
(let loop ((package package)
|
||
(output output)
|
||
(parent (delay #f)))
|
||
(memoized package output
|
||
;; For each dependency, keep a promise pointing to its "parent" entry.
|
||
(letrec* ((deps (map (match-lambda
|
||
((label package)
|
||
(loop package "out" (delay entry)))
|
||
((label package output)
|
||
(loop package output (delay entry))))
|
||
(inferior-package-propagated-inputs package)))
|
||
(entry (manifest-entry
|
||
(name (inferior-package-name package))
|
||
(version (inferior-package-version package))
|
||
(output output)
|
||
(item package)
|
||
(dependencies (delete-duplicates deps))
|
||
(search-paths
|
||
(inferior-package-transitive-native-search-paths package))
|
||
(parent parent)
|
||
(properties properties))))
|
||
entry))))
|
||
|
||
|
||
;;;
|
||
;;; Cached inferiors.
|
||
;;;
|
||
|
||
(define %inferior-cache-directory
|
||
;; Directory for cached inferiors (GC roots).
|
||
(make-parameter (string-append (cache-directory #:ensure? #f)
|
||
"/inferiors")))
|
||
|
||
(define (channel-full-commit channel)
|
||
"Return the commit designated by CHANNEL as quickly as possible. If
|
||
CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1
|
||
prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
|
||
(let ((commit (channel-commit channel))
|
||
(branch (channel-branch channel)))
|
||
(if (and commit (= (string-length commit) 40))
|
||
commit
|
||
(let* ((ref (if commit `(commit . ,commit) `(branch . ,branch)))
|
||
(cache commit relation
|
||
(update-cached-checkout (channel-url channel)
|
||
#:ref ref
|
||
#:check-out? #f)))
|
||
commit))))
|
||
|
||
(define* (cached-channel-instance store
|
||
channels
|
||
#:key
|
||
(authenticate? #t)
|
||
(cache-directory (%inferior-cache-directory))
|
||
(ttl (* 3600 24 30)))
|
||
"Return a directory containing a guix filetree defined by CHANNELS, a list of channels.
|
||
The directory is a subdirectory of CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds.
|
||
This procedure opens a new connection to the build daemon. AUTHENTICATE?
|
||
determines whether CHANNELS are authenticated."
|
||
(define commits
|
||
;; Since computing the instances of CHANNELS is I/O-intensive, use a
|
||
;; cheaper way to get the commit list of CHANNELS. This limits overhead
|
||
;; to the minimum in case of a cache hit.
|
||
(map channel-full-commit channels))
|
||
|
||
(define key
|
||
(bytevector->base32-string
|
||
(sha256
|
||
(string->utf8 (string-concatenate commits)))))
|
||
|
||
(define cached
|
||
(string-append cache-directory "/" key))
|
||
|
||
(define (base32-encoded-sha256? str)
|
||
(= (string-length str) 52))
|
||
|
||
(define (cache-entries directory)
|
||
(map (lambda (file)
|
||
(string-append directory "/" file))
|
||
(scandir directory base32-encoded-sha256?)))
|
||
|
||
(define (symlink/safe old new)
|
||
(catch 'system-error
|
||
(lambda ()
|
||
(symlink old new))
|
||
(lambda args
|
||
(unless (= EEXIST (system-error-errno args))
|
||
(apply throw args)))))
|
||
|
||
(define symlink*
|
||
(lift2 symlink/safe %store-monad))
|
||
|
||
(define add-indirect-root*
|
||
(store-lift add-indirect-root))
|
||
|
||
(mkdir-p cache-directory)
|
||
(maybe-remove-expired-cache-entries cache-directory
|
||
cache-entries
|
||
#:entry-expiration
|
||
(file-expiration-time ttl))
|
||
|
||
(if (file-exists? cached)
|
||
cached
|
||
(run-with-store store
|
||
(mlet* %store-monad ((instances
|
||
-> (latest-channel-instances store channels
|
||
#:authenticate?
|
||
authenticate?))
|
||
(profile
|
||
(channel-instances->derivation instances)))
|
||
(mbegin %store-monad
|
||
;; It's up to the caller to install a build handler to report
|
||
;; what's going to be built.
|
||
(built-derivations (list profile))
|
||
|
||
;; Note: Caching is fine even when AUTHENTICATE? is false because
|
||
;; we always call 'latest-channel-instances?'.
|
||
(symlink* (derivation->output-path profile) cached)
|
||
(add-indirect-root* cached)
|
||
(return cached))))))
|
||
|
||
(define* (inferior-for-channels channels
|
||
#:key
|
||
(cache-directory (%inferior-cache-directory))
|
||
(ttl (* 3600 24 30)))
|
||
"Return an inferior for CHANNELS, a list of channels. Use the cache at
|
||
CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This
|
||
procedure opens a new connection to the build daemon.
|
||
|
||
This is a convenience procedure that people may use in manifests passed to
|
||
'guix package -m', for instance."
|
||
(define cached
|
||
(with-store store
|
||
;; XXX: Install a build notifier out of convenience, so users know
|
||
;; what's going on. However, we cannot be sure that its options, such
|
||
;; as #:use-substitutes?, correspond to the daemon's default settings.
|
||
(with-build-handler (build-notifier)
|
||
(cached-channel-instance store
|
||
channels
|
||
#:cache-directory cache-directory
|
||
#:ttl ttl))))
|
||
(open-inferior cached))
|
||
|
||
;;; Local Variables:
|
||
;;; eval: (put 'memoized 'scheme-indent-function 1)
|
||
;;; End:
|