;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
version>? version-prefix?
cache-directory))
#:use-module ((guix store)
- #:select (nix-server-socket
- nix-server-major-version
- nix-server-minor-version
+ #:select (store-connection-socket
+ store-connection-major-version
+ store-connection-minor-version
store-lift))
#:use-module ((guix derivations)
#:select (read-derivation-from-file))
#:use-module ((rnrs bytevectors) #:select (string->utf8))
#:export (inferior?
open-inferior
+ port->inferior
close-inferior
inferior-eval
+ inferior-eval-with-store
inferior-object?
+ read-repl-response
inferior-packages
+ inferior-available-packages
lookup-inferior-packages
inferior-package?
inferior-package->manifest-entry
+ gexp->derivation-in-inferior
+
%inferior-cache-directory
inferior-for-channels))
;; Inferior Guix process.
(define-record-type <inferior>
- (inferior pid socket version packages table)
+ (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
((@ (guix scripts repl) machine-repl))))))
pipe)))
-(define* (open-inferior directory #:key (command "bin/guix"))
- "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))
-
- (cond-expand
- ((and guile-2 (not guile-2.2)) #t)
- (else (setvbuf pipe 'line)))
+(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 (cons 0 rest)
+ (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
(delay (%inferior-packages result))
(delay (%inferior-package-table result)))))
(inferior-eval '(use-modules (guix)) result)
(_
#f)))
+(define* (open-inferior directory #:key (command "bin/guix"))
+ "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))
+
+ (port->inferior pipe close-pipe))
+
(define (close-inferior inferior)
"Close INFERIOR."
- (close-pipe (inferior-socket inferior)))
+ (let ((close (inferior-close-socket inferior)))
+ (close (inferior-socket inferior))))
;; Non-self-quoting object of the inferior.
(define-record-type <inferior-object>
(set-record-type-printer! <inferior-object> write-inferior-object)
-(define (read-inferior-response inferior)
+(define (read-repl-response port)
+ "Read a (guix repl) response from PORT and return it as a Scheme object."
(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 key objects ...)
(apply throw key (map sexp->object objects)))))
+(define (read-inferior-response inferior)
+ (read-repl-response (inferior-socket inferior)))
+
(define (send-inferior-request exp inferior)
(write exp (inferior-socket inferior))
(newline (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
;; 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 _IOFBF 65536)
- (setvbuf backend _IOFBF 65536)
+ (setvbuf client 'block 65536)
+ (setvbuf backend 'block 65536)
(let loop ()
(match (select* (list client backend) '() '())
(unless (port-closed? client)
(loop))))))
-(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."
- ;; Create a named socket in /tmp and let the inferior of PACKAGE 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.
+(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))
- (inferior (inferior-package-inferior package))
- (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 ((socket (socket AF_UNIX SOCK_STREAM 0)))
+ `(let ((proc ,code)
+ (socket (socket AF_UNIX SOCK_STREAM 0)))
(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)))
- (package (hashv-ref %package-table
- ,(inferior-package-id package)))
- (drv ,(if target
- `(package-cross-derivation store package
- ,target
- ,system)
- `(package-derivation store package
- ,system))))
- (close-connection store)
- (close-port socket)
- (derivation-file-name drv)))
+ (let ((store (if (defined? 'port->connection)
+ (port->connection socket #:version ,proto)
+ (open-connection))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (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-derivation-from-file (read-inferior-response inferior))))))
+ (read-inferior-response inferior)))))
+
+(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))
;; 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.
HCoop / jackhill / guix / guix.git / blobdiff