1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
;;;; 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)))
(defun handle-condition (condition &optional (socket nil))
"Dispatch correct usocket condition."
(typecase condition
#+allegro
(excl:socket-error
(let ((usock-err
(cdr (assoc (excl:stream-error-identifier condition)
+allegro-identifier-error-map+))))
(if usock-err
(error usock-err :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)
(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."
(when (wait-list usocket)
(remove-waiter (wait-list usocket) usocket))
(with-mapped-conditions (usocket)
(close (socket usocket))))
(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 ()
(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)
(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 ((socket 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 (socket)
(let ((s (socket socket)))
(socket:receive-from s length :buffer buffer :extract t))))
(defun get-host-by-address (address)
(with-mapped-conditions ()
(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 ()
(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)))
|
