ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

inferior: Add 'inferior-package-derivation'.

Browse source 
* guix/inferior.scm (read-inferior-response)
(send-inferior-request): New procedures.
(inferior-eval): Rewrite in terms of these.
(proxy, inferior-package-derivation, inferior-package->derivation)
(package-compiler): New procedures.
* tests/inferior.scm ("inferior-package-derivation"): New test.
This commit is contained in:
Ludovic Courtès 2018-09-14 17:30:06 +02:00
parent 7e27393f82
commit 9daf046c5d
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 141 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

125
guix/inferior.scm
View file

@ -19,9 +19,21 @@
(define-module (guix inferior)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module ((guix utils) #:select (source-properties->location))
#:use-module ((guix utils)
#:select (%current-system
source-properties->location
call-with-temporary-directory))
#:use-module ((guix store)
#:select (nix-server-socket
nix-server-major-version
nix-server-minor-version
store-lift))
#:use-module ((guix derivations)
#:select (read-derivation-from-file))
#:use-module (guix gexp)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 binary-ports)
#:export (inferior?
open-inferior
close-inferior
@ -36,7 +48,8 @@ (define-module (guix inferior)
inferior-package-synopsis
inferior-package-description
inferior-package-home-page
inferior-package-location))
inferior-package-location
inferior-package-derivation))
;;; Commentary:
;;;
@ -123,8 +136,7 @@ (define (write-inferior-object object port)
(set-record-type-printer! <inferior-object> write-inferior-object)
(define (inferior-eval exp inferior)
"Evaluate EXP in INFERIOR."
(define (read-inferior-response inferior)
(define sexp->object
(match-lambda
(('value value)
@ -132,14 +144,21 @@ (define sexp->object
(('non-self-quoting address string)
(inferior-object address string))))
(write exp (inferior-socket inferior))
(newline (inferior-socket inferior))
(match (read (inferior-socket inferior))
(('values objects ...)
(apply values (map sexp->object objects)))
(('exception key objects ...)
(apply throw key (map sexp->object objects)))))
(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.
@ -216,3 +235,97 @@ (define (inferior-package-location package)
(location->source-properties
loc)))
package-location))))
(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.)"
(define (select* read write except)
;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4:
;; since 'select' sometimes returns non-empty sets for no good reason,
;; call 'select' a second time with a zero timeout to filter out incorrect
;; replies.
(match (select read write except)
((read write except)
(select read write except 0))))
;; 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)
(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-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.
(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))
(proto (logior major minor)))
(bind socket AF_UNIX name)
(listen socket 1024)
(send-inferior-request
`(let ((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)))
inferior)
(match (accept socket)
((client . address)
(proxy client (nix-server-socket store))))
(close-port socket)
(read-derivation-from-file (read-inferior-response inferior))))))
(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))

22
tests/inferior.scm
View file

@ -17,9 +17,13 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-inferior)
#:use-module (guix tests)
#:use-module (guix inferior)
#:use-module (guix packages)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64))
@ -29,6 +33,9 @@ (define %top-srcdir
(define %top-builddir
(dirname (search-path %load-compiled-path "guix.go")))
(define %store
(open-connection-for-tests))
(test-begin "inferior")
@ -72,4 +79,19 @@ (define result
(close-inferior inferior)
result))))
(test-equal "inferior-package-derivation"
(map derivation-file-name
(list (package-derivation %store %bootstrap-guile "x86_64-linux")
(package-derivation %store %bootstrap-guile "armhf-linux")))
(let* ((inferior (open-inferior %top-builddir
#:command "scripts/guix"))
(packages (inferior-packages inferior))
(guile (find (lambda (package)
(string=? (package-name %bootstrap-guile)
(inferior-package-name package)))
packages)))
(map derivation-file-name
(list (inferior-package-derivation %store guile "x86_64-linux")
(inferior-package-derivation %store guile "armhf-linux")))))
(test-end "inferior")