source: trunk/source/level-1/l1-sockets.lisp @ 13773

Last change on this file since 13773 was 13773, checked in by rme, 10 years ago

Now that we have this Unicode thing, it doesn't really work for UDP
sockets to support any format other than :binary.

VERIFY-SOCKET-BUFFER: change misleading error message.

Specialize SOCKET-FORMAT for udp-sockets so that it always returns
:binary.

RECEIVE-FROM: :binary is the only acceptable socket-format.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2001-2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19
20
21;;; basic socket API
22(eval-when (:compile-toplevel :load-toplevel :execute)
23  (export '(MAKE-SOCKET
24            ACCEPT-CONNECTION
25            DOTTED-TO-IPADDR
26            IPADDR-TO-DOTTED
27            IPADDR-TO-HOSTNAME
28            LOOKUP-HOSTNAME
29            LOOKUP-PORT
30            ;;with-pending-connect
31            RECEIVE-FROM
32            SEND-TO
33            SHUTDOWN
34            ;;socket-control
35            SOCKET-OS-FD
36            REMOTE-HOST
37            REMOTE-PORT
38            REMOTE-FILENAME
39            LOCAL-HOST
40            LOCAL-PORT
41            LOCAL-FILENAME
42            SOCKET-ADDRESS-FAMILY
43            SOCKET-CONNECT
44            SOCKET-FORMAT
45            SOCKET-TYPE
46            SOCKET-ERROR
47            SOCKET-ERROR-CODE
48            SOCKET-ERROR-IDENTIFIER
49            SOCKET-ERROR-SITUATION
50            SOCKET-CREATION-ERROR
51            SOCKET-CREATION-ERROR-CODE
52            SOCKET-CREATION-ERROR-IDENTIFIER
53            SOCKET-CREATION-ERROR-SITUATION
54            WITH-OPEN-SOCKET))
55  #+windows-target
56  (defmacro check-winsock-error (form)
57    (let* ((val (gensym)))
58      `(let* ((,val ,form))
59        (if (< ,val 0)
60          (%get-winsock-error)
61          ,val))))
62  (defmacro check-socket-error (form)
63    #+windows-target `(check-winsock-error ,form)
64    #-windows-target `(int-errno-call ,form))
65  )
66
67
68#+windows-target
69(defun %get-winsock-error ()
70  (- (#_WSAGetLastError)))
71
72;;; The PPC is big-endian (uses network byte order), which makes
73;;; things like #_htonl and #_htonl no-ops.  These functions aren't
74;;; necessarily defined as functions in some header files (I'm sure
75;;; that that either complies with or violates some C standard), and
76;;; it doesn't seem to make much sense to fight that to do ff-calls
77;;; to a couple of identity functions.
78
79#+big-endian-target
80(progn
81  (defmacro HTONL (x) x)
82  (defmacro HTONS (x) x)
83  (defmacro NTOHL (x) x)
84  (defmacro NTOHS (x) x))
85
86#+little-endian-target
87(progn
88  (declaim (inline %bswap32 %bswap16))
89  (defun %bswap32 (x)
90    (declare (type (unsigned-byte 32) x))
91    (%swap-u32 x))
92  (defun %bswap16 (x)
93    (declare (type (unsigned-byte 16) x))
94    (%swap-u16 x))
95  (defmacro HTONL (x) `(%bswap32 ,x))
96  (defmacro HTONS (x) `(%bswap16 ,x))
97  (defmacro NTOHL (x) `(%bswap32 ,x))
98  (defmacro NTOHS (x) `(%bswap16 ,x)))
99
100(defparameter *default-socket-character-encoding*
101  nil)
102
103(defmethod default-character-encoding ((domain (eql :socket)))
104  *default-socket-character-encoding*)
105 
106
107;;; On some (hypothetical) little-endian platform, we might want to
108;;; define HTONL and HTONS to actually swap bytes around.
109
110(defpackage "OPENMCL-SOCKET"
111  (:use "CL")
112  (:import-from "CCL"
113                "MAKE-SOCKET"
114                "ACCEPT-CONNECTION"
115                "DOTTED-TO-IPADDR"
116                "IPADDR-TO-DOTTED"
117                "IPADDR-TO-HOSTNAME"
118                "LOOKUP-HOSTNAME"
119                "LOOKUP-PORT"
120                ;;with-pending-connect
121                "RECEIVE-FROM"
122                "SEND-TO"
123                "SHUTDOWN"
124                ;;socket-control
125                "SOCKET-OS-FD"
126                "REMOTE-HOST"
127                "REMOTE-PORT"
128                "REMOTE-FILENAME"
129                "LOCAL-HOST"
130                "LOCAL-PORT"
131                "LOCAL-FILENAME"
132                "SOCKET-ADDRESS-FAMILY"
133                "SOCKET-CONNECT"
134                "SOCKET-FORMAT"
135                "SOCKET-TYPE"
136                "SOCKET-ERROR"
137                "SOCKET-ERROR-CODE"
138                "SOCKET-ERROR-IDENTIFIER"
139                "SOCKET-ERROR-SITUATION"
140                "SOCKET-CREATION-ERROR"
141                "SOCKET-CREATION-ERROR-CODE"
142                "SOCKET-CREATION-ERROR-IDENTIFIER"
143                "SOCKET-CREATION-ERROR-SITUATION"
144                "WITH-OPEN-SOCKET")
145  (:export  "MAKE-SOCKET"
146            "ACCEPT-CONNECTION"
147            "DOTTED-TO-IPADDR"
148            "IPADDR-TO-DOTTED"
149            "IPADDR-TO-HOSTNAME"
150            "LOOKUP-HOSTNAME"
151            "LOOKUP-PORT"
152            ;;with-pending-connect
153            "RECEIVE-FROM"
154            "SEND-TO"
155            "SHUTDOWN"
156            ;;socket-control
157            "SOCKET-OS-FD"
158            "REMOTE-HOST"
159            "REMOTE-PORT"
160            "REMOTE-FILENAME"
161            "LOCAL-HOST"
162            "LOCAL-PORT"
163            "LOCAL-FILENAME"
164            "SOCKET-ADDRESS-FAMILY"
165            "SOCKET-CONNECT"
166            "SOCKET-FORMAT"
167            "SOCKET-TYPE"
168            "SOCKET-ERROR"
169            "SOCKET-ERROR-CODE"
170            "SOCKET-ERROR-IDENTIFIER"
171            "SOCKET-ERROR-SITUATION"
172            "SOCKET-CREATION-ERROR"
173            "SOCKET-CREATION-ERROR-CODE"
174            "SOCKET-CREATION-ERROR-IDENTIFIER"
175            "SOCKET-CREATION-ERROR-SITUATION"
176            "WITH-OPEN-SOCKET"))
177
178(define-condition socket-error (simple-stream-error)
179  ((code :initarg :code :reader socket-error-code)
180   (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier)
181   (situation :initarg :situation :reader socket-error-situation)))
182
183(define-condition socket-creation-error (simple-error)
184  ((code :initarg :code :reader socket-creation-error-code)
185   (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
186   (situation :initarg :situation :reader socket-creation-error-situation)))
187
188(defparameter *gai-error-identifiers*
189  (list #$EAI_AGAIN :try-again
190        #$EAI_FAIL :no-recovery
191        #$EAI_NONAME :host-not-found))
192
193(defvar *socket-error-identifiers*
194  #-windows-target
195  (list #$EADDRINUSE :address-in-use
196        #$ECONNABORTED :connection-aborted
197        #$ENOBUFS :no-buffer-space
198        #$ENOMEM :no-buffer-space
199        #$ENFILE :no-buffer-space
200        #$ETIMEDOUT :connection-timed-out
201        #$ECONNREFUSED :connection-refused
202        #$ENETUNREACH :host-unreachable
203        #$EHOSTUNREACH :host-unreachable
204        #$EHOSTDOWN :host-down
205        #$ENETDOWN :network-down
206        #$EADDRNOTAVAIL :address-not-available
207        #$ENETRESET :network-reset
208        #$ECONNRESET :connection-reset
209        #$ESHUTDOWN :shutdown
210        #$EACCES :access-denied
211        #$EPERM :access-denied)
212  #+windows-target
213  (list #$WSAEADDRINUSE :address-in-use
214        #$WSAECONNABORTED :connection-aborted
215        #$WSAENOBUFS :no-buffer-space
216        #$ENOMEM :no-buffer-space
217        #$ENFILE :no-buffer-space
218        #$WSAETIMEDOUT :connection-timed-out
219        #$WSAECONNREFUSED :connection-refused
220        #$WSAENETUNREACH :host-unreachable
221        #$WSAEHOSTUNREACH :host-unreachable
222        #$WSAEHOSTDOWN :host-down
223        #$WSAENETDOWN :network-down
224        #$WSAEADDRNOTAVAIL :address-not-available
225        #$WSAENETRESET :network-reset
226        #$WSAECONNRESET :connection-reset
227        #$WSAESHUTDOWN :shutdown
228        #$EACCES :access-denied
229        #$EPERM :access-denied)
230  )
231
232
233(declaim (inline socket-call))
234(defun socket-call (stream where res)
235  (if (< res 0)
236    (socket-error stream where res)
237    res))
238
239#-windows-target
240(defun %gai-strerror (err)
241  (let ((p (#_gai_strerror err)))
242    (if (%null-ptr-p p)
243      (format nil "Unknown nameserver error ~d" err)
244      (%get-cstring p))))
245
246(defun socket-error (stream where errno &optional nameserver-p)
247  "Creates and signals (via error) one of two socket error
248conditions, based on the state of the arguments."
249  (unless nameserver-p
250    (setq errno (abs errno)))
251  (if stream
252    (error (make-condition 'socket-error
253                           :stream stream
254                           :code errno
255                           :identifier (getf *socket-error-identifiers* errno :unknown)
256                           :situation where
257                           :format-control "~a (error #~d) during ~a"
258                           :format-arguments (list
259                                              #+windows-target
260                                              (%windows-error-string errno)
261                                              #-windows-target
262                                              (%strerror errno)
263                                              errno where)))
264    (let ((identifiers (if nameserver-p
265                         *gai-error-identifiers*
266                         *socket-error-identifiers*)))
267      (error (make-condition 'socket-creation-error
268                             :code errno
269                             :identifier (getf identifiers errno :unknown)
270                             :situation where
271                             :format-control "~a (error #~d) during socket creation or nameserver operation in ~a"
272                             :format-arguments (list
273                                                #+windows-target
274                                                (%windows-error-string errno)
275                                                #-windows-target
276                                                (if nameserver-p
277                                                  (%gai-strerror errno)
278                                                  (%strerror errno))
279                                                errno where))))))
280
281;; If true, this will try to allow other cooperative processes to run
282;; while socket io is happening.  Since CCL threads are preemptively
283;; scheduled, this isn't particularly meaningful.
284(defvar *multiprocessing-socket-io* nil)
285
286(defclass socket ()
287  ())
288
289(defmacro with-open-socket ((var . args) &body body
290                            &aux (socket (make-symbol "socket"))
291                                 (done (make-symbol "done")))
292  "Execute body with var bound to the result of applying make-socket to
293make-socket-args. The socket gets closed on exit."
294  `(let (,socket ,done)
295     (unwind-protect
296         (multiple-value-prog1
297           (let ((,var (setq ,socket (make-socket ,@args))))
298             ,@body)
299           (setq ,done t))
300       (when ,socket (close ,socket :abort (not ,done))))))
301
302(defgeneric socket-address-family (socket)
303  (:documentation "Return :internet or :file, as appropriate."))
304
305(defclass ip-socket (socket)
306  ())
307
308(defmethod socket-address-family ((socket ip-socket)) :internet)
309
310(defclass file-socket (socket)
311  ())
312
313(defmethod socket-address-family ((socket file-socket)) :file)
314
315(defclass tcp-socket (ip-socket)
316  ())
317
318(defgeneric socket-type (socket)
319  (:documentation
320   "Return :stream for tcp-stream and listener-socket, and :datagram
321for udp-socket."))
322
323(defmethod socket-type ((socket tcp-socket)) :stream)
324
325(defclass stream-file-socket (file-socket)
326  ())
327
328(defmethod socket-type ((socket stream-file-socket)) :stream)
329
330
331;;; An active TCP socket is an honest-to-goodness stream.
332(defclass tcp-stream (tcp-socket)
333  ())
334
335(defclass fundamental-tcp-stream (tcp-stream
336                                  fd-stream
337                                  buffered-binary-io-stream-mixin
338                                  buffered-character-io-stream-mixin)
339    ())
340
341(make-built-in-class 'basic-tcp-stream
342                     'tcp-stream
343                     'basic-binary-io-stream
344                     'basic-character-io-stream)
345
346(defgeneric socket-connect (stream)
347 (:documentation
348   "Return :active for tcp-stream, :passive for listener-socket, and NIL
349for udp-socket"))
350
351(defmethod socket-connect ((stream tcp-stream)) :active)
352
353(defgeneric socket-format (stream)
354  (:documentation
355   "Return the socket format as specified by the :format argument to
356make-socket."))
357
358(defmethod socket-format ((stream tcp-stream))
359  (if (eq (stream-element-type stream) 'character)
360    :text
361    ;; Should distinguish between :binary and :bivalent, but hardly
362    ;; seems worth carrying around an extra slot just for that.
363    :bivalent))
364
365(defmethod socket-device ((stream tcp-stream))
366  (let ((ioblock (stream-ioblock stream nil)))
367    (and ioblock (ioblock-device ioblock))))
368
369(defmethod select-stream-class ((class tcp-stream) in-p out-p char-p)
370  (declare (ignore char-p)) ; TODO: is there any real reason to care about this?
371  ;; Yes, in general.  There is.
372  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
373  'fundamental-tcp-stream)
374
375(defmethod map-to-basic-stream-class-name ((name (eql 'tcp-stream)))
376  'basic-tcp-stream)
377
378(defmethod select-stream-class ((s (eql 'basic-tcp-stream)) in-p out-p char-p)
379  (declare (ignore char-p))
380  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
381  'basic-tcp-stream)
382
383;;; A FILE-SOCKET-STREAM is also honest. To goodness.
384(defclass file-socket-stream (stream-file-socket)
385  ())
386
387(defclass fundamental-file-socket-stream (file-socket-stream
388                                          fd-stream
389                                          buffered-binary-io-stream-mixin
390                                          buffered-character-io-stream-mixin)
391    ())
392
393(make-built-in-class 'basic-file-socket-stream
394                     'file-socket-stream
395                     'basic-binary-io-stream
396                     'basic-character-io-stream)
397
398
399(defmethod map-to-basic-stream-class-name ((name (eql 'file-socket-stream)))
400  'basic-file-socket-stream)
401
402(defmethod select-stream-class ((class file-socket-stream) in-p out-p char-p)
403  (declare (ignore char-p)) ; TODO: is there any real reason to care about this?
404  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
405  'fundamental-file-socket-stream)
406
407(defmethod select-stream-class ((s (eql 'basic-file-socket-stream)) in-p out-p char-p)
408  (declare (ignore char-p))
409  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
410  'basic-file-socket-stream)
411
412(defclass unconnected-socket (socket)
413  ((device :initarg :device :accessor socket-device)
414   (keys :initarg :keys :reader socket-keys)))
415
416(defmethod socket-format ((socket unconnected-socket))
417  (or (getf (socket-keys socket) :format) :text))
418
419(defgeneric close (socket &key abort)
420  (:documentation
421   "The close generic function can be applied to sockets. It releases the
422operating system resources associated with the socket."))
423
424(defmethod close ((socket unconnected-socket) &key abort)
425  (declare (ignore abort))
426  (when (socket-device socket)
427    (fd-close (socket-device socket))
428    (setf (socket-device socket) nil)
429    t))
430
431;; A passive tcp socket just generates connection streams
432(defclass listener-socket (tcp-socket unconnected-socket) ())
433
434(defmethod SOCKET-CONNECT ((stream listener-socket)) :passive)
435
436(defclass file-listener-socket (stream-file-socket unconnected-socket) ())
437
438(defmethod SOCKET-CONNECT ((stream file-listener-socket)) :passive)
439
440;;; A FILE-LISTENER-SOCKET should try to delete the filesystem
441;;; entity when closing.
442
443#-windows-target
444(defmethod close :before ((s file-listener-socket) &key abort)
445  (declare (ignore abort))
446  (let* ((path (local-socket-filename (socket-device s) s)))
447    (when path (%delete-file path))))
448
449
450;; A udp socket just sends and receives packets.
451(defclass udp-socket (ip-socket unconnected-socket) ())
452
453(defmethod socket-type ((stream udp-socket)) :datagram)
454(defmethod socket-connect ((stream udp-socket)) nil)
455(defmethod socket-format ((stream udp-socket)) :binary)
456
457(defgeneric socket-os-fd (socket)
458  (:documentation
459   "Return the native OS's representation of the socket, or NIL if the
460socket is closed. On Unix, this is the Unix 'file descriptor', a small
461non-negative integer. Note that it is rather dangerous to mess around
462with tcp-stream fd's, as there is all sorts of buffering and asynchronous
463I/O going on above the OS level. listener-socket and udp-socket fd's are
464safer to mess with directly as there is less magic going on."))
465
466;; Returns nil for closed stream...
467(defmethod socket-os-fd ((socket socket))
468  (socket-device socket))
469
470;; Returns nil for closed stream
471(defun local-socket-info (fd type socket)
472  (and fd
473       (rlet ((sockaddr :sockaddr_in)
474              (namelen :signed))
475             (setf (pref namelen :signed) (record-length :sockaddr_in))
476             (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen))
477             (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
478               (ecase type
479                 (:host (ntohl (pref sockaddr
480                                     #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
481                                     #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)))
482                 (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))
483
484#-windows-target
485(defun path-from-unix-address (addr)
486  (when (= #$AF_UNIX (pref addr :sockaddr_un.sun_family))
487    #+darwin-target
488    (%str-from-ptr (pref addr :sockaddr_un.sun_path)
489                   (- (pref addr :sockaddr_un.sun_len) 2))
490    #-darwin-target
491    (%get-cstring (pref addr :sockaddr_un.sun_path))))
492
493#-windows-target
494(defun local-socket-filename (fd socket)
495  (and fd
496       (rlet ((addr :sockaddr_un)
497              (namelen :signed))
498         (setf (pref namelen :signed) (record-length :sockaddr_un))
499         (socket-call socket "getsockname" (c_getsockname fd addr namelen))
500         (path-from-unix-address addr))))
501
502(defmacro with-if ((var expr) &body body)
503  `(let ((,var ,expr))
504     (if ,var
505         (progn
506           ,@body))))     
507
508(defun remote-socket-info (socket type)
509  (with-if (fd (socket-device socket))
510    (rlet ((sockaddr :sockaddr_in)
511           (namelen :signed))
512          (setf (pref namelen :signed) (record-length :sockaddr_in))
513          (let ((err (c_getpeername fd sockaddr namelen)))
514            (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil)
515                  ((< err 0) (socket-error socket "getpeername" err))
516                  (t
517                   (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
518                     (ecase type
519                       (:host (ntohl (pref sockaddr
520                                           #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
521                                           #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr)))
522                       (:port (ntohs  (pref sockaddr :sockaddr_in.sin_port)))))))))))
523
524#-windows-target
525(defun remote-socket-filename (socket)
526  (with-if (fd (socket-device socket))
527    (rlet ((addr :sockaddr_un)
528           (namelen :signed))
529          (setf (pref namelen :signed) (record-length :sockaddr_un))
530          (let* ((err (c_getsockname fd addr namelen)))
531            (cond ((eql err (- #$ENOTCONN)) nil)
532                  ((< err 0) (socket-error socket "getpeername" err))
533                  (t (path-from-unix-address addr)))))))
534
535(defgeneric local-port (socket)
536  (:documentation "Return the local port number."))
537
538(defmethod local-port ((socket socket))
539  (local-socket-info (socket-device socket) :port socket))
540
541(defgeneric local-host (socket)
542  (:documentation
543   "Return 32-bit unsigned IP address of the local host."))
544
545(defmethod local-host ((socket socket))
546  (local-socket-info (socket-device socket) :host socket))
547
548#-windows-target
549(defmethod local-filename ((socket socket))
550  (local-socket-filename (socket-device socket) socket))
551
552(defgeneric remote-host (socket)
553  (:documentation
554   "Return the 32-bit unsigned IP address of the remote host, or NIL if
555the socket is not connected."))
556
557;; Returns NIL if socket is not connected
558(defmethod remote-host ((socket socket))
559  (remote-socket-info socket :host))
560
561(defgeneric remote-port (socket)
562  (:documentation
563   "Return the remote port number, or NIL if the socket is not connected."))
564
565(defmethod remote-port ((socket socket))
566  (remote-socket-info socket :port))
567
568#-windows-target
569(defmethod remote-filename ((socket socket))
570  (remote-socket-filename socket))
571 
572(defun set-socket-fd-blocking (fd block-flag)
573  #+windows-target
574  (rlet ((argp :u_long (if block-flag 0 1)))
575    (#_ioctlsocket fd #$FIONBIO argp))
576  #-windows-target
577  (if block-flag
578    (fd-clear-flag fd #$O_NONBLOCK)
579    (fd-set-flag fd #$O_NONBLOCK)))
580
581(defun get-socket-fd-blocking (fd)
582  "returns T iff socket is in blocking mode"
583  #+windows-target (declare (ignore fd))
584  #+windows-target t
585  #-windows-target
586  (not (logtest #$O_NONBLOCK (fd-get-flags fd))))
587
588(defun set-socket-options (fd-or-socket &key 
589                           keepalive
590                           reuse-address
591                           nodelay
592                           broadcast
593                           linger
594                           address-family
595                           local-port
596                           local-host
597                           local-filename
598                           type
599                           connect
600                           out-of-band-inline
601                           &allow-other-keys)
602  ;; see man socket(7) tcp(7) ip(7)
603  (multiple-value-bind (socket fd) (etypecase fd-or-socket
604                                     (socket (values fd-or-socket (socket-device fd-or-socket)))
605                                     (integer (values nil fd-or-socket)))
606   
607    (if (null address-family)
608        (setq address-family :internet))
609    (when keepalive
610      (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1))
611    (when reuse-address
612      (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1))
613    (when broadcast
614      (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1))
615    (when out-of-band-inline
616      (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1))
617    (when (eq address-family :internet)
618      (when (eq type :stream)
619        (rlet ((plinger :linger))
620          (setf (pref plinger :linger.l_onoff) (if linger 1 0)
621                (pref plinger :linger.l_linger) (or linger 0))
622          (socket-call socket "setsockopt"
623                       (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER
624                                     plinger (record-length :linger)))))
625      (when nodelay
626        (int-setsockopt fd
627                        #+linux-target #$SOL_TCP
628                        #-linux-target #$IPPROTO_TCP
629                        #$TCP_NODELAY 1))
630      (when (or local-port local-host)
631        (let* ((proto (if (eq type :stream) "tcp" "udp"))
632               (port-n (if local-port (port-as-inet-port local-port proto) 0))
633               (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY)))
634          ;; Darwin includes the SIN_ZERO field of the sockaddr_in when
635          ;; comparing the requested address to the addresses of configured
636          ;; interfaces (as if the zeros were somehow part of either address.)
637          ;; "rletz" zeros out the stack-allocated structure, so those zeros
638          ;; will be 0.
639          (rletz ((sockaddr :sockaddr_in))
640                 (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
641                       (pref sockaddr :sockaddr_in.sin_port) port-n
642                       (pref sockaddr
643                             #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
644                             #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr
645                             ) host-n)
646                 (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in)))))))
647    (when (and (eq address-family :file)
648               (eq connect :passive)
649               local-filename)
650      #+windows-target (error "can't create file socket on Windows")
651      #-windows-target (bind-unix-socket fd local-filename))))
652
653;; I hope the inline declaration makes the &rest/apply's go away...
654(declaim (inline make-ip-socket))
655(defun make-ip-socket (&rest keys &key type &allow-other-keys)
656  (declare (dynamic-extent keys))
657  (ecase type
658    ((nil :stream) (apply #'make-tcp-socket keys))
659    ((:datagram) (apply #'make-udp-socket keys))))
660
661(declaim (inline make-file-socket))
662(defun make-file-socket (&rest keys &key type &allow-other-keys)
663  (declare (dynamic-extent keys))
664  (ecase type
665    ((nil :stream) (apply #'make-stream-file-socket keys))
666    (:datagram (apply #'make-datagram-file-socket keys))))
667
668(defun make-socket (&rest keys
669                    &key address-family
670                    ;; List all keys here just for error checking...
671                    ;; &allow-other-keys
672                    type connect remote-host remote-port eol format
673                    keepalive reuse-address nodelay broadcast linger
674                    local-port local-host backlog class out-of-band-inline
675                    local-filename remote-filename sharing basic
676                    external-format (auto-close t)
677                    connect-timeout input-timeout output-timeout deadline
678                    fd)
679  "Create and return a new socket."
680  (declare (dynamic-extent keys))
681  (declare (ignore type connect remote-host remote-port eol format
682                   keepalive reuse-address nodelay broadcast linger
683                   local-port local-host backlog class out-of-band-inline
684                   local-filename remote-filename sharing basic external-format
685                   auto-close connect-timeout input-timeout output-timeout deadline fd))
686  (ecase address-family
687    ((:file) (apply #'make-file-socket keys))
688    ((nil :internet) (apply #'make-ip-socket keys))))
689
690
691
692(defun make-udp-socket (&rest keys &key (fd -1) &allow-other-keys)
693  (unwind-protect
694    (let (socket)
695      (when (< fd 0)
696        (setq fd (socket-call nil "socket"
697                              (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))))
698      (apply #'set-socket-options fd keys)
699      (setq socket (make-instance 'udp-socket
700                                  :device fd
701                                  :keys keys))
702      (setq fd -1)
703      socket)
704    (unless (< fd 0)
705      (fd-close fd))))
706
707(defun make-tcp-socket (&rest keys &key connect (fd -1) &allow-other-keys)
708  (unwind-protect
709       (let (socket)
710         (when (< fd 0)
711           (setq fd (socket-call nil "socket"
712                                 (c_socket #$AF_INET #$SOCK_STREAM #$IPPROTO_TCP))))
713         (apply #'set-socket-options fd keys)
714         (setq socket
715               (ecase connect
716                 ((nil :active) (apply #'make-tcp-stream-socket fd keys))
717                 ((:passive) (apply #'make-tcp-listener-socket fd keys))))
718         (setq fd -1)
719         socket)
720    (unless (< fd 0)
721      (fd-close fd))))
722
723(defun make-stream-file-socket (&rest keys &key connect (fd -1) &allow-other-keys)
724  (unwind-protect
725       (let (socket)
726         (when (< fd 0)
727           (setq fd (socket-call nil "socket" (c_socket #$PF_UNIX #$SOCK_STREAM 0))))
728         (apply #'set-socket-options fd keys)
729         (setq socket
730               (ecase connect
731                 ((nil :active) (apply #'make-file-stream-socket fd keys))
732                 ((:passive) (apply #'make-file-listener-socket fd keys))))
733         (setq fd -1)
734         socket)
735    (unless (< fd 0)
736      (fd-close fd))))
737
738(defun make-datagram-file-socket (&rest keys)
739  (declare (ignore keys))
740  (error "Datagram file sockets aren't implemented."))
741
742
743(defun %socket-connect (fd addr addrlen &optional timeout-in-milliseconds)
744  (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds)))
745    (declare (fixnum err))
746    (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err))))
747   
748(defun inet-connect (fd host-n port-n &optional timeout-in-milliseconds)
749  (rlet ((sockaddr :sockaddr_in))
750    (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
751          (pref sockaddr :sockaddr_in.sin_port) port-n
752          (pref sockaddr
753                #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
754                #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr
755                ) host-n)
756    (%socket-connect fd sockaddr (record-length :sockaddr_in) timeout-in-milliseconds)))
757
758#-windows-target
759(defun file-socket-connect (fd remote-filename)
760  (rletz ((sockaddr :sockaddr_un))
761    (init-unix-sockaddr sockaddr remote-filename)
762    (%socket-connect fd sockaddr (record-length :sockaddr_un))))
763
764#+windows-target
765(defun file-socket-connect (fd remote-filename)
766  (declare (ignore fd))
767  (error "Can't create file socket to ~s on Windows" remote-filename))
768 
769(defun make-tcp-stream-socket (fd &rest keys
770                                  &key remote-host
771                                  remote-port
772                                  connect-timeout
773                                  deadline
774                                  &allow-other-keys)
775  (let* ((timeout-in-milliseconds
776          (if deadline
777            (max (round (- deadline (get-internal-real-time))
778                        (/ internal-time-units-per-second 1000))
779                 0)
780            (if connect-timeout
781              (round (* connect-timeout 1000))))))
782    (inet-connect fd
783                  (host-as-inet-host remote-host)
784                  (port-as-inet-port remote-port "tcp")
785                  timeout-in-milliseconds)
786    (apply #'make-tcp-stream fd keys)))
787
788(defun make-file-stream-socket (fd &rest keys
789                                   &key remote-filename
790                                   &allow-other-keys)
791  (file-socket-connect fd remote-filename)
792  (apply #'make-file-socket-stream fd keys))
793
794
795(defun make-tcp-stream (fd
796                        &key (format :bivalent)
797                             external-format
798                             (class 'tcp-stream)
799                             sharing
800                             (basic t)
801                             (auto-close t)
802                             input-timeout
803                             output-timeout
804                             deadline
805                        &allow-other-keys)
806  (let* ((external-format (normalize-external-format :socket external-format)))
807    (let ((element-type (ecase format
808                          ((nil :text) 'character)
809                          ((:binary :bivalent) '(unsigned-byte 8)))))
810      ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close
811      ;; See if should specialize any of 'em.
812      (make-fd-stream fd
813                      :class class
814                      :direction :io
815                      :element-type element-type
816                      :sharing sharing
817                      :character-p (not (eq format :binary))
818                      :encoding (external-format-character-encoding external-format)
819                      :line-termination (external-format-line-termination external-format)
820                      :basic basic
821                      :auto-close auto-close
822                      :input-timeout input-timeout
823                      :output-timeout output-timeout
824                      :deadline deadline))))
825
826(defun make-file-socket-stream (fd
827                                &key (format :bivalent)
828                                external-format
829                                (class 'file-socket-stream)
830                                sharing
831                                basic
832                                (auto-close t)
833                                input-timeout
834                                output-timeout
835                                deadline
836                                &allow-other-keys)
837  (let* ((external-format (normalize-external-format :socket external-format)))
838 
839    (let ((element-type (ecase format
840                          ((nil :text) 'character)
841                          ((:binary :bivalent) '(unsigned-byte 8)))))
842      ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close
843      ;; See if should specialize any of 'em.
844      (make-fd-stream fd
845                      :class class
846                      :direction :io
847                      :element-type element-type
848                      :encoding (external-format-character-encoding external-format)
849                      :line-termination (external-format-line-termination external-format)
850                      :sharing sharing
851                      :character-p (not (eq format :binary))
852                      :basic basic
853                      :auto-close auto-close
854                      :input-timeout input-timeout
855                      :output-timeout output-timeout
856                      :deadline deadline))))
857
858(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
859  (socket-call nil "listen" (c_listen fd (or backlog 5)))
860  (make-instance 'listener-socket
861                 :device fd
862                 :keys keys))
863
864(defun make-file-listener-socket (fd &rest keys &key backlog &allow-other-keys)
865  (socket-call nil "listen" (c_listen fd (or backlog 5)))
866  (make-instance 'file-listener-socket
867                 :device fd
868                 :keys keys))
869
870(defun socket-accept (fd wait)
871  (flet ((_accept (fd async)
872           (let ((res (c_accept fd (%null-ptr) (%null-ptr))))
873             (declare (fixnum res))
874             ;; See the inscrutable note under ERROR HANDLING in
875             ;; man accept(2). This is my best guess at what they mean...
876             (if (and async (< res 0)
877                      #+windows-target
878                      (= res #$WSAEWOULDBLOCK)
879                      #-windows-target
880                      (or (eql res (- #$ENETDOWN))
881                          (eql res (- #+linux-target #$EPROTO
882                                      #-linux-target  #$EPROTOTYPE))
883                          (eql res (- #$ENOPROTOOPT))
884                          (eql res (- #$EHOSTDOWN))
885                          (eql res (- #+linux-target #$ENONET
886                                      #-linux-target #$ENETDOWN))
887                          (eql res (- #$EHOSTUNREACH))
888                          (eql res (- #$EOPNOTSUPP))
889                          (eql res (- #$ENETUNREACH))))
890               (- #$EAGAIN)
891               res))))
892    (cond (wait
893            (with-eagain fd :input
894              (_accept fd *multiprocessing-socket-io*)))
895          (*multiprocessing-socket-io*
896            (_accept fd t))
897          (t
898            (let ((was-blocking (get-socket-fd-blocking fd)))
899              (unwind-protect
900                  (progn
901                    (set-socket-fd-blocking fd nil)
902                    (_accept fd t))
903                (set-socket-fd-blocking fd was-blocking)))))))
904
905(defun accept-socket-connection (socket wait stream-create-function &optional stream-args)
906  (let ((listen-fd (socket-device socket))
907        (fd -1))
908    (unwind-protect
909      (let ((keys (append stream-args (socket-keys socket))))
910        (setq fd (socket-accept listen-fd wait))
911        (cond ((>= fd 0)
912               (prog1 (apply stream-create-function fd keys)
913                 (setq fd -1)))
914              ((eql fd (- #$EAGAIN)) nil)
915              (t (socket-error socket "accept" fd))))
916      (when (>= fd 0)
917        (fd-close fd)))))
918
919(defgeneric accept-connection (socket &key wait stream-args)
920  (:documentation
921  "Extract the first connection on the queue of pending connections,
922accept it (i.e. complete the connection startup protocol) and return a new
923tcp-stream or file-socket-stream representing the newly established
924connection.  The tcp stream inherits any properties of the listener socket
925that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments
926may be specified using STREAM-ARGS. The original listener
927socket continues to be open listening for more connections, so you can call
928accept-connection on it again."))
929
930(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args)
931  (accept-socket-connection socket wait #'make-tcp-stream stream-args))
932
933(defmethod accept-connection ((socket file-listener-socket) &key (wait t) stream-args)
934  (accept-socket-connection socket wait #'make-file-socket-stream stream-args))
935
936(defun verify-socket-buffer (buf offset size)
937  (unless offset (setq offset 0))
938  (unless (<= (+ offset size) (length buf))
939    (report-bad-arg size `(integer 0 ,(- (length buf) offset))))
940  (multiple-value-bind (arr start) (array-data-and-offset buf)
941    (setq buf arr offset (+ offset start)))
942  ;; TODO: maybe should allow any raw vector
943  (let ((subtype (typecode buf)))
944    (unless #+ppc32-target (and (<= ppc32::min-8-bit-ivector-subtag subtype)
945                                (<= subtype ppc32::max-8-bit-ivector-subtag))
946            #+ppc64-target (= (the fixnum (logand subtype ppc64::fulltagmask))
947                              ppc64::ivector-class-8-bit)
948            #+x8632-target (and (<= x8632::min-8-bit-ivector-subtag subtype)
949                                (<= subtype x8632::max-8-bit-ivector-subtag))
950            #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
951                                (<= subtype x8664::max-8-bit-ivector-subtag))
952      (report-bad-arg buf '(or (array (unsigned-byte 8))
953                               (array (signed-byte 8))))))
954  (values buf offset))
955
956(defmethod send-to ((socket udp-socket) msg size
957                    &key remote-host remote-port offset)
958  "Send a UDP packet over a socket."
959  (let ((fd (socket-device socket)))
960    (multiple-value-setq (msg offset) (verify-socket-buffer msg offset size))
961    (unless remote-host
962      (setq remote-host (or (getf (socket-keys socket) :remote-host)
963                            (remote-socket-info socket :host))))
964    (unless remote-port
965      (setq remote-port (or (getf (socket-keys socket) :remote-port)
966                            (remote-socket-info socket :port))))
967    (rlet ((sockaddr :sockaddr_in))
968      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
969      (setf (pref sockaddr
970                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
971                  #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr)
972            (if remote-host (host-as-inet-host remote-host) #$INADDR_ANY))
973      (setf (pref sockaddr :sockaddr_in.sin_port)
974            (if remote-port (port-as-inet-port remote-port "udp") 0))
975      (%stack-block ((bufptr size))
976        (%copy-ivector-to-ptr msg offset bufptr 0 size)
977        (socket-call socket "sendto"
978          (with-eagain fd :output
979            (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in))))))))
980
981(defmethod receive-from ((socket udp-socket) size &key buffer extract offset)
982  "Read a UDP packet from a socket. If no packets are available, wait for
983a packet to arrive. Returns four values:
984  The buffer with the data
985  The number of bytes read
986  The 32-bit unsigned IP address of the sender of the data
987  The port number of the sender of the data."
988  (let ((fd (socket-device socket))
989        (vec-offset offset)
990        (vec buffer)
991        (ret-size -1))
992    (when vec
993      (multiple-value-setq (vec vec-offset)
994        (verify-socket-buffer vec vec-offset size)))
995    (rlet ((sockaddr :sockaddr_in)
996           (namelen :signed))
997      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
998      (setf (pref sockaddr
999                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
1000                  #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)
1001            #$INADDR_ANY)
1002      (setf (pref sockaddr :sockaddr_in.sin_port) 0)
1003      (setf (pref namelen :signed) (record-length :sockaddr_in))
1004      (%stack-block ((bufptr size))
1005        (setq ret-size (socket-call socket "recvfrom"
1006                         (with-eagain fd :input
1007                           (c_recvfrom fd bufptr size 0 sockaddr namelen))))
1008        (unless vec
1009          (setq vec (make-array ret-size
1010                                :element-type
1011                                (ecase (socket-format socket)
1012                                  ((:binary) '(unsigned-byte 8))))
1013                vec-offset 0))
1014        (%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size))
1015      (values (cond ((null buffer)
1016                     vec)
1017                    ((or (not extract)
1018                         (and (eql 0 (or offset 0))
1019                              (eql ret-size (length buffer))))
1020                     buffer)
1021                    (t 
1022                     (subseq vec vec-offset (+ vec-offset ret-size))))
1023              ret-size
1024              (ntohl (pref sockaddr
1025                           #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
1026                           #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))
1027              (ntohs (pref sockaddr :sockaddr_in.sin_port))))))
1028
1029(defgeneric shutdown (socket &key direction)
1030  (:documentation
1031   "Shut down part of a bidirectional connection. This is useful if e.g.
1032you need to read responses after sending an end-of-file signal."))
1033
1034(defmethod shutdown (socket &key direction)
1035  ;; TODO: should we ignore ENOTCONN error?  (at least make sure it
1036  ;; is a distinct, catchable error type).
1037  (let ((fd (socket-device socket)))
1038    (socket-call socket "shutdown"
1039      (c_shutdown fd (ecase direction
1040                       (:input 0)
1041                       (:output 1))))))
1042
1043;; Accepts port as specified by user, returns port number in network byte
1044;; order.  Protocol should be one of "tcp" or "udp".  Error if not known.
1045(defun port-as-inet-port (port proto)
1046  (or (etypecase port
1047        (fixnum (htons port))
1048        (string (_getservbyname port proto))
1049        (symbol (_getservbyname (string-downcase (symbol-name port)) proto)))
1050      (socket-error nil "getservbyname" (- #$ENOENT))))
1051
1052(defun lookup-port (port proto)
1053  "Find the port number for the specified port and protocol."
1054  (if (fixnump port)
1055    port
1056    (ntohs (port-as-inet-port port proto))))
1057
1058;; Accepts host as specified by user, returns host number in network byte
1059;; order.
1060(defun host-as-inet-host (host)
1061  (etypecase host
1062    (integer (htonl host))
1063    (string (or (and (every #'(lambda (c) (position c ".0123456789")) host)
1064                     (_inet_aton host))
1065                (multiple-value-bind (addr err) (c_gethostbyname host)
1066                  (or addr
1067                      (socket-error nil "gethostbyname" err t)))))))
1068
1069
1070(defun dotted-to-ipaddr (name &key (errorp t))
1071  "Convert a dotted-string representation of a host address to a 32-bit
1072unsigned IP address."
1073  (let ((addr (_inet_aton name)))
1074    (if addr (ntohl addr)
1075      (and errorp (error "Invalid dotted address ~s" name)))))
1076   
1077(defun lookup-hostname (host)
1078  "Convert a host spec in any of the acceptable formats into a 32-bit
1079unsigned IP address."
1080  (if (typep host 'integer)
1081    host
1082    (ntohl (host-as-inet-host host))))
1083
1084(defun ipaddr-to-dotted (addr &key values)
1085  "Convert a 32-bit unsigned IP address into octets."
1086  (let* ((a (ldb (byte 8 24) addr))
1087         (b (ldb (byte 8 16) addr))
1088         (c (ldb (byte 8  8) addr))
1089         (d (ldb (byte 8  0) addr)))
1090    (if values
1091      (values a b c d)
1092      (format nil "~d.~d.~d.~d" a b c d))))
1093
1094(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
1095  "Convert a 32-bit unsigned IP address into a host name string."
1096  (declare (ignore ignore-cache))
1097  (multiple-value-bind (name err) (c_gethostbyaddr (htonl ipaddr))
1098    (or name (socket-error nil "gethostbyaddr" err t))))
1099 
1100
1101(defun int-getsockopt (socket level optname)
1102  (rlet ((valptr :signed)
1103         (vallen :signed))
1104    (setf (pref vallen :signed) 4)
1105    (let* ((err (c_getsockopt socket level optname valptr vallen)))
1106      (if (and (eql 0 err)
1107               (eql 4 (pref vallen :signed)))
1108        (pref valptr :signed)
1109        (socket-error socket "getsockopt" err)))))
1110
1111(defun timeval-setsockopt (socket level optname timeout)
1112    (multiple-value-bind (seconds micros)
1113        (microseconds timeout)
1114      (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros))
1115        (socket-call socket "setsockopt"
1116          (c_setsockopt socket level optname valptr (record-length :timeval))))))
1117                   
1118(defun int-setsockopt (socket level optname optval)
1119  (rlet ((valptr :signed))
1120    (setf (pref valptr :signed) optval)
1121    (socket-call socket "setsockopt"
1122      (c_setsockopt socket level optname valptr (record-length :signed)))))
1123
1124
1125
1126           
1127(defun c_gethostbyaddr (addr-in-net-byte-order)
1128  (rletZ ((sin #>sockaddr_in))
1129    (setf (pref sin :sockaddr_in.sin_family) #$AF_INET
1130          (pref sin
1131                #+(or windows-target solaris-target) #>sockaddr_in.sin_addr.S_un.S_addr
1132                #-(or windows-target solaris-target) #>sockaddr_in.sin_addr.s_addr) addr-in-net-byte-order)
1133    #+darwin-target (setf (pref sin :sockaddr_in.sin_len) (record-length :sockaddr_in))
1134    (%stack-block ((namep #$NI_MAXHOST))
1135      (let* ((err (#_getnameinfo sin (record-length #>sockaddr_in) namep #$NI_MAXHOST (%null-ptr) 0 #$NI_NAMEREQD)))
1136        (if (eql 0 err)
1137          (%get-cstring namep)
1138          (values nil err))))))
1139               
1140(defun c_gethostbyname (name)
1141  (with-cstrs ((name (string name)))
1142    (rletZ ((hints #>addrinfo)
1143            (results :address))
1144      (setf (pref hints #>addrinfo.ai_family) #$AF_INET)
1145      (let* ((err (#_getaddrinfo name (%null-ptr) hints results)))
1146        (if (eql 0 err)
1147          (let* ((info (pref results :address))
1148                 (sin (pref info #>addrinfo.ai_addr)))
1149            (prog1
1150                #+(or windows-target solaris-target)
1151                (pref sin #>sockaddr_in.sin_addr.S_un.S_addr)
1152                #-(or windows-target solaris-target)
1153                (pref sin #>sockaddr_in.sin_addr.s_addr)
1154                (#_freeaddrinfo info)))
1155          (values nil err))))))
1156     
1157 
1158
1159 
1160
1161(defun _getservbyname (name proto)
1162  (with-cstrs ((name (string name))
1163               (proto (string proto)))
1164    (let* ((servent-ptr (%null-ptr)))
1165      (declare (dynamic-extent servent-ptr))
1166      (%setf-macptr servent-ptr (#_getservbyname name proto))
1167      (unless (%null-ptr-p servent-ptr)
1168        (pref servent-ptr :servent.s_port)))))
1169
1170(defun _inet_aton (string)
1171  (with-cstrs ((name string))
1172    #-windows-target
1173    (rlet ((addr :in_addr))
1174      (let* ((result #+freebsd-target (#___inet_aton name addr)
1175                     #-freebsd-target (#_inet_aton name addr)))
1176        (unless (eql result 0)
1177          (pref addr
1178                #-solaris-target :in_addr.s_addr
1179                #+solaris-target #>in_addr.S_un.S_addr
1180                ))))
1181    #+windows-target
1182    (rlet ((addr :sockaddr_in)
1183           (addrlenp :int (record-length :sockaddr_in)))
1184      (setf (pref addr :sockaddr_in.sin_family) #$AF_INET)
1185      (when (zerop (#_WSAStringToAddressA name #$AF_INET (%null-ptr)  addr addrlenp))
1186        (pref addr #>sockaddr_in.sin_addr.S_un.S_addr)))))
1187
1188(defun c_socket_1 (domain type protocol)
1189  #-windows-target (int-errno-call (#_socket domain type protocol))
1190  #+windows-target (let* ((handle (#_socket domain type protocol)))
1191                     (if (< handle 0)
1192                       (%get-winsock-error)
1193                       handle)))
1194
1195
1196
1197(defun c_socket (domain type protocol)
1198  (let* ((fd (c_socket_1 domain type protocol)))
1199    (when (or (eql fd (- #$EMFILE))
1200              (eql fd (- #$ENFILE)))
1201      (gc)
1202      (drain-termination-queue)
1203      (setq fd (c_socket_1 domain type protocol)))
1204    fd))
1205     
1206
1207#-windows-target
1208(defun init-unix-sockaddr (addr path)
1209  (macrolet ((sockaddr_un-path-len ()
1210               (/ (ensure-foreign-type-bits
1211                   (foreign-record-field-type 
1212                    (%find-foreign-record-type-field
1213                     (parse-foreign-type '(:struct :sockaddr_un)) :sun_path)))
1214                  8)))
1215    (let* ((name (native-translated-namestring path))
1216           (namelen (length name))
1217           (pathlen (sockaddr_un-path-len))
1218           (copylen (min (1- pathlen) namelen)))
1219      (setf (pref addr :sockaddr_un.sun_family) #$AF_UNIX)
1220      (let* ((sun-path (pref addr :sockaddr_un.sun_path)))
1221        (dotimes (i copylen)
1222          (setf (%get-unsigned-byte sun-path i)
1223                (let* ((code (char-code (schar name i))))
1224                  (if (> code 255)
1225                    (char-code #\Sub)
1226                    code))))))))
1227
1228#-windows-target
1229(defun bind-unix-socket (socketfd path)
1230  (rletz ((addr :sockaddr_un))
1231    (init-unix-sockaddr addr path)
1232    (socket-call
1233     nil
1234     "bind"
1235     (c_bind socketfd
1236             addr
1237             (+ 2
1238                (#_strlen
1239                 (pref addr :sockaddr_un.sun_path)))))))
1240     
1241
1242(defun c_bind (sockfd sockaddr addrlen)
1243  (check-socket-error (#_bind sockfd sockaddr addrlen)))
1244
1245
1246#+windows-target
1247(defun windows-connect-wait (sockfd timeout-in-milliseconds)
1248  (if (and timeout-in-milliseconds
1249           (< timeout-in-milliseconds 0))
1250    (setq timeout-in-milliseconds nil))
1251  (rlet ((writefds :fd_set)
1252         (exceptfds :fd_set)
1253         (tv :timeval :tv_sec 0 :tv_usec 0))
1254    (fd-zero writefds)
1255    (fd-zero exceptfds)
1256    (fd-set sockfd writefds)
1257    (fd-set sockfd exceptfds)
1258    (when timeout-in-milliseconds
1259      (multiple-value-bind (seconds milliseconds)
1260          (floor timeout-in-milliseconds 1000)
1261        (setf (pref tv :timeval.tv_sec) seconds
1262              (pref tv :timeval.tv_usec) (* 1000 milliseconds))))
1263    (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseconds tv (%null-ptr))) 0)))
1264     
1265     
1266;;; If attempts to connnect are interrupted, we basically have to
1267;;; wait in #_select (or the equivalent).  There's a good rant
1268;;; about these issues in:
1269;;; <http://www.madore.org/~david/computers/connect-intr.html>
1270(defun c_connect (sockfd addr len &optional timeout-in-milliseconds)
1271  (let* ((was-blocking (get-socket-fd-blocking sockfd)))
1272    (unwind-protect
1273         (progn
1274           (set-socket-fd-blocking sockfd nil)
1275           (let* ((err (check-socket-error (#_connect sockfd addr len))))
1276             (cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS
1277                                   
1278                                    #-windows-target #$EINPROGRESS))
1279                        #+windows-target (eql err (- #$WSAEWOULDBLOCK))
1280                        (eql err (- #$EINTR)))
1281                    (if
1282                      #+windows-target (windows-connect-wait sockfd timeout-in-milliseconds)
1283                      #-windows-target (process-output-wait sockfd timeout-in-milliseconds)
1284                      (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
1285                      (- #+windows-target #$WSAETIMEDOUT #-windows-target #$ETIMEDOUT)))
1286                   (t err))))
1287      (set-socket-fd-blocking sockfd was-blocking))))
1288
1289(defun c_listen (sockfd backlog)
1290  (check-socket-error (#_listen sockfd backlog)))
1291
1292(defun c_accept (sockfd addrp addrlenp)
1293  (ignoring-eintr
1294   (check-socket-error (#_accept sockfd addrp addrlenp))))
1295
1296(defun c_getsockname (sockfd addrp addrlenp)
1297  (check-socket-error (#_getsockname sockfd addrp addrlenp)))
1298
1299(defun c_getpeername (sockfd addrp addrlenp)
1300  (check-socket-error (#_getpeername sockfd addrp addrlenp)))
1301
1302#-windows-target
1303(defun c_socketpair (domain type protocol socketsptr)
1304  (check-socket-error (#_socketpair domain type protocol socketsptr)))
1305
1306
1307(defun c_sendto (sockfd msgptr len flags addrp addrlen)
1308  (ignoring-eintr (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen))))
1309
1310(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp)
1311  (ignoring-eintr (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp))))
1312
1313(defun c_shutdown (sockfd how)
1314  (check-socket-error (#_shutdown sockfd how)))
1315
1316(defun c_setsockopt (sockfd level optname optvalp optlen)
1317  (check-socket-error (#_setsockopt sockfd level optname optvalp optlen)))
1318
1319(defun c_getsockopt (sockfd level optname optvalp optlenp)
1320  (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp)))
1321
1322#-windows-target
1323(defun c_sendmsg (sockfd msghdrp flags)
1324  (check-socket-error (#_sendmsg sockfd msghdrp flags)))
1325
1326#-windows-target
1327(defun c_recvmsg (sockfd msghdrp flags)
1328  (check-socket-error   (#_recvmsg sockfd msghdrp flags)))
1329
1330;;; Return a list of currently configured interfaces, a la ifconfig.
1331(defstruct ip-interface
1332  name
1333  addr
1334  netmask
1335  flags
1336  address-family)
1337
1338(defun dump-buffer (p n)
1339  (dotimes (i n (progn (terpri) (terpri)))
1340    (unless (logtest i 15)
1341      (format t "~&~8,'0x: " (%ptr-to-int (%inc-ptr p i))))
1342    (format t " ~2,'0x" (%get-byte p i))))
1343
1344#-(or windows-target solaris-target)
1345(defun %get-ip-interfaces ()
1346  (rlet ((p :address (%null-ptr)))
1347    (if (zerop (#_getifaddrs p))
1348      (unwind-protect
1349           (do* ((q (%get-ptr p) (pref q :ifaddrs.ifa_next))
1350                 (res ()))
1351                ((%null-ptr-p q) (nreverse res))
1352             (let* ((addr (pref q :ifaddrs.ifa_addr)))
1353               (when (and (not (%null-ptr-p addr))
1354                          (eql (pref addr :sockaddr.sa_family) #$AF_INET))
1355                 (push (make-ip-interface
1356                        :name (%get-cstring (pref q :ifaddrs.ifa_name))
1357                        :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr))
1358                        :netmask (ntohl
1359                                  (pref (pref q :ifaddrs.ifa_netmask)
1360                                       :sockaddr_in.sin_addr.s_addr))
1361                        :flags (pref q :ifaddrs.ifa_flags)
1362                        :address-family #$AF_INET)
1363                       res))))
1364        (#_freeifaddrs (pref p :address))))))
1365
1366#+solaris-target
1367(progn
1368  ;;; Interface translator has trouble with a lot of ioctl constants.
1369  (eval-when (:compile-toplevel :execute)
1370    (defconstant os::|SIOCGLIFNUM| #xc00c6982)
1371    (defconstant os::|SIOCGLIFCONF| #xc01069a5)
1372    (defconstant os::|SIOCGLIFADDR| #xc0786971)
1373    (defconstant os::|SIOCGLIFFLAGS| #xc0786975)
1374    (defconstant os::|SIOCGLIFNETMASK| #xc078697d)
1375    )
1376
1377(defun %get-ip-interfaces ()
1378  (let* ((sock (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))
1379         (res nil))
1380    (when (>= sock 0)
1381      (unwind-protect
1382           (let* ((flags (logior #$LIFC_NOXMIT #$LIFC_TEMPORARY #$LIFC_ALLZONES))
1383                  (ninterfaces (rlet ((lifnum :lifnum
1384                                        :lifn_flags flags
1385                                        :lifn_family #$AF_INET
1386                                        :lifn_count 0))
1387                                 (#_ioctl sock os::SIOCGLIFNUM :address lifnum)
1388                                 (pref lifnum :lifnum.lifn_count))))
1389             (declare (fixnum ninterfaces))
1390             (when (> ninterfaces 0)
1391               (let* ((bufsize (* ninterfaces (record-length :lifreq))))
1392                 (%stack-block ((buf bufsize :clear t))
1393                   (rlet ((lifc :lifconf
1394                            :lifc_family #$AF_INET
1395                            :lifc_flags flags
1396                            :lifc_len bufsize
1397                            :lifc_lifcu.lifcu_buf buf))
1398                     (when (>= (#_ioctl sock os::SIOCGLIFCONF :address lifc) 0)
1399                       (do* ((i 0 (1+ i))
1400                             (p (pref lifc :lifconf.lifc_lifcu.lifcu_buf)
1401                                (%inc-ptr p (record-length :lifreq))))
1402                            ((= i ninterfaces))
1403                         (let* ((name (%get-cstring (pref p :lifreq.lifr_name)))
1404                                (address-family (pref p :lifreq.lifr_lifru.lifru_addr.ss_family))
1405                                (if-flags nil)
1406                                (address nil)
1407                                (netmask nil))
1408                           (if (>= (#_ioctl sock os::SIOCGLIFFLAGS :address p)
1409                                   0)
1410                             (setq if-flags (pref p :lifreq.lifr_lifru.lifru_flags)))
1411                           (if (>= (#_ioctl sock os::SIOCGLIFADDR :address p)
1412                                   0)
1413                             (setq address (pref
1414                                            (pref p :lifreq.lifr_lifru.lifru_addr)
1415                                            #>sockaddr_in.sin_addr.S_un.S_addr)))
1416                           (if (>= (#_ioctl sock os::SIOCGLIFNETMASK :address p)
1417                                   0)
1418                             (setq netmask (pref
1419                                            (pref p :lifreq.lifr_lifru.lifru_subnet)
1420                                            #>sockaddr_in.sin_addr.S_un.S_addr)))
1421                             
1422                           (push (make-ip-interface
1423                                  :name name
1424                                  :addr (ntohl address)
1425                                  :netmask (ntohl netmask)
1426                                  :flags if-flags
1427                                  :address-family address-family)
1428                                 res)))))))))
1429        (fd-close sock)))
1430    res))
1431)
1432
1433
1434
1435
1436#+windows-target
1437(defun %get-ip-interfaces ()
1438  (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
1439    (unwind-protect
1440    (rlet ((realoutlen #>DWORD 0))
1441      (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
1442                         (* 2 reservedlen)))
1443           ()
1444        (%stack-block ((buf reservedlen))
1445          (unless (eql 0 (#_WSAIoctl
1446                          socket
1447                          #$SIO_GET_INTERFACE_LIST
1448                          (%null-ptr)
1449                          0
1450                          buf
1451                          reservedlen
1452                          realoutlen
1453                          (%null-ptr)
1454                          (%null-ptr)))
1455            (return))
1456          (let* ((noutbytes (pref realoutlen #>DWORD)))
1457            (when (< noutbytes reservedlen)
1458              (let* ((interfaces nil))
1459                (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO)))
1460                      (nameidx 0 (1+ nameidx)))
1461                     ((>= offset noutbytes))
1462                  (with-macptrs ((p (%inc-ptr buf offset)))
1463                    (push (make-ip-interface 
1464                           :name (format nil "ip~d" nameidx)
1465                           :addr (ntohl
1466                                  (pref (pref p #>INTERFACE_INFO.iiAddress)
1467                                        #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
1468                           :netmask (ntohl
1469                                     (pref (pref p #>INTERFACE_INFO.iiNetmask)
1470                                        #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
1471                           :flags (pref p #>INTERFACE_INFO.iiFlags)
1472                           :address-family #$AF_INET)
1473                          interfaces)))
1474                (return interfaces)))))))
1475      (#_closesocket socket))))
1476
1477     
1478
1479
1480(defloadvar *ip-interfaces* ())
1481
1482(defun ip-interfaces ()
1483  (or *ip-interfaces*
1484      (setq *ip-interfaces* (%get-ip-interfaces))))
1485
1486;;; This should presumably happen after a configuration change.
1487;;; How do we detect a configuration change ?
1488(defun %reset-ip-interfaces ()
1489  (setq *ip-interfaces* ()))
1490
1491;;; Return the first non-loopback interface that's up and whose address
1492;;; family is #$AF_INET.  If no such interface exists, return
1493;;; the loopback interface.
1494(defun primary-ip-interface ()
1495  (let* ((ifaces (ip-interfaces)))
1496    (or (find-if #'(lambda (i)
1497                     (and (eq #$AF_INET (ip-interface-address-family i))
1498                          (ip-interface-addr i)
1499                          (let* ((flags (ip-interface-flags i)))
1500                            (and (not (logtest #$IFF_LOOPBACK flags))
1501                                 (logtest #$IFF_UP flags)))))
1502                 ifaces)
1503        (car ifaces))))
1504
1505(defun primary-ip-interface-address ()
1506  (let* ((iface (primary-ip-interface)))
1507    (if iface
1508      (ip-interface-addr iface)
1509      (error "Can't determine primary IP interface"))))
1510         
1511         
1512(defmethod stream-io-error ((stream socket) errno where)
1513  (socket-error stream where errno))
Note: See TracBrowser for help on using the repository browser.