;;;
;;; new-serve-event.lisp
;;;
;;; SBCL/Win32-specific sub-serve-event that allows for a window-message hook.
;;;

(cl:defpackage :new-serve-event
  (:use :common-lisp :sb-alien)
  (:export #:*message-function*))

(cl:in-package :new-serve-event)

#|
TODO:

  Take out the pipe detection in sub-serve-event and replace it with a
monitor thread based around an event.  Only needs to happen for stdin,
after all, and only when it's a thread.


STUPID TRICKS:

  You can't pass an event to _open_osfhandle() (sockint::handle->fd by
any other name), but what you can do is to open a dummy fd-stream (I
suggest using "NUL", with :if-does-not-exist :create in order to work
around the DOS device brain-damage), obtain the fd from the stream,
and the hande from the stream, then push a new mapping to
*fd-wait-handlers* saying that the handle for the stream is signalled
by your new event.  At this point, you can add an :input fd-handler
for the stream's fd and it will be called when the event is signalled.

|#

;;; External interface.

(defvar *message-function*)


;;; Win32 API defs.

(defconstant +qs-allevents+ #x4bf)
(defconstant +infinite+ #xffffffff)
(defconstant +wait-timeout+ #x102)
(defconstant +wait-abandoned-0+ #x80)
(defconstant +wait-failed+ #xffffffff)
(defconstant +fd-read+ 1)
(defconstant +fd-accept+ 8)
(defconstant +socket-error+ -1)

(load-shared-object "KERNEL32")
(load-shared-object "USER32")

(declaim (inline WaitForSingleObject))
(defun WaitForSingleObject (handle milliseconds)
  (alien-funcall (extern-alien "WaitForSingleObject"
			       (function unsigned-long
					 unsigned-long unsigned-long))
		 handle milliseconds))

(declaim (inline MsgWaitForMultipleObjects))
(defun MsgWaitForMultipleObjects (count handles waitall milliseconds wakemask)
  (alien-funcall (extern-alien "MsgWaitForMultipleObjects"
			       (function unsigned-long
					 unsigned-long (* unsigned-long)
					 long unsigned-long unsigned-long))
		 count handles waitall milliseconds wakemask))

(declaim (inline WaitForMultipleObjects))
(defun WaitForMultipleObjects (count handles waitall milliseconds)
  (alien-funcall (extern-alien "WaitForMultipleObjects"
			       (function unsigned-long
					 unsigned-long (* unsigned-long)
					 long unsigned-long))
		 count handles waitall milliseconds))

(declaim (inline wsa-create-event))
(defun wsa-create-event ()
  (alien-funcall (extern-alien "WSACreateEvent" (function unsigned-long))))

(declaim (inline wsa-event-select))
(defun wsa-event-select (socket event flags)
  (alien-funcall (extern-alien "WSAEventSelect"
			       (function int
					 unsigned-long unsigned-long
					 unsigned-long))
		 socket event flags))

(declaim (inline wsa-close-event))
(defun wsa-close-event (handle)
  (alien-funcall (extern-alien "WSACloseEvent" (function int unsigned-long))
		 handle))


;;; Hidden communication channel.

(defvar *fd-wait-handles* nil
  "A list of file-descriptor -> handle,type mappings for specialized handling in serve-event because of WaitForMultipleObject limitations.")


;;; Serve-event damage.

(sb-ext:without-package-locks
  (defun sb-impl::sub-serve-event (to-sec to-usec deadlinep)
    ;(format sb-sys:*stdout* "sub-serve: waithandles ~S~%" *fd-wait-handles*)
    ;(format sb-sys:*stdout* "sa: ~S~%" *standard-output*)
    (sb-alien:with-alien ((handles (array unsigned-long 63)))

      ;; NOTE: Can't have more than 63 handles (api limit).
      ;; FIXME: Enforce this.
      (let ((count 0)
	    (pipe-ready nil)
	    (timeout (cond ((or to-sec to-usec)
			    (+ (* (or to-sec 0) 1000)
			       (or to-usec 0)))
			   (t
			    (unless sb-sys:*interrupts-enabled*
			      (sb-unix::note-dangerous-select))
			    +infinite+))))

	(sb-impl::map-descriptor-handlers
	 (lambda (handler)
	   (unless (sb-impl::handler-bogus handler)
	     (ecase (sb-impl::handler-direction handler)
	       (:input
		(let* ((fd (sb-impl::handler-descriptor handler))
		       (handle (sockint::fd->handle fd))
		       (waithandle (find handle *fd-wait-handles* :key #'first)))
		  (with-alien ((avail unsigned-long))
		    (if (zerop (sb-win32:peek-named-pipe handle nil 0
							 nil (addr avail) nil))
		      (progn
			;(format sb-sys:*stdout* "count ~A: ~A (~A, ~A)~%" count handle fd waithandle)
			(if waithandle
			    (setf (deref handles count) (second waithandle))
			    (setf (deref handles count) handle))
			(incf count))
		      (setf pipe-ready t)))))
	       (:output
		;; Don't do anything here.
		)))))

	;(format sb-sys:*stdout* "count: ~X~%" count)
	(let ((result (if (zerop count)
			  ;; Either there are no descriptor handlers or they're
			  ;; all pipes.  We don't dare call a wait function.
			  (if (boundp '*message-function*)
			      ;; These results lose no matter what.
			      count
			      (progn
				(sleep 0.5)
				nil))
			  ;; There are valid descriptor handlers that aren't pipes.
			  (if (boundp '*message-function*)
			      (MsgWaitForMultipleObjects count (addr (deref handles 0))
							 0 timeout +qs-allevents+)
			      (WaitForMultipleObjects count (addr (deref handles 0))
						      0 timeout)))))
	  ;(format sb-sys:*stdout* "result: ~X~%" result)
	  (when pipe-ready
	    (dolist (handler (sb-impl::select-descriptor-handlers
			      (lambda (handler)
				(ecase (sb-impl::handler-direction handler)
				  (:input
				   (with-alien ((avail unsigned-long))
				     (and (not (zerop (sb-win32:peek-named-pipe (sockint::fd->handle (sb-impl::handler-descriptor handler)) nil 0 nil (addr avail) nil)))
					  (not (zerop avail)))))
				  (:output
				   ;; Handles are always ready for output.
				   t)))))
	      ;(format sb-sys:*stdout* "calling handler ~A~%" handler)
	      (funcall (sb-impl::handler-function handler)
		       (sb-impl::handler-descriptor handler))
	      t))
	  (cond ((eq result nil))
		((< result count)
		 ;; The result'th handle in handles is ready for reading.
		 (let* ((handle (deref handles result))
			(waithandle (find handle *fd-wait-handles* :key #'second)))
		   ;(format sb-sys:*stdout* "handle: ~A, waithandle: ~A~%" handle waithandle)
		   (dolist (handler (sb-impl::select-descriptor-handlers
				     (lambda (handler)
				       (ecase (sb-impl::handler-direction handler)
					 (:input
					  (or
					   (and waithandle
						(= (sockint::fd->handle
						    (sb-impl::handler-descriptor handler))
						   (first waithandle)))
					   (= (sockint::fd->handle
					       (sb-impl::handler-descriptor handler))
					     handle)))
					 (:output
					  ;; Handles are always ready for output.
					  t)))))
		     ;(format sb-sys:*stdout* "calling handler ~A~%" handler)
		     (funcall (sb-impl::handler-function handler)
			      (sb-impl::handler-descriptor handler))
		     t)))
		((= result count)
		 ;; There is a windows message ready.
		 (funcall *message-function*)
		 t)
		((= result +wait-timeout+)
		 ;(format sb-sys:*stdout* "bar~%")
		 ;; The timeout elapsed.
		 (when deadlinep
		   (sb-sys:signal-deadline))
		 nil)
		(t
		 ;(format sb-sys:*stdout* "foo~%")
		 ;; Something unexpected happened, should probably error.
		 (sb-impl::handler-descriptors-error) ;; ???
		 )))))))


;;; Sb-bsd-sockets damage.

(defun sockint::bind (fd &rest options)
  (let ((handle (sockint::fd->handle fd))
	(event (wsa-create-event)))
    (wsa-event-select handle event +fd-accept+)
    (push (list handle event :host-socket) *fd-wait-handles*)

    (apply #'sockint::win32-bind handle options)))

(defun sockint::close (fd &rest options)
  (let* ((handle (sockint::fd->handle fd))
	 (result (apply #'sockint::win32-close handle options)))

    (setf *fd-wait-handles*
	  (delete-if
	   (lambda (entry)
	     (when (= (first entry) handle)
	       (when (second entry)
		 (wsa-close-event (second entry))
		 (setf (second entry) nil))
	       t))
	   *fd-wait-handles*))

    result))

(defun sockint::accept (fd &rest options)
  (let ((handle (apply #'sockint::win32-accept (sockint::fd->handle fd) options))
	(event (wsa-create-event)))
    (wsa-event-select handle event +fd-read+)
    (push (list handle event :data-socket) *fd-wait-handles*)
    (sockint::handle->fd handle 0)))


;;; Sb-win32 damage.

(sb-ext:without-package-locks
  (defun sb-win32:handle-listen (handle)
    (with-alien ((avail sb-win32:dword)
		 (buf (array char #.sb-win32::input-record-size)))
      (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil (addr avail) nil))
	(return-from sb-win32:handle-listen (plusp avail)))
    
      (unless (zerop (sb-win32:peek-console-input handle
						  (cast buf (* t))
						  sb-win32::input-record-size (addr avail)))
	(return-from sb-win32:handle-listen (plusp avail)))

      (let ((waithandle (find handle *fd-wait-handles* :key #'first)))
	(when waithandle
	  (let ((result (WaitForSingleObject (second waithandle) 0)))
	    ;(format sb-sys:*stdout* "hl: ~S / ~S~%" waithandle result)
	    (when (or (zerop result)
		      (= result +wait-timeout+))
	      (return-from sb-win32:handle-listen (zerop result))))))

      t)))


;;; Sb-unix damage.

(sb-ext:without-package-locks
  (defun sb-unix:unix-read (fd buf len)
    (declare (type sb-unix::unix-fd fd)
	     (type (unsigned-byte 32) len))
    (let* ((handle (sb-win32:get-osfhandle fd))
	   (waithandle (find handle *fd-wait-handles* :key #'first)))
      (if (and waithandle (eq (third waithandle) :data-socket))
	  (progn
	    (alien-funcall (extern-alien "WSAResetEvent" (function int unsigned-long))
			   (second waithandle))
	    (let ((result (sockint::win32-recv handle buf len 0)))
	      (if (= result +socket-error+)
		  (values nil (if (= 10035 (sockint::wsa-get-last-error)) 'sb-unix:ewouldblock 0))
		  (values result 0))))
	  (sb-unix::int-syscall ("read" int (* char) int) fd buf len)))))


;; Fd-stream damage.

(sb-ext:without-package-locks
  (defun sb-impl::refill-input-buffer (stream)
    (let ((fd (sb-impl::fd-stream-fd stream))
	  (errno 0)
	  (count 0))
      (tagbody
	 ;; Check for blocking input before touching the stream, as if
	 ;; we happen to wait we are liable to be interrupted, and the
	 ;; interrupt handler may use the same stream.
	 (if (sb-impl::sysread-may-block-p stream)
	     (go :wait-for-input)
	     (go :main))
	 ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
	 ;; we can signal errors outside the WITHOUT-INTERRUPTS.
       :closed-flame
	 (sb-impl::closed-flame stream)
       :read-error
	 (sb-impl::simple-stream-perror "couldn't read from ~S" stream errno)
       :wait-for-input
	 ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
	 ;; to wait for input if read tells us EWOULDBLOCK.
	 (unless (sb-impl::wait-until-fd-usable fd :input (sb-impl::fd-stream-timeout stream))
	   (sb-impl::signal-timeout 'io-timeout :stream stream :direction :read
				    :seconds (sb-impl::fd-stream-timeout stream)))
       :main
	 ;; Since the read should not block, we'll disable the
	 ;; interrupts here, so that we don't accidentally unwind and
	 ;; leave the stream in an inconsistent state.
	 (sb-sys:without-interrupts
	   ;; Check the buffer: if it is null, then someone has closed
	   ;; the stream from underneath us. This is not ment to fix
	   ;; multithreaded races, but to deal with interrupt handlers
	   ;; closing the stream.
	   (let* ((ibuf (or (sb-impl::fd-stream-ibuf stream) (go :closed-flame)))
		  (sap (sb-impl::buffer-sap ibuf))
		  (length (sb-impl::buffer-length ibuf))
		  (head (sb-impl::buffer-head ibuf))
		  (tail (sb-impl::buffer-tail ibuf)))
	     (declare (sb-impl::index length head tail))
	     (unless (zerop head)
	       (cond ((eql head tail)
		      ;; Buffer is empty, but not at yet reset -- make it so.
		      (setf head 0
			    tail 0)
		      (sb-impl::reset-buffer ibuf))
		     (t
		      ;; Buffer has things in it, but they are not at the head
		      ;; -- move them there.
		      (let ((n (- tail head)))
			(sb-kernel:system-area-ub8-copy sap head sap 0 n)
			(setf head 0
			      (sb-impl::buffer-head ibuf) head
			      tail n
			      (sb-impl::buffer-tail ibuf) tail)))))
	     (setf (sb-impl::fd-stream-listen stream) nil)
	     (setf (values count errno)
		   (sb-unix:unix-read fd (sb-sys:sap+ sap tail) (- length tail)))
	     (cond ((null count)
		    (if (eql errno 'sb-unix:ewouldblock)
			(go :wait-for-input)
			(go :read-error)))
		   ((zerop count)
		    (setf (sb-impl::fd-stream-listen stream) :eof)
					;(/show0 "THROWing EOF-INPUT-CATCHER")
		    (throw 'sb-impl::eof-input-catcher nil))
		   (t
		    ;; Success! (Do not use INCF, for sake of other threads.)
		    (setf (sb-impl::buffer-tail ibuf) (+ count tail)))))))
      count)))


;;; EOF