269 lines
10 KiB
Common Lisp
269 lines
10 KiB
Common Lisp
|
;;;; See LICENSE for licensing information.
|
||
|
|
|
||
|
|
(in-package :usocket)
|
||
|
|
|
||
|
|
(defun get-host-name ()
|
||
|
|
(ccl::%stack-block ((resultbuf 256))
|
||
|
|
(when (zerop (#_gethostname resultbuf 256))
|
||
|
|
(ccl::%get-cstring resultbuf))))
|
||
|
|
|
||
|
|
(defparameter +openmcl-error-map+
|
||
|
|
'((:address-in-use . address-in-use-error)
|
||
|
|
(:connection-aborted . connection-aborted-error)
|
||
|
|
(:no-buffer-space . no-buffers-error)
|
||
|
|
(:connection-timed-out . timeout-error)
|
||
|
|
(:connection-refused . connection-refused-error)
|
||
|
|
(:host-unreachable . host-unreachable-error)
|
||
|
|
(:host-down . host-down-error)
|
||
|
|
(:network-down . network-down-error)
|
||
|
|
(:address-not-available . address-not-available-error)
|
||
|
|
(:network-reset . network-reset-error)
|
||
|
|
(:connection-reset . connection-reset-error)
|
||
|
|
(:shutdown . shutdown-error)
|
||
|
|
(:access-denied . operation-not-permitted-error)))
|
||
|
|
|
||
|
|
(defparameter +openmcl-nameserver-error-map+
|
||
|
|
'((:no-recovery . ns-no-recovery-error)
|
||
|
|
(:try-again . ns-try-again-condition)
|
||
|
|
(:host-not-found . ns-host-not-found-error)))
|
||
|
|
|
||
|
|
;; we need something which the openmcl implementors 'forgot' to do:
|
||
|
|
;; wait for more than one socket-or-fd
|
||
|
|
|
||
|
|
(defun input-available-p (sockets &optional ticks-to-wait)
|
||
|
|
(ccl::rletz ((tv :timeval))
|
||
|
|
(ccl::ticks-to-timeval ticks-to-wait tv)
|
||
|
|
;;### The trickery below can be moved to the wait-list now...
|
||
|
|
(ccl::%stack-block ((infds ccl::*fd-set-size*))
|
||
|
|
(ccl::fd-zero infds)
|
||
|
|
(let ((max-fd -1))
|
||
|
|
(dolist (sock sockets)
|
||
|
|
(let ((fd (openmcl-socket:socket-os-fd (socket sock))))
|
||
|
|
(when fd ;; may be NIL if closed
|
||
|
|
(setf max-fd (max max-fd fd))
|
||
|
|
(ccl::fd-set fd infds))))
|
||
|
|
(let ((res (#_select (1+ max-fd)
|
||
|
|
infds (ccl::%null-ptr) (ccl::%null-ptr)
|
||
|
|
(if ticks-to-wait tv (ccl::%null-ptr)))))
|
||
|
|
(when (> res 0)
|
||
|
|
(dolist (sock sockets)
|
||
|
|
(let ((fd (openmcl-socket:socket-os-fd (socket sock))))
|
||
|
|
(when (and fd (ccl::fd-is-set fd infds))
|
||
|
|
(setf (state sock) :READ)))))
|
||
|
|
sockets)))))
|
||
|
|
|
||
|
|
(defun raise-error-from-id (condition-id socket real-condition)
|
||
|
|
(let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
|
||
|
|
(if usock-err
|
||
|
|
(error usock-err :socket socket)
|
||
|
|
(error 'unknown-error :socket socket :real-error real-condition))))
|
||
|
|
|
||
|
|
(defun handle-condition (condition &optional socket (host-or-ip nil))
|
||
|
|
(typecase condition
|
||
|
|
(openmcl-socket:socket-error
|
||
|
|
(raise-error-from-id (openmcl-socket:socket-error-identifier condition)
|
||
|
|
socket condition))
|
||
|
|
(ccl:input-timeout
|
||
|
|
(error 'timeout-error :socket socket))
|
||
|
|
(ccl:communication-deadline-expired
|
||
|
|
(error 'deadline-timeout-error :socket socket))
|
||
|
|
(ccl::socket-creation-error #| ugh! |#
|
||
|
|
(let* ((condition-id (ccl::socket-creation-error-identifier condition))
|
||
|
|
(nameserver-error (cdr (assoc condition-id
|
||
|
|
+openmcl-nameserver-error-map+))))
|
||
|
|
(if nameserver-error
|
||
|
|
(if (typep nameserver-error 'serious-condition)
|
||
|
|
(error nameserver-error :host-or-ip host-or-ip)
|
||
|
|
(signal nameserver-error :host-or-ip host-or-ip))
|
||
|
|
(raise-error-from-id condition-id socket condition))))))
|
||
|
|
|
||
|
|
(defun to-format (element-type protocol)
|
||
|
|
(cond ((null element-type)
|
||
|
|
(ecase protocol ; default value of different protocol
|
||
|
|
(:stream :text)
|
||
|
|
(:datagram :binary)))
|
||
|
|
((subtypep element-type 'character)
|
||
|
|
:text)
|
||
|
|
(t :binary)))
|
||
|
|
|
||
|
|
#-ipv6
|
||
|
|
(defun socket-connect (host port &key (protocol :stream) element-type
|
||
|
|
timeout deadline nodelay
|
||
|
|
local-host local-port)
|
||
|
|
(when (eq nodelay :if-supported)
|
||
|
|
(setf nodelay t))
|
||
|
|
(with-mapped-conditions (nil host)
|
||
|
|
(ecase protocol
|
||
|
|
(:stream
|
||
|
|
(let ((mcl-sock
|
||
|
|
(openmcl-socket:make-socket :remote-host (host-to-hostname host)
|
||
|
|
:remote-port port
|
||
|
|
:local-host local-host
|
||
|
|
:local-port local-port
|
||
|
|
:format (to-format element-type protocol)
|
||
|
|
:external-format ccl:*default-external-format*
|
||
|
|
:deadline deadline
|
||
|
|
:nodelay nodelay
|
||
|
|
:connect-timeout timeout)))
|
||
|
|
(make-stream-socket :stream mcl-sock :socket mcl-sock)))
|
||
|
|
(:datagram
|
||
|
|
(let* ((mcl-sock
|
||
|
|
(openmcl-socket:make-socket :address-family :internet
|
||
|
|
:type :datagram
|
||
|
|
:local-host local-host
|
||
|
|
:local-port local-port
|
||
|
|
:input-timeout timeout
|
||
|
|
:format (to-format element-type protocol)
|
||
|
|
:external-format ccl:*default-external-format*))
|
||
|
|
(usocket (make-datagram-socket mcl-sock)))
|
||
|
|
(when (and host port)
|
||
|
|
(ccl::inet-connect (ccl::socket-device mcl-sock)
|
||
|
|
(ccl::host-as-inet-host host)
|
||
|
|
(ccl::port-as-inet-port port "udp")))
|
||
|
|
(setf (connected-p usocket) t)
|
||
|
|
usocket)))))
|
||
|
|
|
||
|
|
#-ipv6
|
||
|
|
(defun socket-listen (host port
|
||
|
|
&key reuseaddress
|
||
|
|
(reuse-address nil reuse-address-supplied-p)
|
||
|
|
(backlog 5)
|
||
|
|
(element-type 'character))
|
||
|
|
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
|
||
|
|
(real-host (host-to-hostname host))
|
||
|
|
(sock (with-mapped-conditions (nil host)
|
||
|
|
(apply #'openmcl-socket:make-socket
|
||
|
|
(append (list :connect :passive
|
||
|
|
:reuse-address reuseaddress
|
||
|
|
:local-port port
|
||
|
|
:backlog backlog
|
||
|
|
:format (to-format element-type :stream))
|
||
|
|
(unless (eq host *wildcard-host*)
|
||
|
|
(list :local-host real-host)))))))
|
||
|
|
(make-stream-server-socket sock :element-type element-type)))
|
||
|
|
|
||
|
|
(defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
|
||
|
|
(declare (ignore element-type)) ;; openmcl streams are bi/multivalent
|
||
|
|
(let ((sock (with-mapped-conditions (usocket)
|
||
|
|
(openmcl-socket:accept-connection (socket usocket)))))
|
||
|
|
(make-stream-socket :socket sock :stream sock)))
|
||
|
|
|
||
|
|
;; One close method is sufficient because sockets
|
||
|
|
;; and their associated objects are represented
|
||
|
|
;; by the same object.
|
||
|
|
(defmethod socket-close ((usocket usocket))
|
||
|
|
(with-mapped-conditions (usocket)
|
||
|
|
(close (socket usocket))))
|
||
|
|
|
||
|
|
(defmethod socket-shutdown ((usocket usocket) direction)
|
||
|
|
(with-mapped-conditions (usocket)
|
||
|
|
(openmcl-socket:shutdown (socket usocket) :direction direction)))
|
||
|
|
|
||
|
|
#-ipv6
|
||
|
|
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
|
||
|
|
(with-mapped-conditions (usocket host)
|
||
|
|
(if (and host port)
|
||
|
|
(openmcl-socket:send-to (socket usocket) buffer size
|
||
|
|
:remote-host (host-to-hbo host)
|
||
|
|
:remote-port port
|
||
|
|
:offset offset)
|
||
|
|
;; Clozure CL's socket function SEND-TO doesn't support operations on connected UDP sockets,
|
||
|
|
;; so we have to define our own.
|
||
|
|
(let* ((socket (socket usocket))
|
||
|
|
(fd (ccl::socket-device socket)))
|
||
|
|
(multiple-value-setq (buffer offset)
|
||
|
|
(ccl::verify-socket-buffer buffer offset size))
|
||
|
|
(ccl::%stack-block ((bufptr size))
|
||
|
|
(ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
|
||
|
|
(ccl::socket-call socket "send"
|
||
|
|
(ccl::with-eagain fd :output
|
||
|
|
(ccl::ignoring-eintr
|
||
|
|
(ccl::check-socket-error (#_send fd bufptr size 0))))))))))
|
||
|
|
|
||
|
|
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
|
||
|
|
(with-mapped-conditions (usocket)
|
||
|
|
(openmcl-socket:receive-from (socket usocket) length :buffer buffer)))
|
||
|
|
|
||
|
|
(defun usocket-host-address (address)
|
||
|
|
(cond
|
||
|
|
((integerp address)
|
||
|
|
(hbo-to-vector-quad address))
|
||
|
|
((and (arrayp address)
|
||
|
|
(= (length address) 16)
|
||
|
|
(every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
|
||
|
|
(make-array 4 :displaced-to address :displaced-index-offset 12))
|
||
|
|
(t
|
||
|
|
address)))
|
||
|
|
|
||
|
|
(defmethod get-local-address ((usocket usocket))
|
||
|
|
(usocket-host-address (openmcl-socket:local-host (socket usocket))))
|
||
|
|
|
||
|
|
(defmethod get-peer-address ((usocket stream-usocket))
|
||
|
|
(usocket-host-address (openmcl-socket:remote-host (socket usocket))))
|
||
|
|
|
||
|
|
(defmethod get-local-port ((usocket usocket))
|
||
|
|
(openmcl-socket:local-port (socket usocket)))
|
||
|
|
|
||
|
|
(defmethod get-peer-port ((usocket stream-usocket))
|
||
|
|
(openmcl-socket:remote-port (socket usocket)))
|
||
|
|
|
||
|
|
(defmethod get-local-name ((usocket usocket))
|
||
|
|
(values (get-local-address usocket)
|
||
|
|
(get-local-port usocket)))
|
||
|
|
|
||
|
|
(defmethod get-peer-name ((usocket stream-usocket))
|
||
|
|
(values (get-peer-address usocket)
|
||
|
|
(get-peer-port usocket)))
|
||
|
|
|
||
|
|
(defun get-host-by-address (address)
|
||
|
|
(with-mapped-conditions (nil address)
|
||
|
|
(openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
|
||
|
|
|
||
|
|
(defun get-hosts-by-name (name)
|
||
|
|
(with-mapped-conditions (nil name)
|
||
|
|
(list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
|
||
|
|
(host-to-hostname name))))))
|
||
|
|
|
||
|
|
(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 ()
|
||
|
|
(let* ((ticks-timeout (truncate (* (or timeout 1)
|
||
|
|
ccl::*ticks-per-second*))))
|
||
|
|
(input-available-p (wait-list-waiters wait-list)
|
||
|
|
(when timeout ticks-timeout))
|
||
|
|
wait-list)))
|
||
|
|
|
||
|
|
;;; Helper functions for option.lisp
|
||
|
|
|
||
|
|
(defun get-socket-option-reuseaddr (socket)
|
||
|
|
(ccl::int-getsockopt (ccl::socket-device socket)
|
||
|
|
#$SOL_SOCKET #$SO_REUSEADDR))
|
||
|
|
|
||
|
|
(defun set-socket-option-reuseaddr (socket value)
|
||
|
|
(ccl::int-setsockopt (ccl::socket-device socket)
|
||
|
|
#$SOL_SOCKET #$SO_REUSEADDR value))
|
||
|
|
|
||
|
|
(defun get-socket-option-broadcast (socket)
|
||
|
|
(ccl::int-getsockopt (ccl::socket-device socket)
|
||
|
|
#$SOL_SOCKET #$SO_BROADCAST))
|
||
|
|
|
||
|
|
(defun set-socket-option-broadcast (socket value)
|
||
|
|
(ccl::int-setsockopt (ccl::socket-device socket)
|
||
|
|
#$SOL_SOCKET #$SO_BROADCAST value))
|
||
|
|
|
||
|
|
(defun get-socket-option-tcp-nodelay (socket)
|
||
|
|
(ccl::int-getsockopt (ccl::socket-device socket)
|
||
|
|
#$IPPROTO_TCP #$TCP_NODELAY))
|
||
|
|
|
||
|
|
(defun set-socket-option-tcp-nodelay (socket value)
|
||
|
|
(ccl::int-setsockopt (ccl::socket-device socket)
|
||
|
|
#$IPPROTO_TCP #$TCP_NODELAY value))
|