;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*-
;;;
;;;   Time-stamp: <2004-05-15 19:00:42>
;;;   Touched: Thu May 13 15:35:30 2004 +0530
;;;   Bugs-To: <enometh@net.meer>
(defpackage "PSE"
  (:use "CL")
  (:export "SERVE-EVENT" "SERVE-ALL-EVENTS" "ADD-SOCKET-HANDLER"
	   "REMOVE-SOCKET-HANDLER" "SOCKET-ERROR"))
(in-package "PSE")

;;; Roll-our-own serve-event facility for CLISP sockets. Adapted in
;;; part from gilberth's phemlock:src;wire;port.lisp. NOTE: CLISP
;;; doesn't have non-blocking output, so this is a bad hack at best.

(defvar *event-handlers* nil)
(defvar *watch-sockets* nil)
(defstruct handler function socket direction)

(defun add-socket-handler (socket direction fn)	; see add-fd-handler apidoc
  (ecase direction ((:input :output)))
  (unless (find-if (lambda (item)
		     (and (eq socket (car item))
			  (eq direction (cadr item))))
		   *watch-sockets*)
    (push (list socket direction) *watch-sockets*)
    (let ((handler (make-handler :function fn :socket socket
				 :direction direction)))
      (push handler *event-handlers*)
      handler)))

(defun remove-socket-handler (handler)	; see remove-fd-handler
  (setf *event-handlers* (delete handler *event-handlers* :test #'eq))
  (let ((socket (handler-socket handler))
	(direction (handler-direction handler)))
    (setq *watch-sockets*
	  (delete-if (lambda (item)
		       (and (eq socket (car item))
			    (eq direction (cadr item))))
		     *watch-sockets*))))

(define-condition socket-error (error)
  ((handler :initarg :socket-handler :reader socket-handler)
   (encapsulated :initarg :original-error :reader original-error
		 :type condition)))

(defun decode-timeout (timeout)		; from CMUCL:code;serve-event
  (typecase timeout
    (integer (values timeout 0))
    (null (values nil 0))
    (real
     (multiple-value-bind (q r)
	 (truncate (coerce timeout 'single-float))
       (declare (type index q) (single-float r))
       (values q  (truncate (* r 1f6)))))
    (t (error "Timeout is not a real number or NIL: ~S" timeout))))

(defun serve-event (&optional timeout &aux (result nil))
  (multiple-value-bind (watch-sockets n)
      (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
	(socket:socket-status *watch-sockets* to-sec to-usec))
    (loop for (socket direction . active-p) in watch-sockets
	  count active-p into counted
	  when active-p do
	  (let ((handler (find socket *event-handlers* :test #'eq
			       :key #'handler-socket)))
	    (handler-bind ((error (lambda (c)
				    (error 'socket-error
					   :socket-handler handler
					   :original-error c))))
	      (funcall (handler-function handler) socket))
	    (setf result t)) 
	  finally (assert (= n counted)))
    result))

(defun serve-all-events (&optional timeout)
  (do ((res nil)
       (sval (serve-event timeout) (serve-event 0)))
      ((null sval) res)
    (setq res t)))

;;; ----------------------------------------------------------------------
;;; Toy echo server example: service socket connections by reading
;;; lines from sockets and echoing them back.
;;;
(defvar *socket-read-buffers* (make-hash-table :test #'eq))
(defun accept-connection (server-socket)
  (let ((from-socket (socket:socket-accept server-socket
					   :buffered nil
					   :element-type 'character)))
    (setf (gethash from-socket *socket-read-buffers*)
	   (make-array 10 :element-type 'character :adjustable t
		     :fill-pointer 0))
    (ADD-SOCKET-HANDLER from-socket :INPUT #'input-handler)
    (format t "accept-connection: connect from ~a~&" from-socket)
    from-socket))

(defun input-handler (from-socket)
  (let ((buffer (gethash from-socket *socket-read-buffers*)))
    (loop for c = (read-char-no-hang from-socket nil)
	  when (eql c #\newline) do ; echo back what we have.
	  (ext:write-char-sequence buffer from-socket) ; XXX Blocks! oughtnt
	  (terpri from-socket)
	  (setf (fill-pointer buffer) 0)
	  else do (if (null c)
		      (return)
		      (vector-push-extend c buffer)))))

(defvar *toy-echo-server-port* 9999)
(defun toploop (&optional(port *toy-echo-server-port*))
  (let ((server-socket (socket:socket-server port)))
    (ADD-SOCKET-HANDLER server-socket :INPUT #'accept-connection)
    (loop
     (handler-case (SERVE-ALL-EVENTS 1)
       (socket-error (c)
	 (format *debug-io* "caught ~a.~% removing handler ~a.~%"
		 (original-error c) (socket-handler c))
	 (REMOVE-SOCKET-HANDLER (socket-handler c))
	 (remhash (handler-socket (socket-handler c))
		  *socket-read-buffers*))))))

#|;;; junk
(toploop)
(setq *foo-server* (socket:socket-server 9999))
(setq *foo-socket* (accept-connection *foo-server*))
(mapcar #'remove-socket-handler *event-handlers*)
(close *foo-socket*)
(close (socket:socket-accept
	*foo-server*
	:buffered t
	:element-type 'character
	:external-format
	(ext:make-encoding
	 :charset 'charset:iso-8859-1 :line-terminator :unix)))
(socket:socket-server-close *foo-server*)
(trace accept-connection input-handler serve-all-events serve-event)
(trace add-socket remove-socket select)
(trace add-socket-handler remove-socket-handler)
(format t "~:{~S => ~S~&~}"
	(loop for k being each hash-key in *socket-read-buffers*
	      using (hash-value v)
	      collect (list k v)))
(clrhash *socket-read-buffers*)
|#