228 lines
8.4 KiB
Common Lisp
228 lines
8.4 KiB
Common Lisp
;;;; See LICENSE for licensing information.
|
|
|
|
(in-package :usocket)
|
|
|
|
#+cormanlisp
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(require :acl-socket))
|
|
|
|
#+allegro
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(require :sock)
|
|
;; for wait-for-input:
|
|
(require :process)
|
|
;; note: the line below requires ACL 6.2+
|
|
(require :osi))
|
|
|
|
(defun get-host-name ()
|
|
;; note: the line below requires ACL 7.0+ to actually *work* on windows
|
|
#+allegro (excl.osi:gethostname)
|
|
#+cormanlisp "")
|
|
|
|
(defparameter +allegro-identifier-error-map+
|
|
'((:address-in-use . address-in-use-error)
|
|
(:address-not-available . address-not-available-error)
|
|
(:network-down . network-down-error)
|
|
(:network-reset . network-reset-error)
|
|
(:network-unreachable . network-unreachable-error)
|
|
(:connection-aborted . connection-aborted-error)
|
|
(:connection-reset . connection-reset-error)
|
|
(:no-buffer-space . no-buffers-error)
|
|
(:shutdown . shutdown-error)
|
|
(:connection-timed-out . timeout-error)
|
|
(:connection-refused . connection-refused-error)
|
|
(:host-down . host-down-error)
|
|
(:host-unreachable . host-unreachable-error)))
|
|
|
|
;; TODO: what's the error class of Corman Lisp?
|
|
(defun handle-condition (condition &optional (socket nil) (host-or-ip nil))
|
|
"Dispatch correct usocket condition."
|
|
(typecase condition
|
|
#+allegro
|
|
(excl:socket-error
|
|
(let ((usock-error
|
|
(cdr (assoc (excl:stream-error-identifier condition)
|
|
+allegro-identifier-error-map+))))
|
|
(declare (type symbol usock-error))
|
|
(if usock-error
|
|
(cond ((subtypep usock-error 'ns-error)
|
|
(error usock-error :socket socket :host-or-ip host-or-ip))
|
|
(t
|
|
(error usock-error :socket socket)))
|
|
(error 'unknown-error
|
|
:real-error condition
|
|
:socket socket))))))
|
|
|
|
(defun to-format (element-type)
|
|
(if (subtypep element-type 'character)
|
|
:text
|
|
:binary))
|
|
|
|
(defun socket-connect (host port &key (protocol :stream) (element-type 'character)
|
|
timeout deadline
|
|
(nodelay t) ;; nodelay == t is the ACL default
|
|
local-host local-port)
|
|
(when timeout (unsupported 'timeout 'socket-connect))
|
|
(when deadline (unsupported 'deadline 'socket-connect))
|
|
(when (eq nodelay :if-supported)
|
|
(setf nodelay t))
|
|
|
|
(let ((socket))
|
|
(setf socket
|
|
(with-mapped-conditions (socket (or host local-host))
|
|
(ecase protocol
|
|
(:stream
|
|
(labels ((make-socket ()
|
|
(socket:make-socket :remote-host (host-to-hostname host)
|
|
:remote-port port
|
|
:local-host (when local-host
|
|
(host-to-hostname local-host))
|
|
:local-port local-port
|
|
:format (to-format element-type)
|
|
:nodelay nodelay)))
|
|
#+allegro
|
|
(if timeout
|
|
(mp:with-timeout (timeout nil)
|
|
(make-socket))
|
|
(make-socket))
|
|
#+cormanlisp (make-socket)))
|
|
(:datagram
|
|
(apply #'socket:make-socket
|
|
(nconc (list :type protocol
|
|
:address-family :internet
|
|
:local-host (when local-host
|
|
(host-to-hostname local-host))
|
|
:local-port local-port
|
|
:format (to-format element-type))
|
|
(if (and host port)
|
|
(list :connect :active
|
|
:remote-host (host-to-hostname host)
|
|
:remote-port port)
|
|
(list :connect :passive))))))))
|
|
(ecase protocol
|
|
(:stream
|
|
(make-stream-socket :socket socket :stream socket))
|
|
(:datagram
|
|
(make-datagram-socket socket :connected-p (and host port t))))))
|
|
|
|
;; One socket close method is sufficient,
|
|
;; because socket-streams are also sockets.
|
|
(defmethod socket-close ((usocket usocket))
|
|
"Close socket."
|
|
(with-mapped-conditions (usocket)
|
|
(close (socket usocket))))
|
|
|
|
(defmethod socket-shutdown ((usocket stream-usocket) direction)
|
|
(with-mapped-conditions (usocket)
|
|
(socket:shutdown (socket usocket) :direction direction)))
|
|
|
|
(defun socket-listen (host port
|
|
&key reuseaddress
|
|
(reuse-address nil reuse-address-supplied-p)
|
|
(backlog 5)
|
|
(element-type 'character))
|
|
;; Allegro and OpenMCL socket interfaces bear very strong resemblence
|
|
;; whatever you change here, change it also for OpenMCL
|
|
(let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
|
|
(sock (with-mapped-conditions (nil host)
|
|
(apply #'socket:make-socket
|
|
(append (list :connect :passive
|
|
:reuse-address reuseaddress
|
|
:local-port port
|
|
:backlog backlog
|
|
:format (to-format element-type)
|
|
;; allegro now ignores :format
|
|
)
|
|
(when (ip/= host *wildcard-host*)
|
|
(list :local-host host)))))))
|
|
(make-stream-server-socket sock :element-type element-type)))
|
|
|
|
(defmethod socket-accept ((socket stream-server-usocket) &key element-type)
|
|
(declare (ignore element-type)) ;; allegro streams are multivalent
|
|
(let ((stream-sock
|
|
(with-mapped-conditions (socket)
|
|
(socket:accept-connection (socket socket)))))
|
|
(make-stream-socket :socket stream-sock :stream stream-sock)))
|
|
|
|
(defmethod get-local-address ((usocket usocket))
|
|
(hbo-to-vector-quad (socket:local-host (socket usocket))))
|
|
|
|
(defmethod get-peer-address ((usocket stream-usocket))
|
|
(hbo-to-vector-quad (socket:remote-host (socket usocket))))
|
|
|
|
(defmethod get-local-port ((usocket usocket))
|
|
(socket:local-port (socket usocket)))
|
|
|
|
(defmethod get-peer-port ((usocket stream-usocket))
|
|
#+allegro
|
|
(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)))
|
|
|
|
#+allegro
|
|
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
|
|
(with-mapped-conditions (usocket host)
|
|
(let ((s (socket usocket)))
|
|
(socket:send-to s
|
|
(if (zerop offset)
|
|
buffer
|
|
(subseq buffer offset (+ offset size)))
|
|
size
|
|
:remote-host host
|
|
:remote-port port))))
|
|
|
|
#+allegro
|
|
(defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
|
|
(declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
|
|
(integer 0) ; size
|
|
(unsigned-byte 32) ; host
|
|
(unsigned-byte 16))) ; port
|
|
(with-mapped-conditions (usocket)
|
|
(let ((s (socket usocket)))
|
|
(socket:receive-from s length :buffer buffer :extract t))))
|
|
|
|
(defun get-host-by-address (address)
|
|
(with-mapped-conditions (nil address)
|
|
(socket:ipaddr-to-hostname (host-to-hbo address))))
|
|
|
|
(defun get-hosts-by-name (name)
|
|
;;###FIXME: ACL has the acldns module which returns all A records
|
|
;; only problem: it doesn't fall back to tcp (from udp) if the returned
|
|
;; structure is too long.
|
|
(with-mapped-conditions (nil name)
|
|
(list (hbo-to-vector-quad (socket:lookup-hostname
|
|
(host-to-hostname name))))))
|
|
|
|
(defun %setup-wait-list (wait-list)
|
|
(declare (ignore wait-list)))
|
|
|
|
(defun %add-waiter (wait-list waiter)
|
|
(push (socket waiter) (wait-list-%wait wait-list)))
|
|
|
|
(defun %remove-waiter (wait-list waiter)
|
|
(setf (wait-list-%wait wait-list)
|
|
(remove (socket waiter) (wait-list-%wait wait-list))))
|
|
|
|
#+allegro
|
|
(defun wait-for-input-internal (wait-list &key timeout)
|
|
(with-mapped-conditions ()
|
|
(let ((active-internal-sockets
|
|
(if timeout
|
|
(mp:wait-for-input-available (wait-list-%wait wait-list)
|
|
:timeout timeout)
|
|
(mp:wait-for-input-available (wait-list-%wait wait-list)))))
|
|
;; this is quadratic, but hey, the active-internal-sockets
|
|
;; list is very short and it's only quadratic in the length of that one.
|
|
;; When I have more time I could recode it to something of linear
|
|
;; complexity.
|
|
;; [Same code is also used in openmcl.lisp]
|
|
(dolist (x active-internal-sockets)
|
|
(setf (state (gethash x (wait-list-map wait-list)))
|
|
:read))
|
|
wait-list)))
|