From 2ca299caf64489f4e1e665ec1158fb0309b0b565 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Jul 2018 14:18:36 +0200 Subject: Add (guix inferior) and (guix scripts repl). * guix/inferior.scm, guix/scripts/repl.scm, tests/inferior.scm: New files. * Makefile.am (MODULES): Add 'guix/scripts/repl.scm' and 'guix/inferior.scm'. (SCM_TESTS): Add 'tests/inferior.scm'. * doc/guix.texi (Invoking guix repl): New node. --- guix/inferior.scm | 197 +++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/repl.scm | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 396 insertions(+) create mode 100644 guix/inferior.scm create mode 100644 guix/scripts/repl.scm (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm new file mode 100644 index 0000000000..629c2c4313 --- /dev/null +++ b/guix/inferior.scm @@ -0,0 +1,197 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix inferior) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:export (inferior? + open-inferior + close-inferior + inferior-eval + inferior-object? + + inferior-package? + inferior-package-name + inferior-package-version + + inferior-packages + inferior-package-synopsis + inferior-package-description)) + +;;; 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 pid socket version) + inferior? + (pid inferior-pid) + (socket inferior-socket) + (version inferior-version)) ;REPL protocol version + +(define (inferior-pipe directory command) + "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") + (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. + (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)))))) + 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)) + + (setvbuf pipe _IOLBF) + (match (read pipe) + (('repl-version 0 rest ...) + (let ((result (inferior 'pipe pipe (cons 0 rest)))) + (inferior-eval '(use-modules (guix)) result) + (inferior-eval '(use-modules (gnu)) result) + (inferior-eval '(define %package-table (make-hash-table)) + result) + result)) + (_ + #f))) + +(define (close-inferior inferior) + "Close INFERIOR." + (close-pipe (inferior-socket inferior))) + +;; Non-self-quoting object of the inferior. +(define-record-type + (inferior-object address appearance) + inferior-object? + (address inferior-object-address) + (appearance inferior-object-appearance)) + +(define (write-inferior-object object port) + (match object + (($ _ appearance) + (format port "#" appearance)))) + +(set-record-type-printer! write-inferior-object) + +(define (inferior-eval exp inferior) + "Evaluate EXP in INFERIOR." + (define sexp->object + (match-lambda + (('value value) + value) + (('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))))) + + +;;; +;;; Inferior packages. +;;; + +(define-record-type + (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 + (($ _ name version) + (format port "#" + name version + (number->string (object-address package) 16))))) + +(set-record-type-printer! write-inferior-package) + +(define (inferior-packages inferior) + "Return the list of packages known to 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-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))) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm new file mode 100644 index 0000000000..b157833a49 --- /dev/null +++ b/guix/scripts/repl.scm @@ -0,0 +1,199 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts repl) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:autoload (system repl repl) (start-repl) + #:autoload (system repl server) + (make-tcp-server-socket make-unix-domain-server-socket) + #:export (machine-repl + guix-repl)) + +;;; Commentary: +;;; +;;; This command provides a Guile REPL + +(define %default-options + `((type . guile))) + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix repl"))) + (option '(#\t "type") #t #f + (lambda (opt name arg result) + (alist-cons 'type (string->symbol arg) result))) + (option '("listen") #t #f + (lambda (opt name arg result) + (alist-cons 'listen arg result))))) + + +(define (show-help) + (display (G_ "Usage: guix repl [OPTIONS...] +Start a Guile REPL in the Guix execution environment.\n")) + (display (G_ " + -t, --type=TYPE start a REPL of the given TYPE")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (self-quoting? x) + "Return #t if X is self-quoting." + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? pair? null? vector? + bytevector? number? boolean?))) + +(define user-module + ;; Module where we execute user code. + (let ((module (resolve-module '(guix-user) #f #f #:ensure #t))) + (beautify-user-module! module) + module)) + +(define* (machine-repl #:optional + (input (current-input-port)) + (output (current-output-port))) + "Run a machine-usable REPL over ports INPUT and OUTPUT. + +The protocol of this REPL is meant to be machine-readable and provides proper +support to represent multiple-value returns, exceptions, objects that lack a +read syntax, and so on. As such it is more convenient and robust than parsing +Guile's REPL prompt." + (define (value->sexp value) + (if (self-quoting? value) + `(value ,value) + `(non-self-quoting ,(object-address value) + ,(object->string value)))) + + (write `(repl-version 0 0) output) + (newline output) + (force-output output) + + (let loop () + (match (read input) + ((? eof-object?) #t) + (exp + (catch #t + (lambda () + (let ((results (call-with-values + (lambda () + + (primitive-eval exp)) + list))) + (write `(values ,@(map value->sexp results)) + output) + (newline output) + (force-output output))) + (lambda (key . args) + (write `(exception ,key ,@(map value->sexp args))) + (newline output) + (force-output output))) + (loop))))) + +(define (call-with-connection spec thunk) + "Dynamically-bind the current input and output ports according to SPEC and +call THUNK." + (if (not spec) + (thunk) + + ;; Note: the "PROTO:" prefix in SPEC is here so that we can eventually + ;; parse things like "fd:123" in a non-ambiguous way. + (match (string-index spec #\:) + (#f + (leave (G_ "~A: invalid listen specification~%") spec)) + (index + (let ((protocol (string-take spec index)) + (address (string-drop spec (+ index 1)))) + (define socket + (match protocol + ("tcp" + (make-tcp-server-socket #:port (string->number address))) + ("unix" + (make-unix-domain-server-socket #:path address)) + (_ + (leave (G_ "~A: unsupported protocol family~%") + protocol)))) + + (listen socket 10) + (let loop () + (match (accept socket) + ((connection . address) + (if (= AF_UNIX (sockaddr:fam address)) + (info (G_ "accepted connection~%")) + (info (G_ "accepted connection from ~a~%") + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address)))) + (dynamic-wind + (const #t) + (lambda () + (parameterize ((current-input-port connection) + (current-output-port connection)) + (thunk))) + (lambda () + (false-if-exception (close-port connection)) + (info (G_ "connection closed~%")))))) + (loop))))))) + + +(define (guix-repl . args) + (define opts + ;; Return the list of package names. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (G_ "~A: extraneous argument~%") arg)) + %default-options)) + + (with-error-handling + (let ((type (assoc-ref opts 'type))) + (call-with-connection (assoc-ref opts 'listen) + (lambda () + (case type + ((guile) + (save-module-excursion + (lambda () + (set-current-module user-module) + (start-repl)))) + ((machine) + (machine-repl)) + (else + (leave (G_ "~a: unknown type of REPL~%") type)))))))) + +;; Local Variables: +;; eval: (put 'call-with-connection 'scheme-indent-function 1) +;; End: -- cgit v1.2.3