;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(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 utils)
#:select (%current-system
source-properties->location
version>? version-prefix?
cache-directory))
#:use-module ((guix store)
- #:select (nix-server-socket
- nix-server-major-version
- nix-server-minor-version
- store-lift))
+ #: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 derivations)
#:use-module (guix base32)
#:use-module (gcrypt hash)
- #:autoload (guix cache) (maybe-remove-expired-cache-entries)
+ #:autoload (guix cache) (maybe-remove-expired-cache-entries
+ file-expiration-time)
#:autoload (guix ui) (show-what-to-build*)
#:autoload (guix build utils) (mkdir-p)
#:use-module (srfi srfi-1)
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-native-search-paths
inferior-package-transitive-native-search-paths
inferior-package-search-paths
+ inferior-package-provenance
inferior-package-derivation
inferior-package->manifest-entry
+ gexp->derivation-in-inferior
+
%inferior-cache-directory
+ cached-channel-instance
inferior-for-channels))
;;; Commentary:
(packages inferior-package-promise) ;promise of inferior packages
(table inferior-package-table)) ;promise of vhash
-(define (inferior-pipe directory command)
+(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 (%make-void-port "w")
+ (let ((pipe (with-error-to-port error-port
(lambda ()
(open-pipe* OPEN_BOTH
(string-append directory "/" command)
;; Older versions of Guix didn't have a 'guix repl' command, so
;; emulate it.
- (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/scripts/repl.scm"))
- ((@ (guix scripts repl) machine-repl))))))
+ (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))
(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"))
+(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))
+ (inferior-pipe directory command error-port))
(port->inferior pipe close-pipe))
(set-record-type-printer! <inferior-object> write-inferior-object)
-(define (read-inferior-response inferior)
+;; 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)
(('non-self-quoting address string)
(inferior-object address string))))
- (match (read (inferior-socket inferior))
+ (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 ...)
- (apply throw key (map sexp->object 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))
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 requires 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
(cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
(define (%inferior-package-search-paths package field)
- "Return the list of search path specificiations of PACKAGE, an inferior
+ "Return the list of search path specifications of PACKAGE, an inferior
package."
(define paths
(inferior-package-field package
(define inferior-package-transitive-native-search-paths
(cut %inferior-package-search-paths <> 'package-transitive-native-search-paths))
+(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
(chmod directory #o700)
(let* ((name (string-append directory "/inferior"))
(socket (socket AF_UNIX SOCK_STREAM 0))
- (major (nix-server-major-version store))
- (minor (nix-server-minor-version store))
+ (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)))
+ (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
(dynamic-wind
(const #t)
(lambda ()
- (proc store))
+ ;; 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 (nix-server-socket store))))
+ (proxy client (store-connection-socket store))))
(close-port socket)
- (read-inferior-response inferior)))))
+
+ (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
;; 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)))
+
\f
;;;
;;; Manifest entries.
(make-parameter (string-append (cache-directory #:ensure? #f)
"/inferiors")))
+(define* (cached-channel-instance store
+ channels
+ #:key
+ (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."
+ (define instances
+ (latest-channel-instances store channels))
+
+ (define key
+ (bytevector->base32-string
+ (sha256
+ (string->utf8
+ (string-concatenate (map channel-instance-commit instances))))))
+
+ (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*
+ (lift2 symlink %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 ((profile
+ (channel-instances->derivation instances)))
+ (mbegin %store-monad
+ (show-what-to-build* (list profile))
+ (built-derivations (list profile))
+ (symlink* (derivation->output-path profile) cached)
+ (add-indirect-root* cached)
+ (return cached))))))
+
(define* (inferior-for-channels channels
#:key
(cache-directory (%inferior-cache-directory))
This is a convenience procedure that people may use in manifests passed to
'guix package -m', for instance."
- (with-store store
- (let ()
- (define instances
- (latest-channel-instances store channels))
-
- (define key
- (bytevector->base32-string
- (sha256
- (string->utf8
- (string-concatenate (map channel-instance-commit instances))))))
-
- (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*
- (lift2 symlink %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)
- (open-inferior cached)
- (run-with-store store
- (mlet %store-monad ((profile
- (channel-instances->derivation instances)))
- (mbegin %store-monad
- (show-what-to-build* (list profile))
- (built-derivations (list profile))
- (symlink* (derivation->output-path profile) cached)
- (add-indirect-root* cached)
- (return (open-inferior cached)))))))))
+ (define cached
+ (with-store store
+ (cached-channel-instance store
+ channels
+ #:cache-directory cache-directory
+ #:ttl ttl)))
+ (open-inferior cached))