mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 20:30:28 +02:00
8a114e1b54
* module/system/repl/server.scm (run-server): Remove case that handled
'interrupt' exceptions specially. It is no longer needed since
e6c8e6047e (REPL Server: Don't establish
a SIGINT handler.)
109 lines
3.5 KiB
Scheme
109 lines
3.5 KiB
Scheme
;;; Repl server
|
|
|
|
;; Copyright (C) 2003, 2010, 2011, 2014 Free Software Foundation, Inc.
|
|
|
|
;; This library is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public
|
|
;; License as published by the Free Software Foundation; either
|
|
;; version 3 of the License, or (at your option) any later version.
|
|
;;
|
|
;; This library 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
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public
|
|
;; License along with this library; if not, write to the Free Software
|
|
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
;; 02110-1301 USA
|
|
|
|
;;; Code:
|
|
|
|
(define-module (system repl server)
|
|
#:use-module (system repl repl)
|
|
#:use-module (ice-9 threads)
|
|
#:export (make-tcp-server-socket
|
|
make-unix-domain-server-socket
|
|
run-server
|
|
spawn-server
|
|
stop-server-and-clients!))
|
|
|
|
(define *open-sockets* '())
|
|
|
|
(define sockets-lock (make-mutex))
|
|
|
|
(define (close-socket! s)
|
|
(with-mutex sockets-lock
|
|
(set! *open-sockets* (delq! s *open-sockets*)))
|
|
;; Close-port could block or raise an exception flushing buffered
|
|
;; output. Hmm.
|
|
(close-port s))
|
|
|
|
(define (add-open-socket! s)
|
|
(with-mutex sockets-lock
|
|
(set! *open-sockets* (cons s *open-sockets*))))
|
|
|
|
(define (stop-server-and-clients!)
|
|
(cond
|
|
((with-mutex sockets-lock
|
|
(and (pair? *open-sockets*)
|
|
(car *open-sockets*)))
|
|
=> (lambda (s)
|
|
(close-socket! s)
|
|
(stop-server-and-clients!)))))
|
|
|
|
(define* (make-tcp-server-socket #:key
|
|
(host #f)
|
|
(addr (if host (inet-aton host) INADDR_LOOPBACK))
|
|
(port 37146))
|
|
(let ((sock (socket PF_INET SOCK_STREAM 0)))
|
|
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
|
|
(bind sock AF_INET addr port)
|
|
sock))
|
|
|
|
(define* (make-unix-domain-server-socket #:key (path "/tmp/guile-socket"))
|
|
(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
|
|
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
|
|
(bind sock AF_UNIX path)
|
|
sock))
|
|
|
|
(define* (run-server #:optional (server-socket (make-tcp-server-socket)))
|
|
(define (accept-new-client)
|
|
(catch #t
|
|
(lambda () (accept server-socket))
|
|
(lambda (k . args)
|
|
(cond
|
|
((port-closed? server-socket)
|
|
;; Shutting down.
|
|
#f)
|
|
(else
|
|
(warn "Error accepting client" k args)
|
|
;; Retry after a timeout.
|
|
(sleep 1)
|
|
(accept-new-client))))))
|
|
|
|
(sigaction SIGPIPE SIG_IGN)
|
|
(add-open-socket! server-socket)
|
|
(listen server-socket 5)
|
|
(let lp ((client (accept-new-client)))
|
|
;; If client is false, we are shutting down.
|
|
(if client
|
|
(let ((client-socket (car client))
|
|
(client-addr (cdr client)))
|
|
(add-open-socket! client-socket)
|
|
(make-thread serve-client client-socket client-addr)
|
|
(lp (accept-new-client))))))
|
|
|
|
(define* (spawn-server #:optional (server-socket (make-tcp-server-socket)))
|
|
(make-thread run-server server-socket))
|
|
|
|
(define (serve-client client addr)
|
|
(with-continuation-barrier
|
|
(lambda ()
|
|
(parameterize ((current-input-port client)
|
|
(current-output-port client)
|
|
(current-error-port client)
|
|
(current-warning-port client))
|
|
(with-fluids ((*repl-stack* '()))
|
|
(start-repl)))))
|
|
(close-socket! client))
|