summaryrefslogtreecommitdiff
path: root/2d/repl/server.scm
diff options
context:
space:
mode:
Diffstat (limited to '2d/repl/server.scm')
-rw-r--r--2d/repl/server.scm132
1 files changed, 132 insertions, 0 deletions
diff --git a/2d/repl/server.scm b/2d/repl/server.scm
new file mode 100644
index 0000000..9498b1d
--- /dev/null
+++ b/2d/repl/server.scm
@@ -0,0 +1,132 @@
+;;; Repl server
+
+;; Copyright (C) 2003, 2010, 2011 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 (2d repl server)
+ #:use-module (2d 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 call-with-sigint
+ (if (not (provided? 'posix))
+ (lambda (thunk) (thunk))
+ (lambda (thunk)
+ (let ((handler #f))
+ (dynamic-wind
+ (lambda ()
+ (set! handler
+ (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
+ thunk
+ (lambda ()
+ (if handler
+ ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+ (sigaction SIGINT (car handler) (cdr handler))
+ ;; restore original C handler.
+ (sigaction SIGINT #f))))))))
+
+(define* (run-server #:optional (server-socket (make-tcp-server-socket)))
+ (define (accept-new-client)
+ (catch #t
+ (lambda () (call-with-sigint (lambda () (accept server-socket))))
+ (lambda (k . args)
+ (cond
+ ((port-closed? server-socket)
+ ;; Shutting down.
+ #f)
+ ((eq? k 'interrupt)
+ ;; Interrupt.
+ (close-socket! server-socket)
+ #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 ()
+ (with-input-from-port client
+ (lambda ()
+ (with-output-to-port client
+ (lambda ()
+ (with-error-to-port client
+ (lambda ()
+ (with-fluids ((*repl-stack* '()))
+ (start-repl))))))))))
+ (close-socket! client))