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 ;;; Copyright © 2020 Konrad Hinsen <konrad.hinsen@fastmail.net>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix scripts repl)
  22   #:use-module (guix ui)
  23   #:use-module (guix scripts)
  24   #:use-module (guix repl)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (srfi srfi-37)
  28   #:use-module (ice-9 match)
  29   #:use-module (rnrs bytevectors)
  30   #:autoload   (system repl repl) (start-repl)
  31   #:autoload   (system repl server)
  32                   (make-tcp-server-socket make-unix-domain-server-socket)
  33   #:export (guix-repl))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; This command provides a Guile script runner and REPL in an environment
  38 ;;; that contains all the modules comprising Guix.
  39
  40 (define %default-options
  41   `((type . guile)))
  42
  43 (define %options
  44   (list (option '(#\h "help") #f #f
  45                 (lambda args
  46                   (show-help)
  47                   (exit 0)))
  48         (option '(#\V "version") #f #f
  49                 (lambda args
  50                   (show-version-and-exit "guix repl")))
  51         (option '(#\t "type") #t #f
  52                 (lambda (opt name arg result)
  53                   (alist-cons 'type (string->symbol arg) result)))
  54         (option '("listen") #t #f
  55                 (lambda (opt name arg result)
  56                   (alist-cons 'listen arg result)))
  57         (option '(#\q) #f #f
  58                 (lambda (opt name arg result)
  59                   (alist-cons 'ignore-dot-guile? #t result)))
  60         (option '(#\L "load-path") #t #f
  61                 (lambda (opt name arg result)
  62                   ;; XXX: Imperatively modify the search paths.
  63                   (set! %load-path (cons arg %load-path))
  64                   (set! %load-compiled-path (cons arg %load-compiled-path))
  65                   result))))
  66
  67
  68 (define (show-help)
  69   (display (G_ "Usage: guix repl [OPTIONS...] [-- FILE ARGS...]
  70 In the Guix execution environment, run FILE as a Guile script with
  71 command-line arguments ARGS.  If no FILE is given, start a Guile REPL.\n"))
  72   (display (G_ "
  73   -t, --type=TYPE        start a REPL of the given TYPE"))
  74   (display (G_ "
  75       --listen=ENDPOINT  listen to ENDPOINT instead of standard input"))
  76   (display (G_ "
  77   -q                     inhibit loading of ~/.guile"))
  78   (newline)
  79   (display (G_ "
  80   -L, --load-path=DIR    prepend DIR to the package module search path"))
  81   (newline)
  82   (display (G_ "
  83   -h, --help             display this help and exit"))
  84   (display (G_ "
  85   -V, --version          display version information and exit"))
  86   (newline)
  87   (show-bug-report-information))
  88
  89 (define user-module
  90   ;; Module where we execute user code.
  91   (let ((module (resolve-module '(guix-user) #f #f #:ensure #t)))
  92     (beautify-user-module! module)
  93     module))
  94
  95 (define (call-with-connection spec thunk)
  96   "Dynamically-bind the current input and output ports according to SPEC and
  97 call THUNK."
  98   (if (not spec)
  99       (thunk)
 100
 101       ;; Note: the "PROTO:" prefix in SPEC is here so that we can eventually
 102       ;; parse things like "fd:123" in a non-ambiguous way.
 103       (match (string-index spec #\:)
 104         (#f
 105          (leave (G_ "~A: invalid listen specification~%") spec))
 106         (index
 107          (let ((protocol (string-take spec index))
 108                (address  (string-drop spec (+ index 1))))
 109            (define socket
 110              (match protocol
 111                ("tcp"
 112                 (make-tcp-server-socket #:port (string->number address)))
 113                ("unix"
 114                 (make-unix-domain-server-socket #:path address))
 115                (_
 116                 (leave (G_ "~A: unsupported protocol family~%")
 117                        protocol))))
 118
 119            (listen socket 10)
 120            (let loop ()
 121              (match (accept socket)
 122                ((connection . address)
 123                 (if (= AF_UNIX (sockaddr:fam address))
 124                     (info (G_ "accepted connection~%"))
 125                     (info (G_ "accepted connection from ~a~%")
 126                           (inet-ntop (sockaddr:fam address)
 127                                      (sockaddr:addr address))))
 128                 (dynamic-wind
 129                   (const #t)
 130                   (lambda ()
 131                     (parameterize ((current-input-port connection)
 132                                    (current-output-port connection))
 133                       (thunk)))
 134                   (lambda ()
 135                     (false-if-exception (close-port connection))
 136                     (info (G_ "connection closed~%"))))))
 137              (loop)))))))
 138
 139 \f
 140 (define-command (guix-repl . args)
 141   (category plumbing)
 142   (synopsis "read-eval-print loop (REPL) for interactive programming")
 143
 144   (define opts
 145     (args-fold* args %options
 146                 (lambda (opt name arg result)
 147                   (leave (G_ "~A: unrecognized option~%") name))
 148                 (lambda (arg result)
 149                   (append `((script . ,arg)
 150                             (ignore-dot-guile? . #t))
 151                           result))
 152                 %default-options))
 153
 154   (define user-config
 155     (and=> (getenv "HOME")
 156            (lambda (home)
 157              (string-append home "/.guile"))))
 158
 159   (define (set-user-module)
 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   (define script
 167     (reverse
 168      (filter-map (match-lambda
 169                    (('script . script) script)
 170                    (_ #f))
 171                  opts)))
 172
 173   (with-error-handling
 174
 175     (unless (null? script)
 176       ;; Run script
 177       (save-module-excursion
 178        (lambda ()
 179          (set-program-arguments script)
 180          (set-user-module)
 181
 182          ;; When passed a relative file name, 'load-in-vicinity' searches the
 183          ;; file in %LOAD-PATH.  Thus, pass (getcwd) instead of ".".
 184          (load-in-vicinity (getcwd) (car script)))))
 185
 186     (when (null? script)
 187       ;; Start REPL
 188       (let ((type (assoc-ref opts 'type)))
 189         (call-with-connection (assoc-ref opts 'listen)
 190           (lambda ()
 191             (case type
 192               ((guile)
 193                (save-module-excursion
 194                 (lambda ()
 195                   (set-user-module)
 196                   ;; Do not exit repl on SIGINT.
 197                   ((@@ (ice-9 top-repl) call-with-sigint)
 198                    (lambda ()
 199                      (start-repl))))))
 200               ((machine)
 201                (machine-repl))
 202               (else
 203                (leave (G_ "~a: unknown type of REPL~%") type)))))))))
 204
 205 ;; Local Variables:
 206 ;; eval: (put 'call-with-connection 'scheme-indent-function 1)
 207 ;; End: