1002 lines
40 KiB
Common Lisp
1002 lines
40 KiB
Common Lisp
|
;;;; See LICENSE for licensing information.
|
||
|
|
|
||
|
|
(in-package :usocket)
|
||
|
|
|
||
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||
|
|
(require "comm")
|
||
|
|
|
||
|
|
#+lispworks3
|
||
|
|
(error "LispWorks 3 is not supported"))
|
||
|
|
|
||
|
|
;;; ---------------------------------------------------------------------------
|
||
|
|
;;; Warn if multiprocessing is not running on Lispworks
|
||
|
|
|
||
|
|
(defun check-for-multiprocessing-started (&optional errorp)
|
||
|
|
(unless mp:*current-process*
|
||
|
|
(funcall (if errorp 'error 'warn)
|
||
|
|
"You must start multiprocessing on Lispworks by calling~
|
||
|
|
~%~3t(~s)~
|
||
|
|
~%for ~s function properly."
|
||
|
|
'mp:initialize-multiprocessing
|
||
|
|
'wait-for-input)))
|
||
|
|
|
||
|
|
(eval-when (:load-toplevel :execute)
|
||
|
|
(check-for-multiprocessing-started))
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(eval-when (:load-toplevel :execute)
|
||
|
|
(fli:register-module "ws2_32"))
|
||
|
|
|
||
|
|
(fli:define-foreign-function (get-host-name-internal "gethostname" :source)
|
||
|
|
((return-string (:reference-return (:ef-mb-string :limit 257)))
|
||
|
|
(namelen :int))
|
||
|
|
:lambda-list (&aux (namelen 256) return-string)
|
||
|
|
:result-type :int
|
||
|
|
#+win32 :module
|
||
|
|
#+win32 "ws2_32")
|
||
|
|
|
||
|
|
(defun get-host-name ()
|
||
|
|
(multiple-value-bind (return-code name)
|
||
|
|
(get-host-name-internal)
|
||
|
|
(when (zerop return-code)
|
||
|
|
name)))
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(defun remap-maybe-for-win32 (z)
|
||
|
|
(mapcar #'(lambda (x)
|
||
|
|
(cons (mapcar #'(lambda (y) (+ 10000 y)) (car x))
|
||
|
|
(cdr x)))
|
||
|
|
z))
|
||
|
|
|
||
|
|
(defparameter +lispworks-error-map+
|
||
|
|
#+win32
|
||
|
|
(append (remap-maybe-for-win32 +unix-errno-condition-map+)
|
||
|
|
(remap-maybe-for-win32 +unix-errno-error-map+))
|
||
|
|
#-win32
|
||
|
|
(append +unix-errno-condition-map+
|
||
|
|
+unix-errno-error-map+))
|
||
|
|
|
||
|
|
(defun raise-usock-err (errno socket &optional condition (host-or-ip nil))
|
||
|
|
(let ((usock-error
|
||
|
|
(cdr (assoc errno +lispworks-error-map+ :test #'member))))
|
||
|
|
(if usock-error
|
||
|
|
(if (subtypep usock-error 'error)
|
||
|
|
(cond ((subtypep usock-error 'ns-error)
|
||
|
|
(error usock-error :socket socket :host-or-ip host-or-ip))
|
||
|
|
(t
|
||
|
|
(error usock-error :socket socket)))
|
||
|
|
(cond ((subtypep usock-error 'ns-condition)
|
||
|
|
(signal usock-error :socket socket :host-or-ip host-or-ip))
|
||
|
|
(t
|
||
|
|
(signal usock-error :socket socket))))
|
||
|
|
(error 'unknown-error
|
||
|
|
:socket socket
|
||
|
|
:real-error condition
|
||
|
|
:errno errno))))
|
||
|
|
|
||
|
|
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
|
||
|
|
"Dispatch correct usocket condition."
|
||
|
|
(typecase condition
|
||
|
|
(condition (let ((errno #-win32 (lw:errno-value)
|
||
|
|
#+win32 (wsa-get-last-error)))
|
||
|
|
(unless (zerop errno)
|
||
|
|
(raise-usock-err errno socket condition host-or-ip))))))
|
||
|
|
|
||
|
|
(defconstant *socket_sock_dgram* 2
|
||
|
|
"Connectionless, unreliable datagrams of fixed maximum length.")
|
||
|
|
|
||
|
|
(defconstant *socket_ip_proto_udp* 17)
|
||
|
|
|
||
|
|
(defconstant *sockopt_so_rcvtimeo*
|
||
|
|
#-linux #x1006
|
||
|
|
#+linux 20
|
||
|
|
"Socket receive timeout")
|
||
|
|
|
||
|
|
(defconstant *sockopt_so_sndtimeo*
|
||
|
|
#-linux #x1007
|
||
|
|
#+linux 21
|
||
|
|
"Socket send timeout")
|
||
|
|
|
||
|
|
(fli:define-c-struct timeval
|
||
|
|
(tv-sec :long)
|
||
|
|
(tv-usec :long))
|
||
|
|
|
||
|
|
;;; ssize_t
|
||
|
|
;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags,
|
||
|
|
;;; struct sockaddr *restrict address, socklen_t *restrict address_len);
|
||
|
|
(fli:define-foreign-function (%recvfrom "recvfrom" :source)
|
||
|
|
((socket :int)
|
||
|
|
(buffer (:pointer (:unsigned :byte)))
|
||
|
|
(length :int)
|
||
|
|
(flags :int)
|
||
|
|
(address (:pointer (:struct comm::sockaddr)))
|
||
|
|
(address-len (:pointer :int)))
|
||
|
|
:result-type :int
|
||
|
|
#+win32 :module
|
||
|
|
#+win32 "ws2_32")
|
||
|
|
|
||
|
|
;;; ssize_t
|
||
|
|
;;; sendto(int socket, const void *buffer, size_t length, int flags,
|
||
|
|
;;; const struct sockaddr *dest_addr, socklen_t dest_len);
|
||
|
|
(fli:define-foreign-function (%sendto "sendto" :source)
|
||
|
|
((socket :int)
|
||
|
|
(buffer (:pointer (:unsigned :byte)))
|
||
|
|
(length :int)
|
||
|
|
(flags :int)
|
||
|
|
(address (:pointer (:struct comm::sockaddr)))
|
||
|
|
(address-len :int))
|
||
|
|
:result-type :int
|
||
|
|
#+win32 :module
|
||
|
|
#+win32 "ws2_32")
|
||
|
|
|
||
|
|
#-win32
|
||
|
|
(defun set-socket-receive-timeout (socket-fd seconds)
|
||
|
|
"Set socket option: RCVTIMEO, argument seconds can be a float number"
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type number seconds))
|
||
|
|
(multiple-value-bind (sec usec) (truncate seconds)
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
|
||
|
|
(fli:with-foreign-slots (tv-sec tv-usec) timeout
|
||
|
|
(setf tv-sec sec
|
||
|
|
tv-usec (truncate (* 1000000 usec)))
|
||
|
|
(if (zerop (comm::setsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_rcvtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :void))
|
||
|
|
(fli:size-of '(:struct timeval))))
|
||
|
|
seconds)))))
|
||
|
|
|
||
|
|
#-win32
|
||
|
|
(defun set-socket-send-timeout (socket-fd seconds)
|
||
|
|
"Set socket option: SNDTIMEO, argument seconds can be a float number"
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type number seconds))
|
||
|
|
(multiple-value-bind (sec usec) (truncate seconds)
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
|
||
|
|
(fli:with-foreign-slots (tv-sec tv-usec) timeout
|
||
|
|
(setf tv-sec sec
|
||
|
|
tv-usec (truncate (* 1000000 usec)))
|
||
|
|
(if (zerop (comm::setsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_sndtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :void))
|
||
|
|
(fli:size-of '(:struct timeval))))
|
||
|
|
seconds)))))
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(defun set-socket-receive-timeout (socket-fd seconds)
|
||
|
|
"Set socket option: RCVTIMEO, argument seconds can be a float number.
|
||
|
|
On win32, you must bind the socket before use this function."
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type number seconds))
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout :int))
|
||
|
|
(setf (fli:dereference timeout)
|
||
|
|
(truncate (* 1000 seconds)))
|
||
|
|
(if (zerop (comm::setsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_rcvtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :char))
|
||
|
|
(fli:size-of :int)))
|
||
|
|
seconds)))
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(defun set-socket-send-timeout (socket-fd seconds)
|
||
|
|
"Set socket option: SNDTIMEO, argument seconds can be a float number.
|
||
|
|
On win32, you must bind the socket before use this function."
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type number seconds))
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout :int))
|
||
|
|
(setf (fli:dereference timeout)
|
||
|
|
(truncate (* 1000 seconds)))
|
||
|
|
(if (zerop (comm::setsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_sndtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :char))
|
||
|
|
(fli:size-of :int)))
|
||
|
|
seconds)))
|
||
|
|
|
||
|
|
#-win32
|
||
|
|
(defun get-socket-receive-timeout (socket-fd)
|
||
|
|
"Get socket option: RCVTIMEO, return value is a float number"
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
|
||
|
|
(len :int))
|
||
|
|
(comm::getsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_rcvtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :void))
|
||
|
|
len)
|
||
|
|
(fli:with-foreign-slots (tv-sec tv-usec) timeout
|
||
|
|
(float (+ tv-sec (/ tv-usec 1000000))))))
|
||
|
|
|
||
|
|
#-win32
|
||
|
|
(defun get-socket-send-timeout (socket-fd)
|
||
|
|
"Get socket option: SNDTIMEO, return value is a float number"
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
|
||
|
|
(len :int))
|
||
|
|
(comm::getsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_sndtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :void))
|
||
|
|
len)
|
||
|
|
(fli:with-foreign-slots (tv-sec tv-usec) timeout
|
||
|
|
(float (+ tv-sec (/ tv-usec 1000000))))))
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(defun get-socket-receive-timeout (socket-fd)
|
||
|
|
"Get socket option: RCVTIMEO, return value is a float number"
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout :int)
|
||
|
|
(len :int))
|
||
|
|
(comm::getsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_rcvtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :void))
|
||
|
|
len)
|
||
|
|
(float (/ (fli:dereference timeout) 1000))))
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(defun get-socket-send-timeout (socket-fd)
|
||
|
|
"Get socket option: SNDTIMEO, return value is a float number"
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((timeout :int)
|
||
|
|
(len :int))
|
||
|
|
(comm::getsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
*sockopt_so_sndtimeo*
|
||
|
|
(fli:copy-pointer timeout
|
||
|
|
:type '(:pointer :void))
|
||
|
|
len)
|
||
|
|
(float (/ (fli:dereference timeout) 1000))))
|
||
|
|
|
||
|
|
#+(or lispworks4 lispworks5.0)
|
||
|
|
(defun set-socket-tcp-nodelay (socket-fd new-value)
|
||
|
|
"Set socket option: TCP_NODELAY, argument is a fixnum (0 or 1)"
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type (integer 0 1) new-value))
|
||
|
|
(fli:with-dynamic-foreign-objects ((zero-or-one :int))
|
||
|
|
(setf (fli:dereference zero-or-one) new-value)
|
||
|
|
(when (zerop (comm::setsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
comm::*sockopt_tcp_nodelay*
|
||
|
|
(fli:copy-pointer zero-or-one
|
||
|
|
:type '(:pointer #+win32 :char #-win32 :void))
|
||
|
|
(fli:size-of :int)))
|
||
|
|
new-value)))
|
||
|
|
|
||
|
|
(defun get-socket-tcp-nodelay (socket-fd)
|
||
|
|
"Get socket option: TCP_NODELAY, return value is a fixnum (0 or 1)"
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((zero-or-one :int)
|
||
|
|
(len :int))
|
||
|
|
(if (zerop (comm::getsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
comm::*sockopt_tcp_nodelay*
|
||
|
|
(fli:copy-pointer zero-or-one
|
||
|
|
:type '(:pointer #+win32 :char #-win32 :void))
|
||
|
|
len))
|
||
|
|
zero-or-one 0))) ; on error, return 0
|
||
|
|
|
||
|
|
(defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname))
|
||
|
|
(declare (ignorable original-hostname))
|
||
|
|
#+(or lispworks4 lispworks5 lispworks6.0)
|
||
|
|
(let ((server-addr (fli:allocate-dynamic-foreign-object
|
||
|
|
:type '(:struct comm::sockaddr_in))))
|
||
|
|
(values (comm::initialize-sockaddr_in
|
||
|
|
server-addr
|
||
|
|
comm::*socket_af_inet*
|
||
|
|
hostname
|
||
|
|
service protocol)
|
||
|
|
comm::*socket_af_inet*
|
||
|
|
server-addr
|
||
|
|
(fli:pointer-element-size server-addr)))
|
||
|
|
#-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1
|
||
|
|
(progn
|
||
|
|
(when (stringp hostname)
|
||
|
|
(setq hostname (comm:string-ip-address hostname))
|
||
|
|
(unless hostname
|
||
|
|
(let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address))))
|
||
|
|
(unless resolved-hostname
|
||
|
|
(return-from initialize-dynamic-sockaddr :unknown-host))
|
||
|
|
(setq hostname resolved-hostname))))
|
||
|
|
(if (or (null hostname)
|
||
|
|
(integerp hostname)
|
||
|
|
(comm:ipv6-address-p hostname))
|
||
|
|
(let ((server-addr (fli:allocate-dynamic-foreign-object
|
||
|
|
:type '(:struct comm::lw-sockaddr))))
|
||
|
|
(multiple-value-bind (error family)
|
||
|
|
(comm::initialize-sockaddr_in
|
||
|
|
server-addr
|
||
|
|
hostname
|
||
|
|
service protocol)
|
||
|
|
(values error family
|
||
|
|
server-addr
|
||
|
|
(if (eql family comm::*socket_af_inet*)
|
||
|
|
(fli:size-of '(:struct comm::sockaddr_in))
|
||
|
|
(fli:size-of '(:struct comm::sockaddr_in6))))))
|
||
|
|
:bad-host)))
|
||
|
|
|
||
|
|
(defun open-udp-socket (&key local-address local-port read-timeout
|
||
|
|
(address-family comm::*socket_af_inet*))
|
||
|
|
"Open a unconnected UDP socket.
|
||
|
|
For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL),
|
||
|
|
for binding on random free unused port, set LOCAL-PORT to 0."
|
||
|
|
|
||
|
|
;; Note: move (ensure-sockets) here to make sure delivered applications
|
||
|
|
;; correctly have networking support initialized.
|
||
|
|
;;
|
||
|
|
;; Following words was from Martin Simmons, forwarded by Camille Troillard:
|
||
|
|
|
||
|
|
;; Calling comm::ensure-sockets at load time looks like a bug in Lispworks-udp
|
||
|
|
;; (it is too early and also unnecessary).
|
||
|
|
|
||
|
|
;; The LispWorks comm package calls comm::ensure-sockets when it is needed, so I
|
||
|
|
;; think open-udp-socket should probably do it too. Calling it more than once is
|
||
|
|
;; safe and it will be very fast after the first time.
|
||
|
|
#+win32 (comm::ensure-sockets)
|
||
|
|
|
||
|
|
(let ((socket-fd (comm::socket address-family *socket_sock_dgram* *socket_ip_proto_udp*)))
|
||
|
|
(if socket-fd
|
||
|
|
(progn
|
||
|
|
(when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
|
||
|
|
(if local-port
|
||
|
|
(fli:with-dynamic-foreign-objects ()
|
||
|
|
(multiple-value-bind (error local-address-family
|
||
|
|
client-addr client-addr-length)
|
||
|
|
(initialize-dynamic-sockaddr local-address local-port "udp")
|
||
|
|
(if (or error (not (eql address-family local-address-family)))
|
||
|
|
(progn
|
||
|
|
(comm::close-socket socket-fd)
|
||
|
|
(error "cannot resolve hostname ~S, service ~S: ~A"
|
||
|
|
local-address local-port (or error "address family mismatch")))
|
||
|
|
(if (comm::bind socket-fd client-addr client-addr-length)
|
||
|
|
;; success, return socket fd
|
||
|
|
socket-fd
|
||
|
|
(progn
|
||
|
|
(comm::close-socket socket-fd)
|
||
|
|
(error "cannot bind"))))))
|
||
|
|
socket-fd))
|
||
|
|
(error "cannot create socket"))))
|
||
|
|
|
||
|
|
(defun connect-to-udp-server (hostname service
|
||
|
|
&key local-address local-port read-timeout)
|
||
|
|
"Something like CONNECT-TO-TCP-SERVER"
|
||
|
|
(fli:with-dynamic-foreign-objects ()
|
||
|
|
(multiple-value-bind (error address-family server-addr server-addr-length)
|
||
|
|
(initialize-dynamic-sockaddr hostname service "udp")
|
||
|
|
(when error
|
||
|
|
(error "cannot resolve hostname ~S, service ~S: ~A"
|
||
|
|
hostname service error))
|
||
|
|
(let ((socket-fd (open-udp-socket :local-address local-address
|
||
|
|
:local-port local-port
|
||
|
|
:read-timeout read-timeout
|
||
|
|
:address-family address-family)))
|
||
|
|
(if socket-fd
|
||
|
|
(if (comm::connect socket-fd server-addr server-addr-length)
|
||
|
|
;; success, return socket fd
|
||
|
|
socket-fd
|
||
|
|
;; fail, close socket and return nil
|
||
|
|
(progn
|
||
|
|
(comm::close-socket socket-fd)
|
||
|
|
(error "cannot connect")))
|
||
|
|
(error "cannot create socket"))))))
|
||
|
|
|
||
|
|
(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char)
|
||
|
|
timeout deadline (nodelay t)
|
||
|
|
local-host local-port)
|
||
|
|
;; What's the meaning of this keyword?
|
||
|
|
(when deadline
|
||
|
|
(unimplemented 'deadline 'socket-connect))
|
||
|
|
|
||
|
|
#+(and lispworks4 (not lispworks4.4)) ; < 4.4.5
|
||
|
|
(when timeout
|
||
|
|
(unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5"))
|
||
|
|
|
||
|
|
#+lispworks4
|
||
|
|
(when local-host
|
||
|
|
(unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0"))
|
||
|
|
#+lispworks4
|
||
|
|
(when local-port
|
||
|
|
(unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0"))
|
||
|
|
|
||
|
|
(ecase protocol
|
||
|
|
(:stream
|
||
|
|
(let ((hostname (host-to-hostname host))
|
||
|
|
(stream))
|
||
|
|
(setq stream
|
||
|
|
(with-mapped-conditions (nil host)
|
||
|
|
(comm:open-tcp-stream hostname port
|
||
|
|
:element-type element-type
|
||
|
|
#-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5
|
||
|
|
#-(and lispworks4 (not lispworks4.4))
|
||
|
|
:timeout timeout
|
||
|
|
#-lispworks4 #-lispworks4
|
||
|
|
#-lispworks4 #-lispworks4
|
||
|
|
:local-address (when local-host (host-to-hostname local-host))
|
||
|
|
:local-port local-port
|
||
|
|
#-(or lispworks4 lispworks5.0) ; >= 5.1
|
||
|
|
#-(or lispworks4 lispworks5.0)
|
||
|
|
:nodelay nodelay)))
|
||
|
|
|
||
|
|
;; Then handle `nodelay' separately for older versions <= 5.0
|
||
|
|
#+(or lispworks4 lispworks5.0)
|
||
|
|
(when (and stream nodelay)
|
||
|
|
(set-socket-tcp-nodelay
|
||
|
|
(comm:socket-stream-socket stream)
|
||
|
|
(bool->int nodelay))) ; ":if-supported" maps to 1 too.
|
||
|
|
|
||
|
|
(if stream
|
||
|
|
(make-stream-socket :socket (comm:socket-stream-socket stream)
|
||
|
|
:stream stream)
|
||
|
|
;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout
|
||
|
|
(error 'timeout-error))))
|
||
|
|
(:datagram
|
||
|
|
(let ((usocket (make-datagram-socket
|
||
|
|
(if (and host port)
|
||
|
|
(with-mapped-conditions (nil host)
|
||
|
|
(connect-to-udp-server (host-to-hostname host) port
|
||
|
|
:local-address (and local-host (host-to-hostname local-host))
|
||
|
|
:local-port local-port
|
||
|
|
:read-timeout timeout))
|
||
|
|
(with-mapped-conditions (nil local-host)
|
||
|
|
(open-udp-socket :local-address (and local-host (host-to-hostname local-host))
|
||
|
|
:local-port local-port
|
||
|
|
:read-timeout timeout)))
|
||
|
|
:connected-p (and host port t))))
|
||
|
|
usocket))))
|
||
|
|
|
||
|
|
(defun socket-listen (host port
|
||
|
|
&key reuseaddress
|
||
|
|
(reuse-address nil reuse-address-supplied-p)
|
||
|
|
(backlog 5)
|
||
|
|
(element-type 'base-char))
|
||
|
|
#+lispworks4.1
|
||
|
|
(unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
|
||
|
|
#+lispworks4.1
|
||
|
|
(unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
|
||
|
|
|
||
|
|
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
|
||
|
|
(comm::*use_so_reuseaddr* reuseaddress)
|
||
|
|
(hostname (host-to-hostname host))
|
||
|
|
(socket-res-list (with-mapped-conditions (nil host)
|
||
|
|
(multiple-value-list
|
||
|
|
#-lispworks4.1 (comm::create-tcp-socket-for-service
|
||
|
|
port :address hostname :backlog backlog)
|
||
|
|
#+lispworks4.1 (comm::create-tcp-socket-for-service port))))
|
||
|
|
(sock (if (not (or (second socket-res-list) (third socket-res-list)))
|
||
|
|
(first socket-res-list)
|
||
|
|
(when (eq (second socket-res-list) :bind)
|
||
|
|
(error 'address-in-use-error)))))
|
||
|
|
(make-stream-server-socket sock :element-type element-type)))
|
||
|
|
|
||
|
|
;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operations, which
|
||
|
|
;; should NOT be applied on socket FDs who have already been called on W-F-I,
|
||
|
|
;; so we have to check the %READY-P slot to decide if this waiting is necessary,
|
||
|
|
;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011
|
||
|
|
|
||
|
|
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
|
||
|
|
(let* ((socket (with-mapped-conditions (usocket)
|
||
|
|
#+win32
|
||
|
|
(if (%ready-p usocket)
|
||
|
|
(comm::accept-connection-to-socket (socket usocket))
|
||
|
|
(comm::get-fd-from-socket (socket usocket)))
|
||
|
|
#-win32
|
||
|
|
(comm::get-fd-from-socket (socket usocket))))
|
||
|
|
(stream (make-instance 'comm:socket-stream
|
||
|
|
:socket socket
|
||
|
|
:direction :io
|
||
|
|
:element-type (or element-type
|
||
|
|
(element-type usocket)))))
|
||
|
|
#+win32
|
||
|
|
(when socket
|
||
|
|
(setf (%ready-p usocket) nil))
|
||
|
|
(make-stream-socket :socket socket :stream stream)))
|
||
|
|
|
||
|
|
;; Sockets and their streams are different objects
|
||
|
|
;; close the stream in order to make sure buffers
|
||
|
|
;; are correctly flushed and the socket closed.
|
||
|
|
(defmethod socket-close ((usocket stream-usocket))
|
||
|
|
"Close socket."
|
||
|
|
(close (socket-stream usocket)))
|
||
|
|
|
||
|
|
(defmethod socket-close ((usocket usocket))
|
||
|
|
(with-mapped-conditions (usocket)
|
||
|
|
(comm::close-socket (socket usocket))))
|
||
|
|
|
||
|
|
(defmethod socket-close :after ((socket datagram-usocket))
|
||
|
|
"Additional socket-close method for datagram-usocket"
|
||
|
|
(setf (%open-p socket) nil))
|
||
|
|
|
||
|
|
(defconstant +shutdown-read+ 0)
|
||
|
|
(defconstant +shutdown-write+ 1)
|
||
|
|
(defconstant +shutdown-read-write+ 2)
|
||
|
|
|
||
|
|
;;; int
|
||
|
|
;;; shutdown(int socket, int what);
|
||
|
|
(fli:define-foreign-function (%shutdown "shutdown" :source)
|
||
|
|
((socket :int)
|
||
|
|
(what :int))
|
||
|
|
:result-type :int
|
||
|
|
#+win32 :module
|
||
|
|
#+win32 "ws2_32")
|
||
|
|
|
||
|
|
(defmethod socket-shutdown ((usocket datagram-usocket) direction)
|
||
|
|
(unless (member direction '(:input :output :io))
|
||
|
|
(error 'invalid-argument-error))
|
||
|
|
(let ((what (case direction
|
||
|
|
(:input +shutdown-read+)
|
||
|
|
(:output +shutdown-write+)
|
||
|
|
(:io +shutdown-read-write+))))
|
||
|
|
(with-mapped-conditions (usocket)
|
||
|
|
#-(or lispworks4 lispworks5 lispworks6) ; lispworks 7.0+
|
||
|
|
(comm::shutdown (socket usocket) what)
|
||
|
|
#+(or lispworks4 lispworks5 lispworks6)
|
||
|
|
(= 0 (%shutdown (socket usocket) what)))))
|
||
|
|
|
||
|
|
(defmethod socket-shutdown ((usocket stream-usocket) direction)
|
||
|
|
(unless (member direction '(:input :output :io))
|
||
|
|
(error 'invalid-argument-error))
|
||
|
|
(with-mapped-conditions (usocket)
|
||
|
|
#-(or lispworks4 lispworks5 lispworks6)
|
||
|
|
(comm:socket-stream-shutdown (socket usocket) direction)
|
||
|
|
#+(or lispworks4 lispworks5 lispworks6)
|
||
|
|
(let ((what (case direction
|
||
|
|
(:input +shutdown-read+)
|
||
|
|
(:output +shutdown-write+)
|
||
|
|
(:io +shutdown-read-write+))))
|
||
|
|
(= 0 (%shutdown (comm:socket-stream-socket (socket usocket)) what)))))
|
||
|
|
|
||
|
|
(defmethod initialize-instance :after ((socket datagram-usocket) &key)
|
||
|
|
(setf (slot-value socket 'send-buffer)
|
||
|
|
(make-array +max-datagram-packet-size+
|
||
|
|
:element-type '(unsigned-byte 8)
|
||
|
|
:allocation :static))
|
||
|
|
(setf (slot-value socket 'recv-buffer)
|
||
|
|
(make-array +max-datagram-packet-size+
|
||
|
|
:element-type '(unsigned-byte 8)
|
||
|
|
:allocation :static)))
|
||
|
|
|
||
|
|
(defvar *length-of-sockaddr_in*
|
||
|
|
(fli:size-of '(:struct comm::sockaddr_in)))
|
||
|
|
|
||
|
|
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
|
||
|
|
&aux (socket-fd (socket usocket))
|
||
|
|
(message (slot-value usocket 'send-buffer))) ; TODO: multiple threads send together?
|
||
|
|
"Send message to a socket, using sendto()/send()"
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type sequence buffer))
|
||
|
|
(when host (setq host (host-to-hostname host)))
|
||
|
|
(fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
|
||
|
|
(replace message buffer :start2 offset :end2 (+ offset size))
|
||
|
|
(let ((n (if (and host port)
|
||
|
|
(fli:with-dynamic-foreign-objects ()
|
||
|
|
(multiple-value-bind (error family client-addr client-addr-length)
|
||
|
|
(initialize-dynamic-sockaddr host port "udp")
|
||
|
|
(declare (ignore family))
|
||
|
|
(when error
|
||
|
|
(error "cannot resolve hostname ~S, port ~S: ~A"
|
||
|
|
host port error))
|
||
|
|
(%sendto socket-fd ptr (min size +max-datagram-packet-size+) 0
|
||
|
|
(fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
|
||
|
|
client-addr-length)))
|
||
|
|
(comm::%send socket-fd ptr (min size +max-datagram-packet-size+) 0))))
|
||
|
|
(declare (type fixnum n))
|
||
|
|
(if (plusp n)
|
||
|
|
n
|
||
|
|
(let ((errno #-win32 (lw:errno-value)
|
||
|
|
#+win32 (wsa-get-last-error)))
|
||
|
|
(if (zerop errno)
|
||
|
|
n
|
||
|
|
(raise-usock-err errno socket-fd host)))))))
|
||
|
|
|
||
|
|
(defmethod socket-receive ((socket datagram-usocket) buffer length &key timeout (max-buffer-size +max-datagram-packet-size+))
|
||
|
|
"Receive message from socket, read-timeout is a float number in seconds.
|
||
|
|
|
||
|
|
This function will return 4 values:
|
||
|
|
1. receive buffer
|
||
|
|
2. number of receive bytes
|
||
|
|
3. remote address
|
||
|
|
4. remote port"
|
||
|
|
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
|
||
|
|
(integer 0) ; size
|
||
|
|
(unsigned-byte 32) ; host
|
||
|
|
(unsigned-byte 16)) ; port
|
||
|
|
(type sequence buffer))
|
||
|
|
(let ((socket-fd (socket socket))
|
||
|
|
(message (slot-value socket 'recv-buffer)) ; TODO: how multiple threads do this in parallel?
|
||
|
|
(read-timeout timeout)
|
||
|
|
old-timeout)
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
|
||
|
|
(len :int
|
||
|
|
#-(or lispworks4 lispworks5.0) ; <= 5.0
|
||
|
|
:initial-element *length-of-sockaddr_in*))
|
||
|
|
#+(or lispworks4 lispworks5.0) ; <= 5.0
|
||
|
|
(setf (fli:dereference len) *length-of-sockaddr_in*)
|
||
|
|
(fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
|
||
|
|
;; setup new read timeout
|
||
|
|
(when read-timeout
|
||
|
|
(setf old-timeout (get-socket-receive-timeout socket-fd))
|
||
|
|
(set-socket-receive-timeout socket-fd read-timeout))
|
||
|
|
(let ((n (%recvfrom socket-fd ptr max-buffer-size 0
|
||
|
|
(fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
|
||
|
|
len)))
|
||
|
|
(declare (type fixnum n))
|
||
|
|
;; restore old read timeout
|
||
|
|
(when (and read-timeout (/= old-timeout read-timeout))
|
||
|
|
(set-socket-receive-timeout socket-fd old-timeout))
|
||
|
|
;; Frank James' patch: reset the %read-p for WAIT-FOR-INPUT
|
||
|
|
#+win32 (setf (%ready-p socket) nil)
|
||
|
|
(if (plusp n)
|
||
|
|
(values (if buffer
|
||
|
|
(replace buffer message
|
||
|
|
:end1 (min length max-buffer-size)
|
||
|
|
:end2 (min n max-buffer-size))
|
||
|
|
(subseq message 0 (min n max-buffer-size)))
|
||
|
|
(min n max-buffer-size)
|
||
|
|
(comm::ntohl (fli:foreign-slot-value
|
||
|
|
(fli:foreign-slot-value client-addr
|
||
|
|
'comm::sin_addr
|
||
|
|
:object-type '(:struct comm::sockaddr_in)
|
||
|
|
:type '(:struct comm::in_addr)
|
||
|
|
:copy-foreign-object nil)
|
||
|
|
'comm::s_addr
|
||
|
|
:object-type '(:struct comm::in_addr)))
|
||
|
|
(comm::ntohs (fli:foreign-slot-value client-addr
|
||
|
|
'comm::sin_port
|
||
|
|
:object-type '(:struct comm::sockaddr_in)
|
||
|
|
:type '(:unsigned :short)
|
||
|
|
:copy-foreign-object nil)))
|
||
|
|
(let ((errno #-win32 (lw:errno-value)
|
||
|
|
#+win32 (wsa-get-last-error)))
|
||
|
|
(if (zerop errno)
|
||
|
|
(values nil n 0 0)
|
||
|
|
(raise-usock-err errno socket-fd)))))))))
|
||
|
|
|
||
|
|
(defmethod get-local-name ((usocket usocket))
|
||
|
|
(multiple-value-bind
|
||
|
|
(address port)
|
||
|
|
(comm:get-socket-address (socket usocket))
|
||
|
|
(values (hbo-to-vector-quad address) port)))
|
||
|
|
|
||
|
|
(defmethod get-peer-name ((usocket stream-usocket))
|
||
|
|
(multiple-value-bind
|
||
|
|
(address port)
|
||
|
|
(comm:get-socket-peer-address (socket usocket))
|
||
|
|
(values (hbo-to-vector-quad address) port)))
|
||
|
|
|
||
|
|
(defmethod get-local-address ((usocket usocket))
|
||
|
|
(nth-value 0 (get-local-name usocket)))
|
||
|
|
|
||
|
|
(defmethod get-peer-address ((usocket stream-usocket))
|
||
|
|
(nth-value 0 (get-peer-name usocket)))
|
||
|
|
|
||
|
|
(defmethod get-local-port ((usocket usocket))
|
||
|
|
(nth-value 1 (get-local-name usocket)))
|
||
|
|
|
||
|
|
(defmethod get-peer-port ((usocket stream-usocket))
|
||
|
|
(nth-value 1 (get-peer-name usocket)))
|
||
|
|
|
||
|
|
#-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1
|
||
|
|
(defun ipv6-address-p (hostname)
|
||
|
|
(when (stringp hostname)
|
||
|
|
(setq hostname (comm:string-ip-address hostname))
|
||
|
|
(unless hostname
|
||
|
|
(let ((resolved-hostname (comm:get-host-entry hostname :fields '(:address))))
|
||
|
|
(unless resolved-hostname
|
||
|
|
(return-from ipv6-address-p nil))
|
||
|
|
(setq hostname resolved-hostname))))
|
||
|
|
(comm:ipv6-address-p hostname))
|
||
|
|
|
||
|
|
(defun lw-hbo-to-vector-quad (hbo)
|
||
|
|
#+(or lispworks4 lispworks5 lispworks6.0)
|
||
|
|
(hbo-to-vector-quad hbo)
|
||
|
|
#-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1
|
||
|
|
(if (comm:ipv6-address-p hbo)
|
||
|
|
(ipv6-host-to-vector (comm:ipv6-address-string hbo))
|
||
|
|
(hbo-to-vector-quad hbo)))
|
||
|
|
|
||
|
|
(defun get-hosts-by-name (name)
|
||
|
|
(with-mapped-conditions (nil name)
|
||
|
|
(mapcar #'lw-hbo-to-vector-quad
|
||
|
|
(comm:get-host-entry name :fields '(:addresses)))))
|
||
|
|
|
||
|
|
(defun get-host-by-address (address)
|
||
|
|
(with-mapped-conditions (nil address)
|
||
|
|
nil)) ;; TODO
|
||
|
|
|
||
|
|
(defun os-socket-handle (usocket)
|
||
|
|
(socket usocket))
|
||
|
|
|
||
|
|
(defun usocket-listen (usocket)
|
||
|
|
(if (stream-usocket-p usocket)
|
||
|
|
(when (listen (socket-stream usocket))
|
||
|
|
usocket)
|
||
|
|
(when (comm::socket-listen (socket usocket))
|
||
|
|
usocket)))
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; Non Windows implementation
|
||
|
|
;;; The Windows implementation needs to resort to the Windows API in order
|
||
|
|
;;; to achieve what we want (what we want is waiting without busy-looping)
|
||
|
|
;;;
|
||
|
|
|
||
|
|
#-win32
|
||
|
|
(progn
|
||
|
|
|
||
|
|
(defun %setup-wait-list (wait-list)
|
||
|
|
(declare (ignore wait-list)))
|
||
|
|
|
||
|
|
(defun %add-waiter (wait-list waiter)
|
||
|
|
(declare (ignore wait-list waiter)))
|
||
|
|
|
||
|
|
(defun %remove-waiter (wait-list waiter)
|
||
|
|
(declare (ignore wait-list waiter)))
|
||
|
|
|
||
|
|
(defun wait-for-input-internal (wait-list &key timeout)
|
||
|
|
(with-mapped-conditions ()
|
||
|
|
;; unfortunately, it's impossible to share code between
|
||
|
|
;; non-win32 and win32 platforms...
|
||
|
|
;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
|
||
|
|
(dolist (x (wait-list-waiters wait-list))
|
||
|
|
(mp:notice-fd (os-socket-handle x)))
|
||
|
|
(labels ((wait-function (socks)
|
||
|
|
(let (rv)
|
||
|
|
(dolist (x socks rv)
|
||
|
|
(when (usocket-listen x)
|
||
|
|
(setf (state x) :READ
|
||
|
|
rv t))))))
|
||
|
|
(if timeout
|
||
|
|
(mp:process-wait-with-timeout "Waiting for a socket to become active"
|
||
|
|
(truncate timeout)
|
||
|
|
#'wait-function
|
||
|
|
(wait-list-waiters wait-list))
|
||
|
|
(mp:process-wait "Waiting for a socket to become active"
|
||
|
|
#'wait-function
|
||
|
|
(wait-list-waiters wait-list))))
|
||
|
|
(dolist (x (wait-list-waiters wait-list))
|
||
|
|
(mp:unnotice-fd (os-socket-handle x)))
|
||
|
|
wait-list))
|
||
|
|
|
||
|
|
) ; end of block
|
||
|
|
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; The Windows side of the story
|
||
|
|
;;; We want to wait without busy looping
|
||
|
|
;;; This code only works in threads which don't have (hidden)
|
||
|
|
;;; windows which need to receive messages. There are workarounds in the Windows API
|
||
|
|
;;; but are those available to 'us'.
|
||
|
|
;;;
|
||
|
|
|
||
|
|
|
||
|
|
#+win32
|
||
|
|
(progn
|
||
|
|
|
||
|
|
;; LispWorks doesn't provide an interface to wait for a socket
|
||
|
|
;; to become ready (under Win32, that is) meaning that we need
|
||
|
|
;; to resort to system calls to achieve the same thing.
|
||
|
|
;; Luckily, it provides us access to the raw socket handles (as we
|
||
|
|
;; wrote the code above.
|
||
|
|
|
||
|
|
(defconstant fd-read 1)
|
||
|
|
(defconstant fd-read-bit 0)
|
||
|
|
(defconstant fd-write 2)
|
||
|
|
(defconstant fd-write-bit 1)
|
||
|
|
(defconstant fd-oob 4)
|
||
|
|
(defconstant fd-oob-bit 2)
|
||
|
|
(defconstant fd-accept 8)
|
||
|
|
(defconstant fd-accept-bit 3)
|
||
|
|
(defconstant fd-connect 16)
|
||
|
|
(defconstant fd-connect-bit 4)
|
||
|
|
(defconstant fd-close 32)
|
||
|
|
(defconstant fd-close-bit 5)
|
||
|
|
(defconstant fd-qos 64)
|
||
|
|
(defconstant fd-qos-bit 6)
|
||
|
|
(defconstant fd-group-qos 128)
|
||
|
|
(defconstant fd-group-qos-bit 7)
|
||
|
|
(defconstant fd-routing-interface 256)
|
||
|
|
(defconstant fd-routing-interface-bit 8)
|
||
|
|
(defconstant fd-address-list-change 512)
|
||
|
|
(defconstant fd-address-list-change-bit 9)
|
||
|
|
|
||
|
|
(defconstant fd-max-events 10)
|
||
|
|
|
||
|
|
(defconstant fionread 1074030207)
|
||
|
|
|
||
|
|
|
||
|
|
;; Note:
|
||
|
|
;;
|
||
|
|
;; If special finalization has to occur for a given
|
||
|
|
;; system resource (handle), an associated object should
|
||
|
|
;; be created. A special cleanup action should be added
|
||
|
|
;; to the system and a special cleanup action should
|
||
|
|
;; be flagged on all objects created for resources like it
|
||
|
|
;;
|
||
|
|
;; We have 2 functions to do so:
|
||
|
|
;; * hcl:add-special-free-action (function-symbol)
|
||
|
|
;; * hcl:flag-special-free-action (object)
|
||
|
|
;;
|
||
|
|
;; Note that the special free action will be called on all
|
||
|
|
;; objects which have been flagged for special free, so be
|
||
|
|
;; sure to check for the right argument type!
|
||
|
|
|
||
|
|
(fli:define-foreign-type ws-socket () '(:unsigned :int))
|
||
|
|
(fli:define-foreign-type win32-handle () '(:unsigned :int))
|
||
|
|
(fli:define-c-struct wsa-network-events
|
||
|
|
(network-events :long)
|
||
|
|
(error-code (:c-array :int 10)))
|
||
|
|
|
||
|
|
(fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source)
|
||
|
|
()
|
||
|
|
:lambda-list nil
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
(fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
|
||
|
|
((event-object win32-handle))
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
;; not used
|
||
|
|
(fli:define-foreign-function (wsa-reset-event "WSAResetEvent" :source)
|
||
|
|
((event-object win32-handle))
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
(fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
|
||
|
|
((socket ws-socket)
|
||
|
|
(event-object win32-handle)
|
||
|
|
(network-events (:reference-return wsa-network-events)))
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
(fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source)
|
||
|
|
((socket ws-socket)
|
||
|
|
(event-object win32-handle)
|
||
|
|
(network-events :long))
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
(fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source)
|
||
|
|
()
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
(fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source)
|
||
|
|
((socket :long) (cmd :long) (argp (:ptr :long)))
|
||
|
|
:result-type :int
|
||
|
|
:module "ws2_32")
|
||
|
|
|
||
|
|
|
||
|
|
;; The Windows system
|
||
|
|
|
||
|
|
|
||
|
|
;; Now that we have access to the system calls, this is the plan:
|
||
|
|
|
||
|
|
;; 1. Receive a wait-list with associated sockets to wait for
|
||
|
|
;; 2. Add all those sockets to an event handle
|
||
|
|
;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that)
|
||
|
|
;; 4. After listening, detect if there are errors
|
||
|
|
;; (this step is different from Unix, where we can have only one error)
|
||
|
|
;; 5. If so, raise one of them
|
||
|
|
;; 6. If not so, return the sockets which have input waiting for them
|
||
|
|
|
||
|
|
|
||
|
|
(defun maybe-wsa-error (rv &optional socket)
|
||
|
|
(unless (zerop rv)
|
||
|
|
(raise-usock-err (wsa-get-last-error) socket)))
|
||
|
|
|
||
|
|
(defun bytes-available-for-read (socket)
|
||
|
|
(fli:with-dynamic-foreign-objects ((int-ptr :long))
|
||
|
|
(let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
|
||
|
|
(if (= 0 rv)
|
||
|
|
(fli:dereference int-ptr)
|
||
|
|
0))))
|
||
|
|
|
||
|
|
(defun socket-ready-p (socket)
|
||
|
|
(if (typep socket 'stream-usocket)
|
||
|
|
(< 0 (bytes-available-for-read socket))
|
||
|
|
(%ready-p socket)))
|
||
|
|
|
||
|
|
(defun waiting-required (sockets)
|
||
|
|
(notany #'socket-ready-p sockets))
|
||
|
|
|
||
|
|
(defun wait-for-input-internal (wait-list &key timeout)
|
||
|
|
(when (waiting-required (wait-list-waiters wait-list))
|
||
|
|
(system:wait-for-single-object (wait-list-%wait wait-list)
|
||
|
|
"Waiting for socket activity" timeout))
|
||
|
|
(update-ready-and-state-slots wait-list))
|
||
|
|
|
||
|
|
(defun map-network-events (func network-events)
|
||
|
|
(let ((event-map (fli:foreign-slot-value network-events 'network-events))
|
||
|
|
(error-array (fli:foreign-slot-pointer network-events 'error-code)))
|
||
|
|
(unless (zerop event-map)
|
||
|
|
(dotimes (i fd-max-events)
|
||
|
|
(unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
|
||
|
|
(funcall func (fli:foreign-aref error-array i)))))))
|
||
|
|
|
||
|
|
(defun update-ready-and-state-slots (wait-list)
|
||
|
|
(loop with sockets = (wait-list-waiters wait-list)
|
||
|
|
for socket in sockets do
|
||
|
|
(if (or (and (stream-usocket-p socket)
|
||
|
|
(listen (socket-stream socket)))
|
||
|
|
(%ready-p socket))
|
||
|
|
(setf (state socket) :READ)
|
||
|
|
(multiple-value-bind
|
||
|
|
(rv network-events)
|
||
|
|
(wsa-enum-network-events (os-socket-handle socket)
|
||
|
|
(wait-list-%wait wait-list)
|
||
|
|
t)
|
||
|
|
(if (zerop rv)
|
||
|
|
(map-network-events #'(lambda (err-code)
|
||
|
|
(if (zerop err-code)
|
||
|
|
(setf (%ready-p socket) t
|
||
|
|
(state socket) :READ)
|
||
|
|
(raise-usock-err err-code socket)))
|
||
|
|
network-events)
|
||
|
|
(maybe-wsa-error rv socket))))))
|
||
|
|
|
||
|
|
;; The wait-list part
|
||
|
|
|
||
|
|
(defun free-wait-list (wl)
|
||
|
|
(when (wait-list-p wl)
|
||
|
|
(unless (null (wait-list-%wait wl))
|
||
|
|
(wsa-event-close (wait-list-%wait wl))
|
||
|
|
(setf (wait-list-%wait wl) nil))))
|
||
|
|
|
||
|
|
(eval-when (:load-toplevel :execute)
|
||
|
|
(hcl:add-special-free-action 'free-wait-list))
|
||
|
|
|
||
|
|
(defun %setup-wait-list (wait-list)
|
||
|
|
(hcl:flag-special-free-action wait-list)
|
||
|
|
(setf (wait-list-%wait wait-list) (wsa-event-create)))
|
||
|
|
|
||
|
|
(defun %add-waiter (wait-list waiter)
|
||
|
|
(let ((events (etypecase waiter
|
||
|
|
(stream-server-usocket (logior fd-connect fd-accept fd-close))
|
||
|
|
(stream-usocket (logior fd-connect fd-read fd-oob fd-close))
|
||
|
|
(datagram-usocket (logior fd-read)))))
|
||
|
|
(maybe-wsa-error
|
||
|
|
(wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
|
||
|
|
waiter)))
|
||
|
|
|
||
|
|
(defun %remove-waiter (wait-list waiter)
|
||
|
|
(maybe-wsa-error
|
||
|
|
(wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0)
|
||
|
|
waiter))
|
||
|
|
|
||
|
|
) ; end of WIN32-block
|
||
|
|
|
||
|
|
(defun set-socket-reuse-address (socket-fd reuse-address-p)
|
||
|
|
(declare (type integer socket-fd)
|
||
|
|
(type boolean reuse-address-p))
|
||
|
|
(fli:with-dynamic-foreign-objects ((value :int))
|
||
|
|
(setf (fli:dereference value) (if reuse-address-p 1 0))
|
||
|
|
(if (zerop (comm::setsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
comm::*sockopt_so_reuseaddr*
|
||
|
|
(fli:copy-pointer value
|
||
|
|
:type '(:pointer :void))
|
||
|
|
(fli:size-of :int)))
|
||
|
|
reuse-address-p)))
|
||
|
|
|
||
|
|
(defun get-socket-reuse-address (socket-fd)
|
||
|
|
(declare (type integer socket-fd))
|
||
|
|
(fli:with-dynamic-foreign-objects ((value :int) (len :int))
|
||
|
|
(if (zerop (comm::getsockopt socket-fd
|
||
|
|
comm::*sockopt_sol_socket*
|
||
|
|
comm::*sockopt_so_reuseaddr*
|
||
|
|
(fli:copy-pointer value
|
||
|
|
:type '(:pointer :void))
|
||
|
|
len))
|
||
|
|
(= 1 (fli:dereference value)))))
|