/[cmucl]/src/code/internet.lisp
ViewVC logotype

Contents of /src/code/internet.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.60 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.59: +36 -36 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Log: code.log; Package: extensions -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/internet.lisp,v 1.60 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains an interface to internet domain sockets.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16
17 (in-package "EXTENSIONS")
18
19 (use-package "ALIEN")
20 (use-package "C-CALL")
21
22 (intl:textdomain "cmucl")
23
24 (export '(htonl ntohl htons ntohs lookup-host-entry host-entry
25 host-entry-name host-entry-aliases host-entry-addr-list
26 host-entry-addr ip-string bind-inet-socket
27 create-unix-socket connect-to-unix-socket
28 create-unix-listener accept-unix-connection create-inet-socket
29 connect-to-inet-socket create-inet-listener accept-tcp-connection
30 close-socket ipproto-tcp ipproto-udp inaddr-any add-oob-handler
31 remove-oob-handler remove-all-oob-handlers
32 send-character-out-of-band
33
34 inet-recvfrom inet-sendto inet-shutdown
35 shut-rd shut-wr shut-rdwr
36
37 open-network-stream accept-network-stream))
38
39
40 #-svr4
41 (defconstant sock-stream 1)
42 #+svr4
43 (defconstant sock-stream 2)
44 #-svr4
45 (defconstant sock-dgram 2)
46 #+svr4
47 (defconstant sock-dgram 1)
48 #-svr4
49 (defconstant sock-raw 3)
50 #+svr4
51 (defconstant sock-raw 4)
52 #+linux
53 (defconstant sock-rdm 4)
54 #+linux
55 (defconstant sock-seqpacket 5)
56 #+linux
57 (defconstant sock-packet 10)
58
59 (defconstant af-unix 1) ; Unix domain sockets
60 (defconstant af-inet 2) ; Internet IP Protocol
61 #+linux
62 (progn
63 (defconstant af-ax25 3) ; Amateur Radio AX.25
64 (defconstant af-ipx 4) ; Novell IPX
65 (defconstant af-appletalk 5) ; Appletalk DDP
66 (defconstant af-netrom 6) ; Amateur radio NetROM
67 (defconstant af-bridge 7) ; Multiprotocol bridge
68 (defconstant af-aal5 9) ; Reserved for Werner's ATM
69 (defconstant af-x25 9) ; Reserved for X.25 project
70 (defconstant af-inet6 10) ; IP version 6
71 (defconstant af-max 12))
72
73 (defconstant msg-oob 1)
74 (defconstant msg-peek 2)
75 (defconstant msg-dontroute 4)
76 #+linux
77 (defconstant msg-proxy 16)
78
79 ;; For errors with socket stuff.
80 (define-condition socket-error (simple-error)
81 ((errno :reader socket-errno
82 :initarg :errno
83 :initform 0)))
84
85
86 (defvar *internet-protocols*
87 '((:stream 6 #.sock-stream)
88 (:datagram 17 #.sock-dgram))
89 "AList of socket kinds and protocol values.")
90
91 (defun internet-protocol (kind)
92 (when (eq kind :data-gram) ; Sep-2000. Remove someday.
93 (warn (intl:gettext "Internet protocol :DATA-GRAM is deprecated. Using :DATAGRAM"))
94 (setq kind :datagram))
95 (let ((entry (assoc kind *internet-protocols*)))
96 (unless entry
97 (error (intl:gettext "Invalid kind (~S) for internet domain sockets.") kind))
98 (values (cadr entry)
99 (caddr entry))))
100
101
102 (defmacro maybe-byte-swap (var bytes)
103 (ecase (c:backend-byte-order c:*backend*)
104 (:big-endian
105 var)
106 (:little-endian
107 (let ((ldbs nil))
108 (dotimes (i bytes `(logior ,@ldbs))
109 (push `(ash (ldb (byte 8 ,(* i 8)) ,var)
110 ,(* (- bytes 1 i) 8))
111 ldbs))))))
112
113 (declaim (inline htonl ntohl htons ntohs))
114
115 (defun htonl (x)
116 (maybe-byte-swap x 4))
117 (defun ntohl (x)
118 (maybe-byte-swap x 4))
119 (defun htons (x)
120 (maybe-byte-swap x 2))
121 (defun ntohs (x)
122 (maybe-byte-swap x 2))
123
124
125 ;;;; Host entry operations.
126
127 ;;; Note the IP addresses are stored in host order.
128 (defstruct host-entry
129 name
130 aliases
131 addr-type
132 addr-list)
133
134 (defun host-entry-addr (host)
135 (declare (type host-entry host))
136 (car (host-entry-addr-list host)))
137
138 #-BSD
139 (def-alien-type unix-sockaddr
140 (struct nil
141 (family #-(or linux alpha) short #+(or linux alpha) unsigned-short)
142 (path (array char 108))))
143 #|
144 struct sockaddr_un {
145 u_char sun_len; /* sockaddr len including null */
146 u_char sun_family; /* AF_UNIX */
147 char sun_path[104]; /* path name (gag) */
148 };
149 |#
150
151 #+BSD
152 (def-alien-type unix-sockaddr
153 (struct nil
154 (sun-len unsigned-char)
155 (family unsigned-char)
156 (path (array char 104))))
157 #|
158 /*
159 * Socket address, internet style.
160 */
161 struct sockaddr_in {
162 u_char sin_len;
163 u_char sin_family;
164 u_short sin_port;
165 struct in_addr sin_addr;
166 char sin_zero[8];
167 };
168 struct in_addr {
169 u_long s_addr;
170 };
171
172 |#
173 #+BSD
174 (def-alien-type inet-sockaddr
175 (struct nil
176 (sin-len unsigned-char)
177 (family unsigned-char)
178 (port unsigned-short)
179 (addr unsigned-long)
180 (zero (array char 8))))
181
182 #-BSD
183 (def-alien-type inet-sockaddr
184 (struct nil
185 (family #-alpha short #+alpha unsigned-short)
186 (port unsigned-short)
187 (addr #-alpha unsigned-long #+alpha unsigned-int)
188 (zero (array char 8))))
189
190
191 (def-alien-type hostent
192 (struct nil
193 (name c-string)
194 (aliases (* c-string))
195 (addrtype int)
196 (length int)
197 (addr-list (* (* (unsigned 32))))))
198
199 (def-alien-routine "gethostbyname" (* hostent)
200 (name c-string))
201
202 (def-alien-routine "gethostbyaddr" (* hostent)
203 (addr unsigned-long :copy)
204 (len int)
205 (type int))
206
207 (def-alien-routine ("os_get_h_errno" get-h-errno) int)
208
209 (defun lookup-host-entry (host)
210 "Return a host-entry for the given host. The host may be an address
211 string or an IP address in host order."
212 (declare (type (or host-entry string (unsigned-byte 32)) host)
213 (optimize (inhibit-warnings 3)))
214 (if (typep host 'host-entry)
215 host
216 (with-alien
217 ((hostent (* hostent)
218 (etypecase host
219 (string
220 (gethostbyname host))
221 ((unsigned-byte 32)
222 (gethostbyaddr (htonl host) 4 af-inet)))))
223 (if (zerop (sap-int (alien-sap hostent)))
224 (values nil (get-h-errno))
225 (values
226 (make-host-entry
227 :name (slot hostent 'name)
228 :aliases
229 (collect ((results))
230 (iterate repeat ((index 0))
231 (declare (type kernel:index index))
232 (cond ((or (zerop (sap-int (alien-sap (slot hostent 'aliases))))
233 (zerop (deref (cast (slot hostent 'aliases)
234 (* (unsigned #-alpha 32
235 #+alpha 64)))
236 index)))
237 (results))
238 (t
239 (results (deref (slot hostent 'aliases) index))
240 (repeat (1+ index))))))
241 :addr-type (slot hostent 'addrtype)
242 :addr-list
243 (collect ((results))
244 (iterate repeat ((index 0))
245 (declare (type kernel:index index))
246 (cond ((zerop (deref (cast (slot hostent 'addr-list)
247 (* (unsigned #-alpha 32 #+alpha 64)))
248 index))
249 (results))
250 (t
251 (results
252 (ntohl (deref (deref (slot hostent 'addr-list) index))))
253 (repeat (1+ index)))))))
254 t)))))
255
256 (defun ip-string (addr)
257 (format nil "~D.~D.~D.~D"
258 (ldb (byte 8 24) addr)
259 (ldb (byte 8 16) addr)
260 (ldb (byte 8 8) addr)
261 (ldb (byte 8 0) addr)))
262
263 (defun create-unix-socket (&optional (kind :stream))
264 (multiple-value-bind (proto type)
265 (internet-protocol kind)
266 (declare (ignore proto))
267 (let ((socket (unix:unix-socket af-unix type 0)))
268 (when (minusp socket)
269 (error 'socket-error
270 :format-control (intl:gettext "Error creating socket: ~A")
271 :format-arguments (list (unix:get-unix-error-msg))
272 :errno (unix:unix-errno)))
273 socket)))
274
275 (defun connect-to-unix-socket (path &optional (kind :stream))
276 (declare (simple-string path))
277 (let ((socket (create-unix-socket kind)))
278 (with-alien ((sockaddr unix-sockaddr))
279 (setf (slot sockaddr 'family) af-unix)
280 #-unicode
281 (kernel:copy-to-system-area path
282 (* vm:vector-data-offset vm:word-bits)
283 (alien-sap (slot sockaddr 'path))
284 0
285 (* (1+ (length path)) vm:byte-bits))
286 #+unicode
287 (let ((sap (alien-sap (slot sockaddr 'path)))
288 (len (length path)))
289 ;; FIXME: What should we do about this for unicode?
290 (dotimes (k len)
291 (setf (sap-ref-8 sap k) (logand #xff (char-code (aref path k)))))
292 (setf (sap-ref-8 sap len) 0))
293
294 (when (minusp (unix:unix-connect socket
295 (alien-sap sockaddr)
296 (alien-size unix-sockaddr :bytes)))
297 (unix:unix-close socket)
298 (error 'socket-error
299 :format-control (intl:gettext "Error connecting socket to [~A]: ~A")
300 :format-arguments (list path (unix:get-unix-error-msg))
301 :errno (unix:unix-errno)))
302 socket)))
303
304 (defun create-unix-listener (path &optional (kind :stream)
305 &key (backlog 5))
306 (declare (simple-string path))
307 (let ((socket (create-unix-socket kind)))
308 (with-alien ((sockaddr unix-sockaddr)) ;; I'm here (MSM)
309 (setf (slot sockaddr 'family) af-unix)
310 #-unicode
311 (kernel:copy-to-system-area path
312 (* vm:vector-data-offset vm:word-bits)
313 (alien-sap (slot sockaddr 'path))
314 0
315 (* (1+ (length path)) vm:byte-bits))
316 #+unicode
317 (let ((sap (alien-sap (slot sockaddr 'path)))
318 (len (length path)))
319 ;; FIXME: What should we do about this for unicode?
320 (dotimes (k len)
321 (setf (sap-ref-8 sap k) (logand #xff (char-code (aref path k)))))
322 (setf (sap-ref-8 sap len) 0))
323
324 (when (minusp (unix:unix-bind socket
325 (alien-sap sockaddr)
326 (+ (alien-size inet-sockaddr :bytes)
327 (length path))))
328 (unix:unix-close socket)
329 (error (intl:gettext "Error binding socket to path ~a: ~a")
330 path
331 (unix:get-unix-error-msg))))
332 (when (eq kind :stream)
333 (when (minusp (unix:unix-listen socket backlog))
334 (unix:unix-close socket)
335 (error (intl:gettext "Error listening to socket: ~A") (unix:get-unix-error-msg))))
336 socket))
337
338 (defun accept-unix-connection (unconnected)
339 (declare (fixnum unconnected))
340 #+MP (mp:process-wait-until-fd-usable unconnected :input)
341 (with-alien ((sockaddr unix-sockaddr))
342 (let ((connected (unix:unix-accept unconnected
343 (alien-sap sockaddr)
344 (alien-size unix-sockaddr :bytes))))
345 (when (minusp connected)
346 (error (intl:gettext "Error accepting a connection: ~A") (unix:get-unix-error-msg)))
347 (values connected (slot sockaddr 'path)))))
348
349 (defun bind-inet-socket (socket host port)
350 "bind Socket to (local) Host and Port"
351 (let ((addr (if (stringp host)
352 (host-entry-addr (or (lookup-host-entry host)
353 (error (intl:gettext "Unknown host: ~S.") host)))
354 host)))
355 (with-alien ((sockaddr inet-sockaddr))
356 (setf (slot sockaddr 'family) af-inet)
357 (setf (slot sockaddr 'port) (htons port))
358 (setf (slot sockaddr 'addr) (htonl addr))
359 (when (minusp (unix:unix-bind socket
360 (alien-sap sockaddr)
361 (alien-size inet-sockaddr :bytes)))
362 (let ((errno (unix:unix-errno)))
363 (unix:unix-close socket)
364 (error 'socket-error
365 :format-control (intl:gettext "Error binding socket to port ~A: ~A")
366 :format-arguments (list port
367 (unix:get-unix-error-msg))
368 :errno errno))))))
369
370 (defun create-inet-socket (&optional (kind :stream))
371 (multiple-value-bind (proto type)
372 (internet-protocol kind)
373 (let ((socket (unix:unix-socket af-inet type proto)))
374 (when (minusp socket)
375 (error 'socket-error
376 :format-control"Error creating socket: ~A"
377 :format-arguments (list (unix:get-unix-error-msg))
378 :errno (unix:unix-errno)))
379 socket)))
380
381 (defun connect-to-inet-socket (host port &optional (kind :stream)
382 &key local-host local-port)
383 "The host may be an address string or an IP address in host order."
384 (let* ((addr (if (stringp host)
385 (host-entry-addr (or (lookup-host-entry host)
386 (error (intl:gettext "Unknown host: ~S.") host)))
387 host))
388 (socket (create-inet-socket kind)))
389 ;; bind to local-host/local-port if given
390 (when (and local-host local-port)
391 (bind-inet-socket socket local-host local-port))
392 (with-alien ((sockaddr inet-sockaddr))
393 (setf (slot sockaddr 'family) af-inet)
394 (setf (slot sockaddr 'port) (htons port))
395 (setf (slot sockaddr 'addr) (htonl addr))
396 (when (minusp (unix:unix-connect socket
397 (alien-sap sockaddr)
398 (alien-size inet-sockaddr :bytes)))
399 ;; unix-close may affect errno; save the current value(s)
400 (let ((errno (unix:unix-errno))
401 (errmsg (unix:get-unix-error-msg)))
402 (unix:unix-close socket)
403 (error 'socket-error
404 :format-control (intl:gettext "Error connecting socket to [~A:~A]: ~A")
405 :format-arguments (list (if (stringp host)
406 host
407 (ip-string addr))
408 port
409 errmsg)
410 :errno errno)))
411 socket)))
412
413 ;; An attempt to rewrite connect-to-inet-socket in such a way that
414 ;; connection attempts that take a long time will not be stuck in the
415 ;; connect(2) system call preventing CMUCL from running other lisp
416 ;; threads.
417 ;;
418 ;; The strategy here is to put the socket in non-blocking mode, and
419 ;; then call connect, which should immediately return. Then there are
420 ;; three cases to handle:
421 ;;
422 ;; I. The connect failed immediately.
423 ;; II. The connect succeeded immediately.
424 ;; III. The connect returned without finishing.
425 ;;
426 ;; Cases I and II are simple enough, we just return the socket or
427 ;; signal an error.
428 ;;
429 ;; In case III, we call SYSTEM:WAIT-UNTIL-FD-IS-USABLE to block just
430 ;; the current thread until the socket is writeable (which signals
431 ;; that the connect has finished, one way or the other).
432 ;;
433 ;; Once WAIT-UNTIL-FD-IS-USABLE returns, we put the socket back into
434 ;; blocking mode and try to determine whether the connect succeeded or
435 ;; failed (and why it failed). We use an approach described at
436 ;; <http://cr.yp.to/docs/connect.html>, which is attributed to Douglas
437 ;; C. Schmidt and Ken Keys.
438 ;;
439 ;; First call getpeername, and if it returns 0 the connect succeeded,
440 ;; otherwise it failed. If it failed, we try to read a single
441 ;; character from the socket. We know it can't work, but it should
442 ;; cause errno set to the real reason for the failure.
443
444 (defun connect-to-inet-socket/non-blocking (host port &optional (kind :stream))
445 "The host may be an address string or an IP address in host order."
446 (let ((addr (if (stringp host)
447 (host-entry-addr (or (lookup-host-entry host)
448 (error (intl:gettext "Unknown host: ~S.") host)))
449 host))
450 (socket (create-inet-socket kind)))
451 (labels ((set-blocking (socket)
452 (unix:unix-fcntl socket unix:f-setfl
453 (logior (unix:unix-fcntl socket unix:f-getfl 0)
454 unix:fndelay)))
455 (unset-blocking (socket)
456 (unix:unix-fcntl socket unix:f-setfl
457 (logandc2 (unix:unix-fcntl socket unix:f-getfl 0)
458 unix:fndelay)))
459 (dotted-quad (ipaddr)
460 (let ((naddr (htonl ipaddr)))
461 (format nil "~D.~D.~D.~D"
462 (ldb (byte 8 0) naddr)
463 (ldb (byte 8 8) naddr)
464 (ldb (byte 8 16) naddr)
465 (ldb (byte 8 24) naddr))))
466 (connect-error (addr reason errno)
467 (error 'socket-error
468 :format-control (intl:gettext "Error connecting socket to [~A:~A]: ~A")
469 :format-arguments (list addr port reason)
470 :errno errno)))
471 (set-blocking socket)
472 (with-alien ((sockaddr inet-sockaddr)
473 (length (alien:array unsigned 1)))
474 (setf (slot sockaddr 'family) af-inet)
475 (setf (slot sockaddr 'port) (htons port))
476 (setf (slot sockaddr 'addr) (htonl addr))
477 (let ((retval (unix:unix-connect socket
478 (alien-sap sockaddr)
479 (alien-size inet-sockaddr :bytes))))
480 (cond ((< retval -1)
481 ;; connect failed
482 (let ((reason (unix:get-unix-error-msg))
483 (errno (unix:unix-errno)))
484 (unix:unix-close socket)
485 (connect-error (if (stringp host) host (dotted-quad addr))
486 reason errno)))
487 ((= retval -1)
488 ;; connect is in progress
489 (system:wait-until-fd-usable socket :output)
490 (unset-blocking socket)
491 ;; OK, it's done, check whether it worked
492 (when (minusp
493 (unix:unix-getpeername socket (alien-sap sockaddr)
494 (alien-sap length)))
495 (unix:unix-close socket)
496 ;; It didn't, so let's find out why
497 (unix:unix-read socket (alien-sap length) 1)
498 (connect-error (if (stringp host) host (dotted-quad addr))
499 (unix:get-unix-error-msg)
500 (unix:unix-errno)))
501 socket)
502 (t
503 ;; connect succeeded
504 (unset-blocking socket)
505 socket)))))))
506
507 ;;; Socket levels.
508 (defconstant sol-socket #+linux 1 #+(or solaris bsd hpux irix) #xffff)
509
510 ;;; Socket options.
511 (defconstant so-reuseaddr #+linux 2 #+(or solaris bsd hpux irix) 4)
512
513 (defun get-socket-option (socket level optname)
514 "Get an integer value socket option."
515 (declare (type unix:unix-fd socket)
516 (type (signed-byte 32) level optname))
517 (with-alien ((optval signed))
518 (if (minusp (unix:unix-getsockopt socket level optname
519 (alien-sap (addr optval)) 4))
520 (values nil (unix:unix-errno))
521 (values optval 0))))
522
523 (defun set-socket-option (socket level optname optval)
524 "Set an integer value socket option."
525 (declare (type unix:unix-fd socket)
526 (type (signed-byte 32) level optname optval))
527 (with-alien ((optval signed optval))
528 (if (minusp (unix:unix-setsockopt socket level optname
529 (alien-sap (addr optval)) 4))
530 (values nil (unix:unix-errno))
531 (values optval 0))))
532
533 (defun create-inet-listener (port &optional (kind :stream)
534 &key
535 (host 0)
536 reuse-address
537 (backlog 5)
538 )
539 (let ((socket (create-inet-socket kind))
540 (addr (if (stringp host)
541 (host-entry-addr (or (lookup-host-entry host)
542 (error 'socket-error
543 :format-control (intl:gettext "Unknown host: ~S.")
544 :format-arguments (list host)
545 :errno (unix:unix-errno))))
546 host)))
547 (when reuse-address
548 (multiple-value-bind (optval errno)
549 (set-socket-option socket sol-socket so-reuseaddr 1)
550 (or optval (error 'socket-error
551 :format-control (intl:gettext "Error ~S setting socket option on socket ~D.")
552 :format-arguments (list (unix:get-unix-error-msg errno)
553 socket)
554 :errno errno))))
555 (with-alien ((sockaddr inet-sockaddr))
556 (setf (slot sockaddr 'family) af-inet)
557 (setf (slot sockaddr 'port) (htons port))
558 (setf (slot sockaddr 'addr) (htonl addr))
559 (when (minusp (unix:unix-bind socket
560 (alien-sap sockaddr)
561 (alien-size inet-sockaddr :bytes)))
562 (let ((errno (unix:unix-errno)))
563 (unix:unix-close socket)
564 (error 'socket-error
565 :format-control (intl:gettext "Error binding socket to port ~A: ~A")
566 :format-arguments (list port
567 (unix:get-unix-error-msg))
568 :errno errno))))
569 (when (eq kind :stream)
570 (when (minusp (unix:unix-listen socket backlog))
571 (let ((errno (unix:unix-errno)))
572 (unix:unix-close socket)
573 (error 'socket-error
574 :format-control (intl:gettext "Error listening to socket: ~A")
575 :format-arguments (list (unix:get-unix-error-msg))
576 :errno errno))))
577 socket))
578
579 (defun accept-tcp-connection (unconnected)
580 (declare (fixnum unconnected))
581 #+MP (mp:process-wait-until-fd-usable unconnected :input)
582 (with-alien ((sockaddr inet-sockaddr))
583 (let ((connected (unix:unix-accept unconnected
584 (alien-sap sockaddr)
585 (alien-size inet-sockaddr :bytes))))
586 (let ((errno (unix:unix-errno)))
587 (when (minusp connected)
588 (error 'socket-error
589 :format-control (intl:gettext "Error accepting a connection: ~A")
590 :format-arguments (list (unix:get-unix-error-msg))
591 :errno errno))
592 (values connected (ntohl (slot sockaddr 'addr)))))))
593
594 (defun close-socket (socket)
595 (multiple-value-bind (ok err)
596 (unix:unix-close socket)
597 (unless ok
598 (error 'socket-error
599 :format-control (intl:gettext "Error closing socket: ~A")
600 :format-arguments (list (unix:get-unix-error-msg err))
601 :errno (unix:unix-errno))))
602 (undefined-value))
603
604 (defun get-peer-host-and-port (fd)
605 "Return the peer host address and port in host order."
606 (with-alien ((sockaddr inet-sockaddr)
607 (length (alien:array unsigned 1)))
608 (setf (deref length 0) (alien-size inet-sockaddr :bytes))
609 (when (minusp (unix:unix-getpeername fd (alien-sap sockaddr)
610 (alien-sap length)))
611 (error (intl:gettext "Error ~s getting peer host and port on FD ~d.")
612 (unix:get-unix-error-msg (unix:unix-errno)) fd))
613 (values (ext:ntohl (slot sockaddr 'addr))
614 (ext:ntohs (slot sockaddr 'port)))))
615
616 (defun get-socket-host-and-port (fd)
617 (with-alien ((sockaddr inet-sockaddr)
618 (length (alien:array unsigned 1)))
619 (setf (deref length 0) (alien-size inet-sockaddr :bytes))
620 (when (minusp (unix:unix-getsockname fd (alien-sap sockaddr)
621 (alien-sap length)))
622 (error (intl:gettext "Error ~s getting socket host and port on FD ~d.")
623 (unix:get-unix-error-msg (unix:unix-errno)) fd))
624 (values (ext:ntohl (slot sockaddr 'addr))
625 (ext:ntohs (slot sockaddr 'port)))))
626
627
628 ;;;; Out of Band Data.
629
630 ;;; Two level AList. First levels key is the file descriptor, second levels
631 ;;; key is the character. The datum is the handler to call.
632
633 (defvar *oob-handlers* nil)
634
635 ;;; SIGURG-HANDLER -- internal
636 ;;;
637 ;;; Routine that gets called whenever out-of-band data shows up. Checks each
638 ;;; file descriptor for any oob data. If there is any, look for a handler for
639 ;;; that character. If any are found, funcall them.
640
641 (defun sigurg-handler (signo code scp)
642 (declare (ignore signo code scp))
643 (let ((buffer (make-string 1))
644 (handled nil))
645 (declare (simple-string buffer))
646 (dolist (handlers *oob-handlers*)
647 (declare (list handlers))
648 (cond ((minusp (unix:unix-recv (car handlers) buffer 1 msg-oob))
649 (cerror (intl:gettext "Ignore it")
650 (intl:gettext "Error recving oob data on ~A: ~A")
651 (car handlers)
652 (unix:get-unix-error-msg)))
653 (t
654 (setf handled t)
655 (let ((char (schar buffer 0))
656 (handled nil))
657 (declare (base-char char))
658 (dolist (handler (cdr handlers))
659 (declare (list handler))
660 (when (eql (car handler) char)
661 (funcall (cdr handler))
662 (setf handled t)))
663 (unless handled
664 (cerror (intl:gettext "Ignore it")
665 (intl:gettext "No oob handler defined for ~S on ~A")
666 char
667 (car handlers)))))))
668 (unless handled
669 (cerror (intl:gettext "Ignore it")
670 (intl:gettext "Got a SIGURG, but couldn't find any out-of-band data."))))
671 (undefined-value))
672
673 ;;; ADD-OOB-HANDLER -- public
674 ;;;
675 ;;; First, check to see if we already have any handlers for this file
676 ;;; descriptor. If so, just add this handler to them. If not, add this
677 ;;; file descriptor to *OOB-HANDLERS*, make sure our interrupt handler is
678 ;;; installed, and that the given file descriptor is "owned" by us (so sigurg
679 ;;; will be delivered.)
680
681 (defun add-oob-handler (fd char handler)
682 "Arrange to funcall HANDLER when CHAR shows up out-of-band on FD."
683 (declare (integer fd)
684 (base-char char))
685 (let ((handlers (assoc fd *oob-handlers*)))
686 (declare (list handlers))
687 (cond (handlers
688 (push (cons char handler)
689 (cdr handlers)))
690 (t
691 (push (list fd
692 (cons char
693 handler))
694 *oob-handlers*)
695 (system:enable-interrupt unix:sigurg #'sigurg-handler)
696 #-hpux
697 (unix:unix-fcntl fd unix:f-setown (unix:unix-getpid))
698 #+hpux
699 (unix:siocspgrp fd (unix:unix-getpid)))))
700 (values))
701
702 ;;; REMOVE-OOB-HANDLER -- public
703 ;;;
704 ;;; Delete any handlers for the given char from the list of handlers for the
705 ;;; given file descriptor. If there are no more, nuke the entry for the file
706 ;;; descriptor.
707
708 (defun remove-oob-handler (fd char)
709 "Remove any handlers for CHAR on FD."
710 (declare (integer fd)
711 (base-char char))
712 (let ((handlers (assoc fd *oob-handlers*)))
713 (declare (list handlers))
714 (when handlers
715 (let ((remaining (delete char (cdr handlers)
716 :test #'eql
717 :key #'car)))
718 (declare (list remaining))
719 (if remaining
720 (setf (cdr handlers) remaining)
721 (setf *oob-handlers*
722 (delete fd *oob-handlers*
723 :test #'eql
724 :key #'car))))))
725 (values))
726
727 ;;; REMOVE-ALL-OOB-HANDLERS -- public
728 ;;;
729 ;;; Delete the entry for the given file descriptor.
730
731 (defun remove-all-oob-handlers (fd)
732 "Remove all handlers for FD."
733 (declare (integer fd))
734 (setf *oob-handlers*
735 (delete fd *oob-handlers*
736 :test #'eql
737 :key #'car))
738 (values))
739
740 ;;; SEND-CHARACTER-OUT-OF-BAND -- public
741 ;;;
742 ;;; Sends CHAR across FD out of band.
743
744 (defun send-character-out-of-band (fd char)
745 (declare (integer fd)
746 (base-char char))
747 (let ((buffer (make-string 1 :initial-element char)))
748 (declare (simple-string buffer))
749 (when (minusp (unix:unix-send fd buffer 1 msg-oob))
750 (error (intl:gettext "Error sending ~S OOB to across ~A: ~A")
751 char
752 fd
753 (unix:get-unix-error-msg)))))
754
755 (defun inet-recvfrom (fd buffer size &key (flags 0))
756 "A packaging of the unix recvfrom call. Returns three values:
757 bytecount, source address as integer, and source port. bytecount
758 can of course be negative, to indicate faults."
759 #+mp (mp:process-wait-until-fd-usable fd :input)
760 (with-alien ((sockaddr inet-sockaddr))
761 (let* ((bytecount (unix:unix-recvfrom fd buffer size flags
762 (alien-sap sockaddr)
763 (alien-size inet-sockaddr :bytes))))
764 (values bytecount (ntohl (slot sockaddr 'addr)) (ntohs (slot sockaddr 'port))))))
765
766 (defun inet-sendto (fd buffer size addr port &key (flags 0))
767 "A packaging of the unix sendto call. Return value like sendto"
768 (with-alien ((sockaddr inet-sockaddr))
769 (setf (slot sockaddr 'family) af-inet)
770 (setf (slot sockaddr 'port) (htons port))
771 (setf (slot sockaddr 'addr) (htonl addr))
772 (unix:unix-sendto fd
773 buffer
774 size
775 flags
776 (alien-sap sockaddr)
777 (alien-size inet-sockaddr :bytes))))
778
779 (defconstant shut-rd 0)
780 (defconstant shut-wr 1)
781 (defconstant shut-rdwr 2)
782
783 (defun inet-shutdown (fd level)
784 "A packaging of the unix shutdown call. An error is signaled if shutdown fails."
785 (when (minusp (unix:unix-shutdown fd level))
786 (error 'socket-error
787 :format-control (intl:gettext "Error on shutdown of socket: ~A")
788 :format-arguments (list (unix:get-unix-error-msg))
789 :errno (unix:unix-errno))))
790
791
792 ;;; OPEN-NETWORK-STREAM -- public
793 ;;;
794 ;;; Returns a stream connected to the specified Port on the given Host.
795 (defun open-network-stream (host port &key (buffering :line) timeout
796 (external-format '(:latin-1 :crlf)))
797 "Return a network stream. HOST may be an address string or an integer
798 IP address."
799 (let (hostent hostaddr)
800 (cond ((stringp host)
801 (setf hostent (or (lookup-host-entry host)
802 (error (intl:gettext "Unknown host: ~S.") host)))
803 (setf host (host-entry-addr hostent))
804 (setf hostaddr (format nil "~A:~D"
805 (host-entry-name hostent)
806 port)))
807 ((integerp host)
808 (setf hostaddr (format nil "~D.~D.~D.~D:~D"
809 (ldb (byte 8 24) host)
810 (ldb (byte 8 16) host)
811 (ldb (byte 8 8) host)
812 (ldb (byte 8 0) host)
813 port)))
814 (t (error (intl:gettext "Unknown host format: ~S.") host)))
815 (sys:make-fd-stream
816 (let ((socket (create-inet-socket :stream)))
817 (alien:with-alien ((sockaddr inet-sockaddr))
818 (setf (alien:slot sockaddr 'family) af-inet)
819 (setf (alien:slot sockaddr 'sys:port) (htons port))
820 (setf (alien:slot sockaddr 'alien:addr) (htonl host))
821 (when (minusp (unix:unix-connect socket
822 (alien:alien-sap sockaddr)
823 (alien:alien-size inet-sockaddr
824 :bytes)))
825 (unix:unix-close socket)
826 (error (intl:gettext "Error connecting socket to [~A]: ~A")
827 hostaddr
828 (unix:get-unix-error-msg)))
829 socket))
830 :input t :output t :buffering buffering :timeout timeout
831 :name (format nil (intl:gettext "network connection to ~A") hostaddr)
832 :external-format external-format
833 :auto-close t)))
834
835 ;;; ACCEPT-NETWORK-STREAM -- public
836 ;;;
837 ;;; Accept a connection from the specified Socket and returns a
838 ;;; stream connected to that connection.
839 (defun accept-network-stream (socket &key (buffering :line) timeout wait-max
840 (external-format '(:latin-1 :crlf)))
841 (declare (fixnum socket))
842 (when #+MP (mp:process-wait-until-fd-usable socket :input wait-max)
843 #-MP (sys:wait-until-fd-usable socket :input wait-max)
844 (with-alien ((sockaddr inet-sockaddr))
845 (let ((socket (unix:unix-accept socket
846 (alien-sap sockaddr)
847 (alien-size inet-sockaddr :bytes))))
848 (when (minusp socket)
849 (error (intl:gettext "Error accepting a connection: ~A") (unix:get-unix-error-msg)))
850 (sys:make-fd-stream
851 socket :input t :output t :buffering buffering :timeout timeout
852 :name (let ((host (ntohl (slot sockaddr 'addr)))
853 (port (ntohs (slot sockaddr 'port))))
854 (format nil (intl:gettext "network connection from ~D.~D.~D.~D:~D")
855 (ldb (byte 8 24) host)
856 (ldb (byte 8 16) host)
857 (ldb (byte 8 8) host)
858 (ldb (byte 8 0) host)
859 port))
860 :external-format external-format
861 :auto-close t)))))

  ViewVC Help
Powered by ViewVC 1.1.5