tlispworks.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tlispworks.lisp (40217B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (require "comm")
7
8 #+lispworks3
9 (error "LispWorks 3 is not supported"))
10
11 ;;; ---------------------------------------------------------------------------
12 ;;; Warn if multiprocessing is not running on Lispworks
13
14 (defun check-for-multiprocessing-started (&optional errorp)
15 (unless mp:*current-process*
16 (funcall (if errorp 'error 'warn)
17 "You must start multiprocessing on Lispworks by calling~
18 ~%~3t(~s)~
19 ~%for ~s function properly."
20 'mp:initialize-multiprocessing
21 'wait-for-input)))
22
23 (eval-when (:load-toplevel :execute)
24 (check-for-multiprocessing-started))
25
26 #+win32
27 (eval-when (:load-toplevel :execute)
28 (fli:register-module "ws2_32"))
29
30 (fli:define-foreign-function (get-host-name-internal "gethostname" :source)
31 ((return-string (:reference-return (:ef-mb-string :limit 257)))
32 (namelen :int))
33 :lambda-list (&aux (namelen 256) return-string)
34 :result-type :int
35 #+win32 :module
36 #+win32 "ws2_32")
37
38 (defun get-host-name ()
39 (multiple-value-bind (return-code name)
40 (get-host-name-internal)
41 (when (zerop return-code)
42 name)))
43
44 #+win32
45 (defun remap-maybe-for-win32 (z)
46 (mapcar #'(lambda (x)
47 (cons (mapcar #'(lambda (y) (+ 10000 y)) (car x))
48 (cdr x)))
49 z))
50
51 (defparameter +lispworks-error-map+
52 #+win32
53 (append (remap-maybe-for-win32 +unix-errno-condition-map+)
54 (remap-maybe-for-win32 +unix-errno-error-map+))
55 #-win32
56 (append +unix-errno-condition-map+
57 +unix-errno-error-map+))
58
59 (defun raise-usock-err (errno socket &optional condition)
60 (let ((usock-err
61 (cdr (assoc errno +lispworks-error-map+ :test #'member))))
62 (if usock-err
63 (if (subtypep usock-err 'error)
64 (error usock-err :socket socket)
65 (signal usock-err))
66 (error 'unknown-error
67 :socket socket
68 :real-error condition
69 :errno errno))))
70
71 (defun handle-condition (condition &optional (socket nil))
72 "Dispatch correct usocket condition."
73 (typecase condition
74 (condition (let ((errno #-win32 (lw:errno-value)
75 #+win32 (wsa-get-last-error)))
76 (unless (zerop errno)
77 (raise-usock-err errno socket condition))))))
78
79 (defconstant *socket_sock_dgram* 2
80 "Connectionless, unreliable datagrams of fixed maximum length.")
81
82 (defconstant *socket_ip_proto_udp* 17)
83
84 (defconstant *sockopt_so_rcvtimeo*
85 #-linux #x1006
86 #+linux 20
87 "Socket receive timeout")
88
89 (defconstant *sockopt_so_sndtimeo*
90 #-linux #x1007
91 #+linux 21
92 "Socket send timeout")
93
94 (fli:define-c-struct timeval
95 (tv-sec :long)
96 (tv-usec :long))
97
98 ;;; ssize_t
99 ;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags,
100 ;;; struct sockaddr *restrict address, socklen_t *restrict address_len);
101 (fli:define-foreign-function (%recvfrom "recvfrom" :source)
102 ((socket :int)
103 (buffer (:pointer (:unsigned :byte)))
104 (length :int)
105 (flags :int)
106 (address (:pointer (:struct comm::sockaddr)))
107 (address-len (:pointer :int)))
108 :result-type :int
109 #+win32 :module
110 #+win32 "ws2_32")
111
112 ;;; ssize_t
113 ;;; sendto(int socket, const void *buffer, size_t length, int flags,
114 ;;; const struct sockaddr *dest_addr, socklen_t dest_len);
115 (fli:define-foreign-function (%sendto "sendto" :source)
116 ((socket :int)
117 (buffer (:pointer (:unsigned :byte)))
118 (length :int)
119 (flags :int)
120 (address (:pointer (:struct comm::sockaddr)))
121 (address-len :int))
122 :result-type :int
123 #+win32 :module
124 #+win32 "ws2_32")
125
126 #-win32
127 (defun set-socket-receive-timeout (socket-fd seconds)
128 "Set socket option: RCVTIMEO, argument seconds can be a float number"
129 (declare (type integer socket-fd)
130 (type number seconds))
131 (multiple-value-bind (sec usec) (truncate seconds)
132 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
133 (fli:with-foreign-slots (tv-sec tv-usec) timeout
134 (setf tv-sec sec
135 tv-usec (truncate (* 1000000 usec)))
136 (if (zerop (comm::setsockopt socket-fd
137 comm::*sockopt_sol_socket*
138 *sockopt_so_rcvtimeo*
139 (fli:copy-pointer timeout
140 :type '(:pointer :void))
141 (fli:size-of '(:struct timeval))))
142 seconds)))))
143
144 #-win32
145 (defun set-socket-send-timeout (socket-fd seconds)
146 "Set socket option: SNDTIMEO, argument seconds can be a float number"
147 (declare (type integer socket-fd)
148 (type number seconds))
149 (multiple-value-bind (sec usec) (truncate seconds)
150 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)))
151 (fli:with-foreign-slots (tv-sec tv-usec) timeout
152 (setf tv-sec sec
153 tv-usec (truncate (* 1000000 usec)))
154 (if (zerop (comm::setsockopt socket-fd
155 comm::*sockopt_sol_socket*
156 *sockopt_so_sndtimeo*
157 (fli:copy-pointer timeout
158 :type '(:pointer :void))
159 (fli:size-of '(:struct timeval))))
160 seconds)))))
161
162 #+win32
163 (defun set-socket-receive-timeout (socket-fd seconds)
164 "Set socket option: RCVTIMEO, argument seconds can be a float number.
165 On win32, you must bind the socket before use this function."
166 (declare (type integer socket-fd)
167 (type number seconds))
168 (fli:with-dynamic-foreign-objects ((timeout :int))
169 (setf (fli:dereference timeout)
170 (truncate (* 1000 seconds)))
171 (if (zerop (comm::setsockopt socket-fd
172 comm::*sockopt_sol_socket*
173 *sockopt_so_rcvtimeo*
174 (fli:copy-pointer timeout
175 :type '(:pointer :char))
176 (fli:size-of :int)))
177 seconds)))
178
179 #+win32
180 (defun set-socket-send-timeout (socket-fd seconds)
181 "Set socket option: SNDTIMEO, argument seconds can be a float number.
182 On win32, you must bind the socket before use this function."
183 (declare (type integer socket-fd)
184 (type number seconds))
185 (fli:with-dynamic-foreign-objects ((timeout :int))
186 (setf (fli:dereference timeout)
187 (truncate (* 1000 seconds)))
188 (if (zerop (comm::setsockopt socket-fd
189 comm::*sockopt_sol_socket*
190 *sockopt_so_sndtimeo*
191 (fli:copy-pointer timeout
192 :type '(:pointer :char))
193 (fli:size-of :int)))
194 seconds)))
195
196 #-win32
197 (defun get-socket-receive-timeout (socket-fd)
198 "Get socket option: RCVTIMEO, return value is a float number"
199 (declare (type integer socket-fd))
200 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
201 (len :int))
202 (comm::getsockopt socket-fd
203 comm::*sockopt_sol_socket*
204 *sockopt_so_rcvtimeo*
205 (fli:copy-pointer timeout
206 :type '(:pointer :void))
207 len)
208 (fli:with-foreign-slots (tv-sec tv-usec) timeout
209 (float (+ tv-sec (/ tv-usec 1000000))))))
210
211 #-win32
212 (defun get-socket-send-timeout (socket-fd)
213 "Get socket option: SNDTIMEO, return value is a float number"
214 (declare (type integer socket-fd))
215 (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))
216 (len :int))
217 (comm::getsockopt socket-fd
218 comm::*sockopt_sol_socket*
219 *sockopt_so_sndtimeo*
220 (fli:copy-pointer timeout
221 :type '(:pointer :void))
222 len)
223 (fli:with-foreign-slots (tv-sec tv-usec) timeout
224 (float (+ tv-sec (/ tv-usec 1000000))))))
225
226 #+win32
227 (defun get-socket-receive-timeout (socket-fd)
228 "Get socket option: RCVTIMEO, return value is a float number"
229 (declare (type integer socket-fd))
230 (fli:with-dynamic-foreign-objects ((timeout :int)
231 (len :int))
232 (comm::getsockopt socket-fd
233 comm::*sockopt_sol_socket*
234 *sockopt_so_rcvtimeo*
235 (fli:copy-pointer timeout
236 :type '(:pointer :void))
237 len)
238 (float (/ (fli:dereference timeout) 1000))))
239
240 #+win32
241 (defun get-socket-send-timeout (socket-fd)
242 "Get socket option: SNDTIMEO, return value is a float number"
243 (declare (type integer socket-fd))
244 (fli:with-dynamic-foreign-objects ((timeout :int)
245 (len :int))
246 (comm::getsockopt socket-fd
247 comm::*sockopt_sol_socket*
248 *sockopt_so_sndtimeo*
249 (fli:copy-pointer timeout
250 :type '(:pointer :void))
251 len)
252 (float (/ (fli:dereference timeout) 1000))))
253
254 #+(or lispworks4 lispworks5.0)
255 (defun set-socket-tcp-nodelay (socket-fd new-value)
256 "Set socket option: TCP_NODELAY, argument is a fixnum (0 or 1)"
257 (declare (type integer socket-fd)
258 (type (integer 0 1) new-value))
259 (fli:with-dynamic-foreign-objects ((zero-or-one :int))
260 (setf (fli:dereference zero-or-one) new-value)
261 (when (zerop (comm::setsockopt socket-fd
262 comm::*sockopt_sol_socket*
263 comm::*sockopt_tcp_nodelay*
264 (fli:copy-pointer zero-or-one
265 :type '(:pointer #+win32 :char #-win32 :void))
266 (fli:size-of :int)))
267 new-value)))
268
269 (defun get-socket-tcp-nodelay (socket-fd)
270 "Get socket option: TCP_NODELAY, return value is a fixnum (0 or 1)"
271 (declare (type integer socket-fd))
272 (fli:with-dynamic-foreign-objects ((zero-or-one :int)
273 (len :int))
274 (if (zerop (comm::getsockopt socket-fd
275 comm::*sockopt_sol_socket*
276 comm::*sockopt_tcp_nodelay*
277 (fli:copy-pointer zero-or-one
278 :type '(:pointer #+win32 :char #-win32 :void))
279 len))
280 zero-or-one 0))) ; on error, return 0
281
282 (defun initialize-dynamic-sockaddr (hostname service protocol &aux (original-hostname hostname))
283 (declare (ignorable original-hostname))
284 #+(or lispworks4 lispworks5 lispworks6.0)
285 (let ((server-addr (fli:allocate-dynamic-foreign-object
286 :type '(:struct comm::sockaddr_in))))
287 (values (comm::initialize-sockaddr_in
288 server-addr
289 comm::*socket_af_inet*
290 hostname
291 service protocol)
292 comm::*socket_af_inet*
293 server-addr
294 (fli:pointer-element-size server-addr)))
295 #-(or lispworks4 lispworks5 lispworks6.0) ; version>=6.1
296 (progn
297 (when (stringp hostname)
298 (setq hostname (comm:string-ip-address hostname))
299 (unless hostname
300 (let ((resolved-hostname (comm:get-host-entry original-hostname :fields '(:address))))
301 (unless resolved-hostname
302 (return-from initialize-dynamic-sockaddr :unknown-host))
303 (setq hostname resolved-hostname))))
304 (if (or (null hostname)
305 (integerp hostname)
306 (comm:ipv6-address-p hostname))
307 (let ((server-addr (fli:allocate-dynamic-foreign-object
308 :type '(:struct comm::lw-sockaddr))))
309 (multiple-value-bind (error family)
310 (comm::initialize-sockaddr_in
311 server-addr
312 hostname
313 service protocol)
314 (values error family
315 server-addr
316 (if (eql family comm::*socket_af_inet*)
317 (fli:size-of '(:struct comm::sockaddr_in))
318 (fli:size-of '(:struct comm::sockaddr_in6))))))
319 :bad-host)))
320
321 (defun open-udp-socket (&key local-address local-port read-timeout
322 (address-family comm::*socket_af_inet*))
323 "Open a unconnected UDP socket.
324 For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL),
325 for binding on random free unused port, set LOCAL-PORT to 0."
326
327 ;; Note: move (ensure-sockets) here to make sure delivered applications
328 ;; correctly have networking support initialized.
329 ;;
330 ;; Following words was from Martin Simmons, forwarded by Camille Troillard:
331
332 ;; Calling comm::ensure-sockets at load time looks like a bug in Lispworks-udp
333 ;; (it is too early and also unnecessary).
334
335 ;; The LispWorks comm package calls comm::ensure-sockets when it is needed, so I
336 ;; think open-udp-socket should probably do it too. Calling it more than once is
337 ;; safe and it will be very fast after the first time.
338 #+win32 (comm::ensure-sockets)
339
340 (let ((socket-fd (comm::socket address-family *socket_sock_dgram* *socket_ip_proto_udp*)))
341 (if socket-fd
342 (progn
343 (when read-timeout (set-socket-receive-timeout socket-fd read-timeout))
344 (if local-port
345 (fli:with-dynamic-foreign-objects ()
346 (multiple-value-bind (error local-address-family
347 client-addr client-addr-length)
348 (initialize-dynamic-sockaddr local-address local-port "udp")
349 (if (or error (not (eql address-family local-address-family)))
350 (progn
351 (comm::close-socket socket-fd)
352 (error "cannot resolve hostname ~S, service ~S: ~A"
353 local-address local-port (or error "address family mismatch")))
354 (if (comm::bind socket-fd client-addr client-addr-length)
355 ;; success, return socket fd
356 socket-fd
357 (progn
358 (comm::close-socket socket-fd)
359 (error "cannot bind"))))))
360 socket-fd))
361 (error "cannot create socket"))))
362
363 (defun connect-to-udp-server (hostname service
364 &key local-address local-port read-timeout)
365 "Something like CONNECT-TO-TCP-SERVER"
366 (fli:with-dynamic-foreign-objects ()
367 (multiple-value-bind (error address-family server-addr server-addr-length)
368 (initialize-dynamic-sockaddr hostname service "udp")
369 (when error
370 (error "cannot resolve hostname ~S, service ~S: ~A"
371 hostname service error))
372 (let ((socket-fd (open-udp-socket :local-address local-address
373 :local-port local-port
374 :read-timeout read-timeout
375 :address-family address-family)))
376 (if socket-fd
377 (if (comm::connect socket-fd server-addr server-addr-length)
378 ;; success, return socket fd
379 socket-fd
380 ;; fail, close socket and return nil
381 (progn
382 (comm::close-socket socket-fd)
383 (error "cannot connect")))
384 (error "cannot create socket"))))))
385
386 (defun socket-connect (host port &key (protocol :stream) (element-type 'base-char)
387 timeout deadline (nodelay t)
388 local-host local-port)
389 ;; What's the meaning of this keyword?
390 (when deadline
391 (unimplemented 'deadline 'socket-connect))
392
393 #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5
394 (when timeout
395 (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5"))
396
397 #+lispworks4
398 (when local-host
399 (unsupported 'local-host 'socket-connect :minimum "LispWorks 5.0"))
400 #+lispworks4
401 (when local-port
402 (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0"))
403
404 (ecase protocol
405 (:stream
406 (let ((hostname (host-to-hostname host))
407 (stream))
408 (setq stream
409 (with-mapped-conditions ()
410 (comm:open-tcp-stream hostname port
411 :element-type element-type
412 #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5
413 #-(and lispworks4 (not lispworks4.4))
414 :timeout timeout
415 #-lispworks4 #-lispworks4
416 #-lispworks4 #-lispworks4
417 :local-address (when local-host (host-to-hostname local-host))
418 :local-port local-port
419 #-(or lispworks4 lispworks5.0) ; >= 5.1
420 #-(or lispworks4 lispworks5.0)
421 :nodelay nodelay)))
422
423 ;; Then handle `nodelay' separately for older versions <= 5.0
424 #+(or lispworks4 lispworks5.0)
425 (when (and stream nodelay)
426 (set-socket-tcp-nodelay
427 (comm:socket-stream-socket stream)
428 (bool->int nodelay))) ; ":if-supported" maps to 1 too.
429
430 (if stream
431 (make-stream-socket :socket (comm:socket-stream-socket stream)
432 :stream stream)
433 ;; if no other error catched by above with-mapped-conditions and still fails, then it's a timeout
434 (error 'timeout-error))))
435 (:datagram
436 (let ((usocket (make-datagram-socket
437 (if (and host port)
438 (with-mapped-conditions ()
439 (connect-to-udp-server (host-to-hostname host) port
440 :local-address (and local-host (host-to-hostname local-host))
441 :local-port local-port
442 :read-timeout timeout))
443 (with-mapped-conditions ()
444 (open-udp-socket :local-address (and local-host (host-to-hostname local-host))
445 :local-port local-port
446 :read-timeout timeout)))
447 :connected-p (and host port t))))
448 usocket))))
449
450 (defun socket-listen (host port
451 &key reuseaddress
452 (reuse-address nil reuse-address-supplied-p)
453 (backlog 5)
454 (element-type 'base-char))
455 #+lispworks4.1
456 (unsupported 'host 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
457 #+lispworks4.1
458 (unsupported 'backlog 'socket-listen :minimum "LispWorks 4.0 or newer than 4.1")
459
460 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
461 (comm::*use_so_reuseaddr* reuseaddress)
462 (hostname (host-to-hostname host))
463 (socket-res-list (with-mapped-conditions ()
464 (multiple-value-list
465 #-lispworks4.1 (comm::create-tcp-socket-for-service
466 port :address hostname :backlog backlog)
467 #+lispworks4.1 (comm::create-tcp-socket-for-service port))))
468 (sock (if (not (or (second socket-res-list) (third socket-res-list)))
469 (first socket-res-list)
470 (when (eq (second socket-res-list) :bind)
471 (error 'address-in-use-error)))))
472 (make-stream-server-socket sock :element-type element-type)))
473
474 ;; Note: COMM::GET-FD-FROM-SOCKET contains addition socket wait operations, which
475 ;; should NOT be applied on socket FDs who have already been called on W-F-I,
476 ;; so we have to check the %READY-P slot to decide if this waiting is necessary,
477 ;; or SOCKET-ACCEPT will just hang. -- Chun Tian (binghe), May 1, 2011
478
479 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
480 (let* ((socket (with-mapped-conditions (usocket)
481 #+win32
482 (if (%ready-p usocket)
483 (comm::accept-connection-to-socket (socket usocket))
484 (comm::get-fd-from-socket (socket usocket)))
485 #-win32
486 (comm::get-fd-from-socket (socket usocket))))
487 (stream (make-instance 'comm:socket-stream
488 :socket socket
489 :direction :io
490 :element-type (or element-type
491 (element-type usocket)))))
492 #+win32
493 (when socket
494 (setf (%ready-p usocket) nil))
495 (make-stream-socket :socket socket :stream stream)))
496
497 ;; Sockets and their streams are different objects
498 ;; close the stream in order to make sure buffers
499 ;; are correctly flushed and the socket closed.
500 (defmethod socket-close ((usocket stream-usocket))
501 "Close socket."
502 (when (wait-list usocket)
503 (remove-waiter (wait-list usocket) usocket))
504 (close (socket-stream usocket)))
505
506 (defmethod socket-close ((usocket usocket))
507 (when (wait-list usocket)
508 (remove-waiter (wait-list usocket) usocket))
509 (with-mapped-conditions (usocket)
510 (comm::close-socket (socket usocket))))
511
512 (defmethod socket-close :after ((socket datagram-usocket))
513 "Additional socket-close method for datagram-usocket"
514 (setf (%open-p socket) nil))
515
516 (defconstant +shutdown-read+ 0)
517 (defconstant +shutdown-write+ 1)
518 (defconstant +shutdown-read-write+ 2)
519
520 ;;; int
521 ;;; shutdown(int socket, int what);
522 (fli:define-foreign-function (%shutdown "shutdown" :source)
523 ((socket :int)
524 (what :int))
525 :result-type :int
526 #+win32 :module
527 #+win32 "ws2_32")
528
529 (defmethod socket-shutdown ((usocket datagram-usocket) direction)
530 (unless (member direction '(:input :output :io))
531 (error 'invalid-argument-error))
532 (let ((what (case direction
533 (:input +shutdown-read+)
534 (:output +shutdown-write+)
535 (:io +shutdown-read-write+))))
536 (with-mapped-conditions (usocket)
537 #-(or lispworks4 lispworks5 lispworks6) ; lispworks 7.0+
538 (comm::shutdown (socket usocket) what)
539 #+(or lispworks4 lispworks5 lispworks6)
540 (= 0 (%shutdown (socket usocket) what)))))
541
542 (defmethod socket-shutdown ((usocket stream-usocket) direction)
543 (unless (member direction '(:input :output :io))
544 (error 'invalid-argument-error))
545 (with-mapped-conditions (usocket)
546 #-(or lispworks4 lispworks5 lispworks6)
547 (comm:socket-stream-shutdown (socket usocket) direction)
548 #+(or lispworks4 lispworks5 lispworks6)
549 (let ((what (case direction
550 (:input +shutdown-read+)
551 (:output +shutdown-write+)
552 (:io +shutdown-read-write+))))
553 (= 0 (%shutdown (comm:socket-stream-socket (socket usocket)) what)))))
554
555 (defmethod initialize-instance :after ((socket datagram-usocket) &key)
556 (setf (slot-value socket 'send-buffer)
557 (make-array +max-datagram-packet-size+
558 :element-type '(unsigned-byte 8)
559 :allocation :static))
560 (setf (slot-value socket 'recv-buffer)
561 (make-array +max-datagram-packet-size+
562 :element-type '(unsigned-byte 8)
563 :allocation :static)))
564
565 (defvar *length-of-sockaddr_in*
566 (fli:size-of '(:struct comm::sockaddr_in)))
567
568 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
569 &aux (socket-fd (socket usocket))
570 (message (slot-value usocket 'send-buffer))) ; TODO: multiple threads send together?
571 "Send message to a socket, using sendto()/send()"
572 (declare (type integer socket-fd)
573 (type sequence buffer))
574 (when host (setq host (host-to-hostname host)))
575 (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
576 (replace message buffer :start2 offset :end2 (+ offset size))
577 (let ((n (if (and host port)
578 (fli:with-dynamic-foreign-objects ()
579 (multiple-value-bind (error family client-addr client-addr-length)
580 (initialize-dynamic-sockaddr host port "udp")
581 (declare (ignore family))
582 (when error
583 (error "cannot resolve hostname ~S, port ~S: ~A"
584 host port error))
585 (%sendto socket-fd ptr (min size +max-datagram-packet-size+) 0
586 (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
587 client-addr-length)))
588 (comm::%send socket-fd ptr (min size +max-datagram-packet-size+) 0))))
589 (declare (type fixnum n))
590 (if (plusp n)
591 n
592 (let ((errno #-win32 (lw:errno-value)
593 #+win32 (wsa-get-last-error)))
594 (if (zerop errno)
595 n
596 (raise-usock-err errno socket-fd)))))))
597
598 (defmethod socket-receive ((socket datagram-usocket) buffer length &key timeout (max-buffer-size +max-datagram-packet-size+))
599 "Receive message from socket, read-timeout is a float number in seconds.
600
601 This function will return 4 values:
602 1. receive buffer
603 2. number of receive bytes
604 3. remote address
605 4. remote port"
606 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
607 (integer 0) ; size
608 (unsigned-byte 32) ; host
609 (unsigned-byte 16)) ; port
610 (type sequence buffer))
611 (let ((socket-fd (socket socket))
612 (message (slot-value socket 'recv-buffer)) ; TODO: how multiple threads do this in parallel?
613 (read-timeout timeout)
614 old-timeout)
615 (declare (type integer socket-fd))
616 (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
617 (len :int
618 #-(or lispworks4 lispworks5.0) ; <= 5.0
619 :initial-element *length-of-sockaddr_in*))
620 #+(or lispworks4 lispworks5.0) ; <= 5.0
621 (setf (fli:dereference len) *length-of-sockaddr_in*)
622 (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
623 ;; setup new read timeout
624 (when read-timeout
625 (setf old-timeout (get-socket-receive-timeout socket-fd))
626 (set-socket-receive-timeout socket-fd read-timeout))
627 (let ((n (%recvfrom socket-fd ptr max-buffer-size 0
628 (fli:copy-pointer client-addr :type '(:struct comm::sockaddr))
629 len)))
630 (declare (type fixnum n))
631 ;; restore old read timeout
632 (when (and read-timeout (/= old-timeout read-timeout))
633 (set-socket-receive-timeout socket-fd old-timeout))
634 ;; Frank James' patch: reset the %read-p for WAIT-FOR-INPUT
635 #+win32 (setf (%ready-p socket) nil)
636 (if (plusp n)
637 (values (if buffer
638 (replace buffer message
639 :end1 (min length max-buffer-size)
640 :end2 (min n max-buffer-size))
641 (subseq message 0 (min n max-buffer-size)))
642 (min n max-buffer-size)
643 (comm::ntohl (fli:foreign-slot-value
644 (fli:foreign-slot-value client-addr
645 'comm::sin_addr
646 :object-type '(:struct comm::sockaddr_in)
647 :type '(:struct comm::in_addr)
648 :copy-foreign-object nil)
649 'comm::s_addr
650 :object-type '(:struct comm::in_addr)))
651 (comm::ntohs (fli:foreign-slot-value client-addr
652 'comm::sin_port
653 :object-type '(:struct comm::sockaddr_in)
654 :type '(:unsigned :short)
655 :copy-foreign-object nil)))
656 (let ((errno #-win32 (lw:errno-value)
657 #+win32 (wsa-get-last-error)))
658 (if (zerop errno)
659 (values nil n 0 0)
660 (raise-usock-err errno socket-fd)))))))))
661
662 (defmethod get-local-name ((usocket usocket))
663 (multiple-value-bind
664 (address port)
665 (comm:get-socket-address (socket usocket))
666 (values (hbo-to-vector-quad address) port)))
667
668 (defmethod get-peer-name ((usocket stream-usocket))
669 (multiple-value-bind
670 (address port)
671 (comm:get-socket-peer-address (socket usocket))
672 (values (hbo-to-vector-quad address) port)))
673
674 (defmethod get-local-address ((usocket usocket))
675 (nth-value 0 (get-local-name usocket)))
676
677 (defmethod get-peer-address ((usocket stream-usocket))
678 (nth-value 0 (get-peer-name usocket)))
679
680 (defmethod get-local-port ((usocket usocket))
681 (nth-value 1 (get-local-name usocket)))
682
683 (defmethod get-peer-port ((usocket stream-usocket))
684 (nth-value 1 (get-peer-name usocket)))
685
686 #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1
687 (defun ipv6-address-p (hostname)
688 (when (stringp hostname)
689 (setq hostname (comm:string-ip-address hostname))
690 (unless hostname
691 (let ((resolved-hostname (comm:get-host-entry hostname :fields '(:address))))
692 (unless resolved-hostname
693 (return-from ipv6-address-p nil))
694 (setq hostname resolved-hostname))))
695 (comm:ipv6-address-p hostname))
696
697 (defun lw-hbo-to-vector-quad (hbo)
698 #+(or lispworks4 lispworks5 lispworks6.0)
699 (hbo-to-vector-quad hbo)
700 #-(or lispworks4 lispworks5 lispworks6.0) ; version>= 6.1
701 (if (comm:ipv6-address-p hbo)
702 (ipv6-host-to-vector (comm:ipv6-address-string hbo))
703 (hbo-to-vector-quad hbo)))
704
705 (defun get-hosts-by-name (name)
706 (with-mapped-conditions ()
707 (mapcar #'lw-hbo-to-vector-quad
708 (comm:get-host-entry name :fields '(:addresses)))))
709
710 (defun os-socket-handle (usocket)
711 (socket usocket))
712
713 (defun usocket-listen (usocket)
714 (if (stream-usocket-p usocket)
715 (when (listen (socket-stream usocket))
716 usocket)
717 (when (comm::socket-listen (socket usocket))
718 usocket)))
719
720 ;;;
721 ;;; Non Windows implementation
722 ;;; The Windows implementation needs to resort to the Windows API in order
723 ;;; to achieve what we want (what we want is waiting without busy-looping)
724 ;;;
725
726 #-win32
727 (progn
728
729 (defun %setup-wait-list (wait-list)
730 (declare (ignore wait-list)))
731
732 (defun %add-waiter (wait-list waiter)
733 (declare (ignore wait-list waiter)))
734
735 (defun %remove-waiter (wait-list waiter)
736 (declare (ignore wait-list waiter)))
737
738 (defun wait-for-input-internal (wait-list &key timeout)
739 (with-mapped-conditions ()
740 ;; unfortunately, it's impossible to share code between
741 ;; non-win32 and win32 platforms...
742 ;; Can we have a sane -pref. complete [UDP!?]- API next time, please?
743 (dolist (x (wait-list-waiters wait-list))
744 (mp:notice-fd (os-socket-handle x)))
745 (labels ((wait-function (socks)
746 (let (rv)
747 (dolist (x socks rv)
748 (when (usocket-listen x)
749 (setf (state x) :READ
750 rv t))))))
751 (if timeout
752 (mp:process-wait-with-timeout "Waiting for a socket to become active"
753 (truncate timeout)
754 #'wait-function
755 (wait-list-waiters wait-list))
756 (mp:process-wait "Waiting for a socket to become active"
757 #'wait-function
758 (wait-list-waiters wait-list))))
759 (dolist (x (wait-list-waiters wait-list))
760 (mp:unnotice-fd (os-socket-handle x)))
761 wait-list))
762
763 ) ; end of block
764
765
766 ;;;
767 ;;; The Windows side of the story
768 ;;; We want to wait without busy looping
769 ;;; This code only works in threads which don't have (hidden)
770 ;;; windows which need to receive messages. There are workarounds in the Windows API
771 ;;; but are those available to 'us'.
772 ;;;
773
774
775 #+win32
776 (progn
777
778 ;; LispWorks doesn't provide an interface to wait for a socket
779 ;; to become ready (under Win32, that is) meaning that we need
780 ;; to resort to system calls to achieve the same thing.
781 ;; Luckily, it provides us access to the raw socket handles (as we
782 ;; wrote the code above.
783
784 (defconstant fd-read 1)
785 (defconstant fd-read-bit 0)
786 (defconstant fd-write 2)
787 (defconstant fd-write-bit 1)
788 (defconstant fd-oob 4)
789 (defconstant fd-oob-bit 2)
790 (defconstant fd-accept 8)
791 (defconstant fd-accept-bit 3)
792 (defconstant fd-connect 16)
793 (defconstant fd-connect-bit 4)
794 (defconstant fd-close 32)
795 (defconstant fd-close-bit 5)
796 (defconstant fd-qos 64)
797 (defconstant fd-qos-bit 6)
798 (defconstant fd-group-qos 128)
799 (defconstant fd-group-qos-bit 7)
800 (defconstant fd-routing-interface 256)
801 (defconstant fd-routing-interface-bit 8)
802 (defconstant fd-address-list-change 512)
803 (defconstant fd-address-list-change-bit 9)
804
805 (defconstant fd-max-events 10)
806
807 (defconstant fionread 1074030207)
808
809
810 ;; Note:
811 ;;
812 ;; If special finalization has to occur for a given
813 ;; system resource (handle), an associated object should
814 ;; be created. A special cleanup action should be added
815 ;; to the system and a special cleanup action should
816 ;; be flagged on all objects created for resources like it
817 ;;
818 ;; We have 2 functions to do so:
819 ;; * hcl:add-special-free-action (function-symbol)
820 ;; * hcl:flag-special-free-action (object)
821 ;;
822 ;; Note that the special free action will be called on all
823 ;; objects which have been flagged for special free, so be
824 ;; sure to check for the right argument type!
825
826 (fli:define-foreign-type ws-socket () '(:unsigned :int))
827 (fli:define-foreign-type win32-handle () '(:unsigned :int))
828 (fli:define-c-struct wsa-network-events
829 (network-events :long)
830 (error-code (:c-array :int 10)))
831
832 (fli:define-foreign-function (wsa-event-create "WSACreateEvent" :source)
833 ()
834 :lambda-list nil
835 :result-type :int
836 :module "ws2_32")
837
838 (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
839 ((event-object win32-handle))
840 :result-type :int
841 :module "ws2_32")
842
843 (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
844 ((socket ws-socket)
845 (event-object win32-handle)
846 (network-events (:reference-return wsa-network-events)))
847 :result-type :int
848 :module "ws2_32")
849
850 (fli:define-foreign-function (wsa-event-select "WSAEventSelect" :source)
851 ((socket ws-socket)
852 (event-object win32-handle)
853 (network-events :long))
854 :result-type :int
855 :module "ws2_32")
856
857 (fli:define-foreign-function (wsa-get-last-error "WSAGetLastError" :source)
858 ()
859 :result-type :int
860 :module "ws2_32")
861
862 (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source)
863 ((socket :long) (cmd :long) (argp (:ptr :long)))
864 :result-type :int
865 :module "ws2_32")
866
867
868 ;; The Windows system
869
870
871 ;; Now that we have access to the system calls, this is the plan:
872
873 ;; 1. Receive a wait-list with associated sockets to wait for
874 ;; 2. Add all those sockets to an event handle
875 ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that)
876 ;; 4. After listening, detect if there are errors
877 ;; (this step is different from Unix, where we can have only one error)
878 ;; 5. If so, raise one of them
879 ;; 6. If not so, return the sockets which have input waiting for them
880
881
882 (defun maybe-wsa-error (rv &optional socket)
883 (unless (zerop rv)
884 (raise-usock-err (wsa-get-last-error) socket)))
885
886 (defun bytes-available-for-read (socket)
887 (fli:with-dynamic-foreign-objects ((int-ptr :long))
888 (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr)))
889 (if (= 0 rv)
890 (fli:dereference int-ptr)
891 0))))
892
893 (defun socket-ready-p (socket)
894 (if (typep socket 'stream-usocket)
895 (< 0 (bytes-available-for-read socket))
896 (%ready-p socket)))
897
898 (defun waiting-required (sockets)
899 (notany #'socket-ready-p sockets))
900
901 (defun wait-for-input-internal (wait-list &key timeout)
902 (when (waiting-required (wait-list-waiters wait-list))
903 (system:wait-for-single-object (wait-list-%wait wait-list)
904 "Waiting for socket activity" timeout))
905 (update-ready-and-state-slots (wait-list-waiters wait-list)))
906
907 (defun map-network-events (func network-events)
908 (let ((event-map (fli:foreign-slot-value network-events 'network-events))
909 (error-array (fli:foreign-slot-pointer network-events 'error-code)))
910 (unless (zerop event-map)
911 (dotimes (i fd-max-events)
912 (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand?
913 (funcall func (fli:foreign-aref error-array i)))))))
914
915 (defun update-ready-and-state-slots (sockets)
916 (dolist (socket sockets)
917 (if (or (and (stream-usocket-p socket)
918 (listen (socket-stream socket)))
919 (%ready-p socket))
920 (setf (state socket) :READ)
921 (multiple-value-bind
922 (rv network-events)
923 (wsa-enum-network-events (os-socket-handle socket) 0 t)
924 (if (zerop rv)
925 (map-network-events #'(lambda (err-code)
926 (if (zerop err-code)
927 (setf (%ready-p socket) t
928 (state socket) :READ)
929 (raise-usock-err err-code socket)))
930 network-events)
931 (maybe-wsa-error rv socket))))))
932
933 ;; The wait-list part
934
935 (defun free-wait-list (wl)
936 (when (wait-list-p wl)
937 (unless (null (wait-list-%wait wl))
938 (wsa-event-close (wait-list-%wait wl))
939 (setf (wait-list-%wait wl) nil))))
940
941 (eval-when (:load-toplevel :execute)
942 (hcl:add-special-free-action 'free-wait-list))
943
944 (defun %setup-wait-list (wait-list)
945 (hcl:flag-special-free-action wait-list)
946 (setf (wait-list-%wait wait-list) (wsa-event-create)))
947
948 (defun %add-waiter (wait-list waiter)
949 (let ((events (etypecase waiter
950 (stream-server-usocket (logior fd-connect fd-accept fd-close))
951 (stream-usocket (logior fd-connect fd-read fd-oob fd-close))
952 (datagram-usocket (logior fd-read)))))
953 (maybe-wsa-error
954 (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
955 waiter)))
956
957 (defun %remove-waiter (wait-list waiter)
958 (maybe-wsa-error
959 (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0)
960 waiter))
961
962 ) ; end of WIN32-block
963
964 (defun set-socket-reuse-address (socket-fd reuse-address-p)
965 (declare (type integer socket-fd)
966 (type boolean reuse-address-p))
967 (fli:with-dynamic-foreign-objects ((value :int))
968 (setf (fli:dereference value) (if reuse-address-p 1 0))
969 (if (zerop (comm::setsockopt socket-fd
970 comm::*sockopt_sol_socket*
971 comm::*sockopt_so_reuseaddr*
972 (fli:copy-pointer value
973 :type '(:pointer :void))
974 (fli:size-of :int)))
975 reuse-address-p)))
976
977 (defun get-socket-reuse-address (socket-fd)
978 (declare (type integer socket-fd))
979 (fli:with-dynamic-foreign-objects ((value :int) (len :int))
980 (if (zerop (comm::getsockopt socket-fd
981 comm::*sockopt_sol_socket*
982 comm::*sockopt_so_reuseaddr*
983 (fli:copy-pointer value
984 :type '(:pointer :void))
985 len))
986 (= 1 (fli:dereference value)))))