guix/scripts/repl.scm

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