;; This program implements a UNIX socket server which multiplexes
;; (single request/reply) transactions on a socket to a lisp REPL on
;; stdin/stdout. All client transactions are queued. All i/o is
;; synchronous.

;; The main use for this to share a single (lisp) server between
;; multiple (lisp) clients. The REPL server is connected on
;; stdin/stdout, which gives greatest flexibility.

;; This can be used to cache connection costs from remote hosts: Start
;; a REPL locally, but connect it to a channel server on another host
;; through SSH.


(define (forward from to)
  (write (read from) to)
  (newline to))                ;; make sure atoms are whitespace separated

;; service a client
(define (service client)
  (forward client (current-output-port))
  (forward (current-input-port) client)
  ;(close client)
)

;; select for input, and perform action
;; actions maps port -> thunk
(define (input-actions actions)
  (let ((read-ports (map car actions)))    ;; get ports/fds
    (map
     (lambda (port)
       ((assoc-ref actions port)))         ;; lookup & exec action
     (car (select read-ports '() '())))))
  

(define (start-server node)
  (let ((sock   (socket AF_UNIX SOCK_STREAM 0))
	(stdin  (current-input-port))   ;; does not work when readline=stdin 
	(stdout (current-output-port)))
    
    (setvbuf stdout _IONBF)   ;; need nonbuf on output
    (bind sock AF_UNIX node)  ;; create unix socket
    (listen sock 5)           ;; start listening


    (let
	((actions 
	  `((,sock  
	     . ,(lambda () ;; service client request
		  (service 
		   (car (accept sock)))))
	    (,stdin
	     . ,(lambda () ;; only whitespace allowed on input channel
		  (let ((thing (peek-char stdin)))
		    (cond ((eof-object? thing) (exit 0))
			  ((char-whitespace? thing) (read-char stdin))
			  (else (exit 1)))))))))

      (while #t (input-actions actions)))))


;; FIXME: error handling
(define (main args) 
  (catch #t
    (lambda ()
      (apply start-server (cdr args)))
    (lambda error
      (with-output-to-file "/tmp/shit.log"
	(lambda ()
	  (display error)
	  (newline))))))