guix/scripts/repl.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix scripts repl)
  20   #:use-module (guix ui)
  21   #:use-module (guix scripts)
  22   #:use-module (guix utils)
  23   #:use-module (guix packages)
  24   #:use-module (gnu packages)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-37)
  27   #:use-module (ice-9 match)
  28   #:use-module (rnrs bytevectors)
  29   #:autoload   (system repl repl) (start-repl)
  30   #:autoload   (system repl server)
  31                   (make-tcp-server-socket make-unix-domain-server-socket)
  32   #:export (machine-repl
  33             guix-repl))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; This command provides a Guile REPL
  38
  39 (define %default-options
  40   `((type . guile)))
  41
  42 (define %options
  43   (list (option '(#\h "help") #f #f
  44                 (lambda args
  45                   (show-help)
  46                   (exit 0)))
  47         (option '(#\V "version") #f #f
  48                 (lambda args
  49                   (show-version-and-exit "guix repl")))
  50         (option '(#\t "type") #t #f
  51                 (lambda (opt name arg result)
  52                   (alist-cons 'type (string->symbol arg) result)))
  53         (option '("listen") #t #f
  54                 (lambda (opt name arg result)
  55                   (alist-cons 'listen arg result)))))
  56
  57
  58 (define (show-help)
  59   (display (G_ "Usage: guix repl [OPTIONS...]
  60 Start a Guile REPL in the Guix execution environment.\n"))
  61   (display (G_ "
  62   -t, --type=TYPE        start a REPL of the given TYPE"))
  63   (newline)
  64   (display (G_ "
  65   -h, --help             display this help and exit"))
  66   (display (G_ "
  67   -V, --version          display version information and exit"))
  68   (newline)
  69   (show-bug-report-information))
  70
  71 (define (self-quoting? x)
  72   "Return #t if X is self-quoting."
  73   (letrec-syntax ((one-of (syntax-rules ()
  74                             ((_) #f)
  75                             ((_ pred rest ...)
  76                              (or (pred x)
  77                                  (one-of rest ...))))))
  78     (one-of symbol? string? pair? null? vector?
  79             bytevector? number? boolean?)))
  80
  81 (define user-module
  82   ;; Module where we execute user code.
  83   (let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
  84     (beautify-user-module! module)
  85     module))
  86
  87 (define* (machine-repl #:optional
  88                        (input (current-input-port))
  89                        (output (current-output-port)))
  90   "Run a machine-usable REPL over ports INPUT and OUTPUT.
  91
  92 The protocol of this REPL is meant to be machine-readable and provides proper
  93 support to represent multiple-value returns, exceptions, objects that lack a
  94 read syntax, and so on.  As such it is more convenient and robust than parsing
  95 Guile's REPL prompt."
  96   (define (value->sexp value)
  97     (if (self-quoting? value)
  98         `(value ,value)
  99         `(non-self-quoting ,(object-address value)
 100                            ,(object->string value))))
 101
 102   (write `(repl-version 0 0) output)
 103   (newline output)
 104   (force-output output)
 105
 106   (let loop ()
 107     (match (read input)
 108       ((? eof-object?) #t)
 109       (exp
 110        (catch #t
 111          (lambda ()
 112            (let ((results (call-with-values
 113                               (lambda ()
 114
 115                                 (primitive-eval exp))
 116                             list)))
 117              (write `(values ,@(map value->sexp results))
 118                     output)
 119              (newline output)
 120              (force-output output)))
 121          (lambda (key . args)
 122            (write `(exception ,key ,@(map value->sexp args)))
 123            (newline output)
 124            (force-output output)))
 125        (loop)))))
 126
 127 (define (call-with-connection spec thunk)
 128   "Dynamically-bind the current input and output ports according to SPEC and
 129 call THUNK."
 130   (if (not spec)
 131       (thunk)
 132
 133       ;; Note: the "PROTO:" prefix in SPEC is here so that we can eventually
 134       ;; parse things like "fd:123" in a non-ambiguous way.
 135       (match (string-index spec #\:)
 136         (#f
 137          (leave (G_ "~A: invalid listen specification~%") spec))
 138         (index
 139          (let ((protocol (string-take spec index))
 140                (address  (string-drop spec (+ index 1))))
 141            (define socket
 142              (match protocol
 143                ("tcp"
 144                 (make-tcp-server-socket #:port (string->number address)))
 145                ("unix"
 146                 (make-unix-domain-server-socket #:path address))
 147                (_
 148                 (leave (G_ "~A: unsupported protocol family~%")
 149                        protocol))))
 150
 151            (listen socket 10)
 152            (let loop ()
 153              (match (accept socket)
 154                ((connection . address)
 155                 (if (= AF_UNIX (sockaddr:fam address))
 156                     (info (G_ "accepted connection~%"))
 157                     (info (G_ "accepted connection from ~a~%")
 158                           (inet-ntop (sockaddr:fam address)
 159                                      (sockaddr:addr address))))
 160                 (dynamic-wind
 161                   (const #t)
 162                   (lambda ()
 163                     (parameterize ((current-input-port connection)
 164                                    (current-output-port connection))
 165                       (thunk)))
 166                   (lambda ()
 167                     (false-if-exception (close-port connection))
 168                     (info (G_ "connection closed~%"))))))
 169              (loop)))))))
 170
 171 \f
 172 (define (guix-repl . args)
 173   (define opts
 174     ;; Return the list of package names.
 175     (args-fold* args %options
 176                 (lambda (opt name arg result)
 177                   (leave (G_ "~A: unrecognized option~%") name))
 178                 (lambda (arg result)
 179                   (leave (G_ "~A: extraneous argument~%") arg))
 180                 %default-options))
 181
 182   (with-error-handling
 183     (let ((type (assoc-ref opts 'type)))
 184       (call-with-connection (assoc-ref opts 'listen)
 185         (lambda ()
 186           (case type
 187             ((guile)
 188              (save-module-excursion
 189               (lambda ()
 190                 (set-current-module user-module)
 191                 (start-repl))))
 192             ((machine)
 193              (machine-repl))
 194             (else
 195              (leave (G_ "~a: unknown type of REPL~%") type))))))))
 196
 197 ;; Local Variables:
 198 ;; eval: (put 'call-with-connection 'scheme-indent-function 1)
 199 ;; End: