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

Last change on this file since 13990 was 13990, checked in by gb, 9 years ago

In the windows version of %GET-IP-INTERFACES, handle the "buffer too
small" case correctly.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.9 KB
RevLine 
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2001-2009 Clozure Associates
[13066]4;;;   This file is part of Clozure CL. 
[6]5;;;
[13066]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
[6]8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]10;;;   conflict, the preamble takes precedence. 
11;;;
[13066]12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
[1539]19
20
21;;; basic socket API
[6]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
[13377]50            SOCKET-CREATION-ERROR
51            SOCKET-CREATION-ERROR-CODE
52            SOCKET-CREATION-ERROR-IDENTIFIER
53            SOCKET-CREATION-ERROR-SITUATION
[10574]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  )
[6]66
[10574]67
68#+windows-target
69(defun %get-winsock-error ()
70  (- (#_WSAGetLastError)))
71
[1539]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
[3978]79#+big-endian-target
[1539]80(progn
81  (defmacro HTONL (x) x)
82  (defmacro HTONS (x) x)
83  (defmacro NTOHL (x) x)
84  (defmacro NTOHS (x) x))
[3978]85
86#+little-endian-target
87(progn
88  (declaim (inline %bswap32 %bswap16))
89  (defun %bswap32 (x)
90    (declare (type (unsigned-byte 32) x))
[5305]91    (%swap-u32 x))
[3978]92  (defun %bswap16 (x)
[5225]93    (declare (type (unsigned-byte 16) x))
[5305]94    (%swap-u16 x))
[3978]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
[5417]100(defparameter *default-socket-character-encoding*
101  nil)
[3978]102
[5417]103(defmethod default-character-encoding ((domain (eql :socket)))
104  *default-socket-character-encoding*)
[1539]105 
106
107;;; On some (hypothetical) little-endian platform, we might want to
108;;; define HTONL and HTONS to actually swap bytes around.
109
[6]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"
[13377]140                "SOCKET-CREATION-ERROR"
141                "SOCKET-CREATION-ERROR-CODE"
142                "SOCKET-CREATION-ERROR-IDENTIFIER"
143                "SOCKET-CREATION-ERROR-SITUATION"
[6]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"
[13377]172            "SOCKET-CREATION-ERROR"
173            "SOCKET-CREATION-ERROR-CODE"
174            "SOCKET-CREATION-ERROR-IDENTIFIER"
175            "SOCKET-CREATION-ERROR-SITUATION"
[6]176            "WITH-OPEN-SOCKET"))
177
[423]178(define-condition socket-error (simple-stream-error)
[6]179  ((code :initarg :code :reader socket-error-code)
180   (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier)
[13377]181   (situation :initarg :situation :reader socket-error-situation)))
[6]182
[768]183(define-condition socket-creation-error (simple-error)
184  ((code :initarg :code :reader socket-creation-error-code)
[7624]185   (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
[768]186   (situation :initarg :situation :reader socket-creation-error-situation)))
187
[13377]188(defparameter *gai-error-identifiers*
189  (list #$EAI_AGAIN :try-again
190        #$EAI_FAIL :no-recovery
191        #$EAI_NONAME :host-not-found))
192
[6]193(defvar *socket-error-identifiers*
[10685]194  #-windows-target
[6]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
[423]206        #$EADDRNOTAVAIL :address-not-available
207        #$ENETRESET :network-reset
208        #$ECONNRESET :connection-reset
209        #$ESHUTDOWN :shutdown
[6]210        #$EACCES :access-denied
[10685]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  )
[6]231
232
233(declaim (inline socket-call))
[423]234(defun socket-call (stream where res)
[6]235  (if (< res 0)
[423]236    (socket-error stream where res)
[6]237    res))
238
[10685]239#-windows-target
[13382]240(defun %gai-strerror (err)
241  (let ((p (#_gai_strerror err)))
[10865]242    (if (%null-ptr-p p)
243      (format nil "Unknown nameserver error ~d" err)
244      (%get-cstring p))))
[423]245
246(defun socket-error (stream where errno &optional nameserver-p)
[768]247  "Creates and signals (via error) one of two socket error
248conditions, based on the state of the arguments."
[13382]249  (unless nameserver-p
250    (setq errno (abs errno)))
[423]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
[7978]257                           :format-control "~a (error #~d) during ~a"
[423]258                           :format-arguments (list
[13377]259                                              #+windows-target
260                                              (%windows-error-string errno)
261                                              #-windows-target
262                                              (%strerror errno)
[7978]263                                              errno where)))
[13377]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))))))
[6]280
[7978]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)
[6]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")))
[2439]292  "Execute body with var bound to the result of applying make-socket to
293make-socket-args. The socket gets closed on exit."
[6]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
[2439]302(defgeneric socket-address-family (socket)
303  (:documentation "Return :internet or :file, as appropriate."))
304
[6]305(defclass ip-socket (socket)
306  ())
307
[2439]308(defmethod socket-address-family ((socket ip-socket)) :internet)
[6]309
310(defclass file-socket (socket)
311  ())
312
[2439]313(defmethod socket-address-family ((socket file-socket)) :file)
[6]314
315(defclass tcp-socket (ip-socket)
316  ())
317
[2439]318(defgeneric socket-type (socket)
319  (:documentation
320   "Return :stream for tcp-stream and listener-socket, and :datagram
321for udp-socket."))
[6]322
[2439]323(defmethod socket-type ((socket tcp-socket)) :stream)
324
[6]325(defclass stream-file-socket (file-socket)
326  ())
327
[2439]328(defmethod socket-type ((socket stream-file-socket)) :stream)
[6]329
330
[4900]331;;; An active TCP socket is an honest-to-goodness stream.
[5305]332(defclass tcp-stream (tcp-socket)
[6]333  ())
334
[5305]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
[2439]346(defgeneric socket-connect (stream)
[5305]347 (:documentation
[2439]348   "Return :active for tcp-stream, :passive for listener-socket, and NIL
349for udp-socket"))
[6]350
[2439]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))
[6]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))
[4900]366  (let ((ioblock (stream-ioblock stream nil)))
[6]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?
[4917]371  ;; Yes, in general.  There is.
[6]372  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
[5305]373  'fundamental-tcp-stream)
[6]374
[5305]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
[4333]383;;; A FILE-SOCKET-STREAM is also honest. To goodness.
[5305]384(defclass file-socket-stream (stream-file-socket)
[6]385  ())
386
[5305]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
[5559]399(defmethod map-to-basic-stream-class-name ((name (eql 'file-socket-stream)))
400  'basic-file-socket-stream)
[5305]401
[6]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?
[5559]404  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
[5305]405  'fundamental-file-socket-stream)
[6]406
[5559]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
[6]412(defclass unconnected-socket (socket)
413  ((device :initarg :device :accessor socket-device)
414   (keys :initarg :keys :reader socket-keys)))
415
[2439]416(defmethod socket-format ((socket unconnected-socket))
[6]417  (or (getf (socket-keys socket) :format) :text))
418
[2439]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)
[6]425  (declare (ignore abort))
426  (when (socket-device socket)
427    (fd-close (socket-device socket))
[384]428    (setf (socket-device socket) nil)
429    t))
[6]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
[10865]443#-windows-target
[6]444(defmethod close :before ((s file-listener-socket) &key abort)
445  (declare (ignore abort))
[440]446  (let* ((path (local-socket-filename (socket-device s) s)))
[6]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
[2439]453(defmethod socket-type ((stream udp-socket)) :datagram)
454(defmethod socket-connect ((stream udp-socket)) nil)
[13773]455(defmethod socket-format ((stream udp-socket)) :binary)
[6]456
[2439]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
[6]466;; Returns nil for closed stream...
[2439]467(defmethod socket-os-fd ((socket socket))
[6]468  (socket-device socket))
469
470;; Returns nil for closed stream
[423]471(defun local-socket-info (fd type socket)
[6]472  (and fd
473       (rlet ((sockaddr :sockaddr_in)
474              (namelen :signed))
475             (setf (pref namelen :signed) (record-length :sockaddr_in))
[423]476             (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen))
[6]477             (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
478               (ecase type
[10052]479                 (:host (ntohl (pref sockaddr
[10685]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)))
[1539]482                 (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))
[6]483
[10685]484#-windows-target
[6]485(defun path-from-unix-address (addr)
[10052]486  (when (= #$AF_UNIX (pref addr :sockaddr_un.sun_family))
[4994]487    #+darwin-target
[6]488    (%str-from-ptr (pref addr :sockaddr_un.sun_path)
489                   (- (pref addr :sockaddr_un.sun_len) 2))
[5561]490    #-darwin-target
[6]491    (%get-cstring (pref addr :sockaddr_un.sun_path))))
492
[10685]493#-windows-target
[423]494(defun local-socket-filename (fd socket)
[6]495  (and fd
496       (rlet ((addr :sockaddr_un)
497              (namelen :signed))
498         (setf (pref namelen :signed) (record-length :sockaddr_un))
[423]499         (socket-call socket "getsockname" (c_getsockname fd addr namelen))
[6]500         (path-from-unix-address addr))))
501
[768]502(defmacro with-if ((var expr) &body body)
503  `(let ((,var ,expr))
504     (if ,var
505         (progn
506           ,@body))))     
[6]507
[768]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)))
[10685]514            (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil)
[768]515                  ((< err 0) (socket-error socket "getpeername" err))
516                  (t
517                   (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
518                     (ecase type
[10052]519                       (:host (ntohl (pref sockaddr
[10685]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)))
[1539]522                       (:port (ntohs  (pref sockaddr :sockaddr_in.sin_port)))))))))))
[6]523
[10685]524#-windows-target
[768]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)))))))
[6]534
[2439]535(defgeneric local-port (socket)
536  (:documentation "Return the local port number."))
537
538(defmethod local-port ((socket socket))
[812]539  (local-socket-info (socket-device socket) :port socket))
[6]540
[2439]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))
[812]546  (local-socket-info (socket-device socket) :host socket))
[6]547
[10865]548#-windows-target
[2439]549(defmethod local-filename ((socket socket))
[8760]550  (local-socket-filename (socket-device socket) socket))
[6]551
[2439]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
[6]557;; Returns NIL if socket is not connected
[2439]558(defmethod remote-host ((socket socket))
[768]559  (remote-socket-info socket :host))
[6]560
[2439]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))
[768]566  (remote-socket-info socket :port))
[6]567
[10865]568#-windows-target
[2439]569(defmethod remote-filename ((socket socket))
[768]570  (remote-socket-filename socket))
[6]571 
[10685]572(defun set-socket-fd-blocking (fd block-flag)
573  #+windows-target
[11081]574  (rlet ((argp :u_long (if block-flag 0 1)))
[11209]575    (#_ioctlsocket fd #$FIONBIO argp))
[10685]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
[768]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)
[6]602  ;; see man socket(7) tcp(7) ip(7)
[768]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))
[12165]617    (when (eq address-family :internet)
618      (when (eq type :stream)
619        (rlet ((plinger :linger))
[768]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"
[12165]623                       (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER
624                                     plinger (record-length :linger)))))
[768]625      (when nodelay
626        (int-setsockopt fd
[3809]627                        #+linux-target #$SOL_TCP
[10052]628                        #-linux-target #$IPPROTO_TCP
[768]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
[10052]642                       (pref sockaddr
[10685]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
[10052]645                             ) host-n)
[768]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)
[10865]650      #+windows-target (error "can't create file socket on Windows")
651      #-windows-target (bind-unix-socket fd local-filename))))
[6]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
[2439]668(defun make-socket (&rest keys
[6]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
[5375]675                    local-filename remote-filename sharing basic
[7978]676                    external-format (auto-close t)
[12089]677                    connect-timeout input-timeout output-timeout deadline
678                    fd)
[2439]679  "Create and return a new socket."
[6]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
[7624]684                   local-filename remote-filename sharing basic external-format
[12105]685                   auto-close connect-timeout input-timeout output-timeout deadline fd))
[6]686  (ecase address-family
687    ((:file) (apply #'make-file-socket keys))
688    ((nil :internet) (apply #'make-ip-socket keys))))
689
690
691
[12089]692(defun make-udp-socket (&rest keys &key (fd -1) &allow-other-keys)
[6]693  (unwind-protect
694    (let (socket)
[12089]695      (when (< fd 0)
696        (setq fd (socket-call nil "socket"
697                              (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))))
[6]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
[12089]707(defun make-tcp-socket (&rest keys &key connect (fd -1) &allow-other-keys)
[6]708  (unwind-protect
[12089]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)
[6]720    (unless (< fd 0)
721      (fd-close fd))))
722
[12089]723(defun make-stream-file-socket (&rest keys &key connect (fd -1) &allow-other-keys)
[6]724  (unwind-protect
[12089]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)
[6]735    (unless (< fd 0)
736      (fd-close fd))))
737
[12033]738(defun make-datagram-file-socket (&rest keys)
739  (declare (ignore keys))
740  (error "Datagram file sockets aren't implemented."))
741
742
[8941]743(defun %socket-connect (fd addr addrlen &optional timeout-in-milliseconds)
744  (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds)))
[6]745    (declare (fixnum err))
[8941]746    (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err))))
[6]747   
[8941]748(defun inet-connect (fd host-n port-n &optional timeout-in-milliseconds)
[6]749  (rlet ((sockaddr :sockaddr_in))
750    (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
751          (pref sockaddr :sockaddr_in.sin_port) port-n
[10052]752          (pref sockaddr
[10685]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
[10052]755                ) host-n)
[8941]756    (%socket-connect fd sockaddr (record-length :sockaddr_in) timeout-in-milliseconds)))
[10685]757
758#-windows-target
[6]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))))
[10865]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))
[6]768 
[5826]769(defun make-tcp-stream-socket (fd &rest keys
770                                  &key remote-host
[8385]771                                  remote-port
772                                  connect-timeout
[8941]773                                  deadline
[6]774                                  &allow-other-keys)
[8941]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)))
[6]787
[5826]788(defun make-file-stream-socket (fd &rest keys
789                                   &key remote-filename
[6]790                                   &allow-other-keys)
791  (file-socket-connect fd remote-filename)
[5826]792  (apply #'make-file-socket-stream fd keys))
[6]793
794
[8603]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)
[5375]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
[6914]817                      :character-p (not (eq format :binary))
[5375]818                      :encoding (external-format-character-encoding external-format)
819                      :line-termination (external-format-line-termination external-format)
[7624]820                      :basic basic
[8603]821                      :auto-close auto-close
822                      :input-timeout input-timeout
823                      :output-timeout output-timeout
824                      :deadline deadline))))
[6]825
[8603]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)
[5375]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
[6914]851                      :character-p (not (eq format :binary))
[7624]852                      :basic basic
[8604]853                      :auto-close auto-close
854                      :input-timeout input-timeout
855                      :output-timeout output-timeout
856                      :deadline deadline))))
[6]857
858(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
[423]859  (socket-call nil "listen" (c_listen fd (or backlog 5)))
[6]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)
[423]865  (socket-call nil "listen" (c_listen fd (or backlog 5)))
[6]866  (make-instance 'file-listener-socket
867                 :device fd
868                 :keys keys))
869
[10685]870(defun socket-accept (fd wait)
[6]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)
[10685]877                      #+windows-target
878                      (= res #$WSAEWOULDBLOCK)
879                      #-windows-target
[6]880                      (or (eql res (- #$ENETDOWN))
[3809]881                          (eql res (- #+linux-target #$EPROTO
[10052]882                                      #-linux-target  #$EPROTOTYPE))
[6]883                          (eql res (- #$ENOPROTOOPT))
884                          (eql res (- #$EHOSTDOWN))
[3822]885                          (eql res (- #+linux-target #$ENONET
[10052]886                                      #-linux-target #$ENETDOWN))
[6]887                          (eql res (- #$EHOSTUNREACH))
888                          (eql res (- #$EOPNOTSUPP))
889                          (eql res (- #$ENETUNREACH))))
890               (- #$EAGAIN)
[11081]891               res))))
[6]892    (cond (wait
893            (with-eagain fd :input
894              (_accept fd *multiprocessing-socket-io*)))
895          (*multiprocessing-socket-io*
896            (_accept fd t))
897          (t
[10685]898            (let ((was-blocking (get-socket-fd-blocking fd)))
[6]899              (unwind-protect
900                  (progn
[10685]901                    (set-socket-fd-blocking fd nil)
[6]902                    (_accept fd t))
[10685]903                (set-socket-fd-blocking fd was-blocking)))))))
[6]904
[12463]905(defun accept-socket-connection (socket wait stream-create-function &optional stream-args)
[6]906  (let ((listen-fd (socket-device socket))
907        (fd -1))
908    (unwind-protect
[12463]909      (let ((keys (append stream-args (socket-keys socket))))
[10685]910        (setq fd (socket-accept listen-fd wait))
[6]911        (cond ((>= fd 0)
[12463]912               (prog1 (apply stream-create-function fd keys)
[6]913                 (setq fd -1)))
914              ((eql fd (- #$EAGAIN)) nil)
[768]915              (t (socket-error socket "accept" fd))))
[6]916      (when (>= fd 0)
917        (fd-close fd)))))
918
[12463]919(defgeneric accept-connection (socket &key wait stream-args)
[2439]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
[12463]925that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments
926may be specified using STREAM-ARGS. The original listener
[2439]927socket continues to be open listening for more connections, so you can call
928accept-connection on it again."))
929
[12463]930(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args)
931  (accept-socket-connection socket wait #'make-tcp-stream stream-args))
[6]932
[12463]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))
[6]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)))
[1966]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)
[10136]948            #+x8632-target (and (<= x8632::min-8-bit-ivector-subtag subtype)
949                                (<= subtype x8632::max-8-bit-ivector-subtag))
[3978]950            #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
951                                (<= subtype x8664::max-8-bit-ivector-subtag))
[13773]952      (report-bad-arg buf '(or (array (unsigned-byte 8))
[6]953                               (array (signed-byte 8))))))
954  (values buf offset))
955
[2439]956(defmethod send-to ((socket udp-socket) msg size
[6]957                    &key remote-host remote-port offset)
[2439]958  "Send a UDP packet over a socket."
[6]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)
[768]963                            (remote-socket-info socket :host))))
[6]964    (unless remote-port
965      (setq remote-port (or (getf (socket-keys socket) :remote-port)
[768]966                            (remote-socket-info socket :port))))
[6]967    (rlet ((sockaddr :sockaddr_in))
968      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
[10052]969      (setf (pref sockaddr
[10685]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)
[6]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)
[423]977        (socket-call socket "sendto"
[6]978          (with-eagain fd :output
979            (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in))))))))
980
[2439]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."
[6]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)
[10052]998      (setf (pref sockaddr
[10685]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)
[10052]1001            #$INADDR_ANY)
[6]1002      (setf (pref sockaddr :sockaddr_in.sin_port) 0)
1003      (setf (pref namelen :signed) (record-length :sockaddr_in))
1004      (%stack-block ((bufptr size))
[423]1005        (setq ret-size (socket-call socket "recvfrom"
[6]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)
[13773]1012                                  ((:binary) '(unsigned-byte 8))))
[6]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
[10052]1024              (ntohl (pref sockaddr
[10685]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))
[1539]1027              (ntohs (pref sockaddr :sockaddr_in.sin_port))))))
[6]1028
[2439]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)
[6]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)))
[423]1038    (socket-call socket "shutdown"
[6]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
[1539]1047        (fixnum (htons port))
[6]1048        (string (_getservbyname port proto))
1049        (symbol (_getservbyname (string-downcase (symbol-name port)) proto)))
[768]1050      (socket-error nil "getservbyname" (- #$ENOENT))))
[6]1051
[2439]1052(defun lookup-port (port proto)
1053  "Find the port number for the specified port and protocol."
[6]1054  (if (fixnump port)
1055    port
[5494]1056    (ntohs (port-as-inet-port port proto))))
[6]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
[1539]1062    (integer (htonl host))
[6]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
[768]1067                      (socket-error nil "gethostbyname" err t)))))))
[6]1068
1069
[2439]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."
[6]1073  (let ((addr (_inet_aton name)))
[1539]1074    (if addr (ntohl addr)
[6]1075      (and errorp (error "Invalid dotted address ~s" name)))))
1076   
[2439]1077(defun lookup-hostname (host)
1078  "Convert a host spec in any of the acceptable formats into a 32-bit
1079unsigned IP address."
[6]1080  (if (typep host 'integer)
1081    host
[1539]1082    (ntohl (host-as-inet-host host))))
[6]1083
[2439]1084(defun ipaddr-to-dotted (addr &key values)
1085  "Convert a 32-bit unsigned IP address into octets."
[11068]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))))
[6]1093
[2439]1094(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
1095  "Convert a 32-bit unsigned IP address into a host name string."
[6]1096  (declare (ignore ignore-cache))
[1539]1097  (multiple-value-bind (name err) (c_gethostbyaddr (htonl ipaddr))
[768]1098    (or name (socket-error nil "gethostbyaddr" err t))))
[6]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)
[768]1109        (socket-error socket "getsockopt" err)))))
[6]1110
[7978]1111(defun timeval-setsockopt (socket level optname timeout)
[8265]1112    (multiple-value-bind (seconds micros)
1113        (microseconds timeout)
1114      (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros))
[7978]1115        (socket-call socket "setsockopt"
1116          (c_setsockopt socket level optname valptr (record-length :timeval))))))
1117                   
[6]1118(defun int-setsockopt (socket level optname optval)
1119  (rlet ((valptr :signed))
1120    (setf (pref valptr :signed) optval)
[423]1121    (socket-call socket "setsockopt"
[6]1122      (c_setsockopt socket level optname valptr (record-length :signed)))))
1123
[4857]1124
[10865]1125
[4857]1126           
[10865]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               
[6]1140(defun c_gethostbyname (name)
1141  (with-cstrs ((name (string name)))
[10865]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 
[6]1158
[10109]1159 
1160
[6]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))
[10685]1172    #-windows-target
[6]1173    (rlet ((addr :in_addr))
[4828]1174      (let* ((result #+freebsd-target (#___inet_aton name addr)
1175                     #-freebsd-target (#_inet_aton name addr)))
[6]1176        (unless (eql result 0)
[10052]1177          (pref addr
1178                #-solaris-target :in_addr.s_addr
1179                #+solaris-target #>in_addr.S_un.S_addr
[10685]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)))))
[6]1187
[7624]1188(defun c_socket_1 (domain type protocol)
[10574]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)
[11081]1193                       handle)))
[6]1194
[10574]1195
1196
[7624]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
[10685]1207#-windows-target
[6]1208(defun init-unix-sockaddr (addr path)
1209  (macrolet ((sockaddr_un-path-len ()
1210               (/ (ensure-foreign-type-bits
[5559]1211                   (foreign-record-field-type 
1212                    (%find-foreign-record-type-field
1213                     (parse-foreign-type '(:struct :sockaddr_un)) :sun_path)))
[6]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)))
[10052]1219      (setf (pref addr :sockaddr_un.sun_family) #$AF_UNIX)
[5559]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))))))))
[6]1227
[10685]1228#-windows-target
[6]1229(defun bind-unix-socket (socketfd path)
1230  (rletz ((addr :sockaddr_un))
1231    (init-unix-sockaddr addr path)
1232    (socket-call
[423]1233     nil
[6]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)
[11081]1243  (check-socket-error (#_bind sockfd sockaddr addrlen)))
[6]1244
1245
[10698]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))
[11081]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)))
[10698]1264     
1265     
[8265]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>
[8941]1270(defun c_connect (sockfd addr len &optional timeout-in-milliseconds)
[10685]1271  (let* ((was-blocking (get-socket-fd-blocking sockfd)))
[8385]1272    (unwind-protect
1273         (progn
[10685]1274           (set-socket-fd-blocking sockfd nil)
[11081]1275           (let* ((err (check-socket-error (#_connect sockfd addr len))))
[10685]1276             (cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS
[10698]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)
[8385]1284                      (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
[10685]1285                      (- #+windows-target #$WSAETIMEDOUT #-windows-target #$ETIMEDOUT)))
[8385]1286                   (t err))))
[10685]1287      (set-socket-fd-blocking sockfd was-blocking))))
[8265]1288
[6]1289(defun c_listen (sockfd backlog)
[11081]1290  (check-socket-error (#_listen sockfd backlog)))
[6]1291
1292(defun c_accept (sockfd addrp addrlenp)
[10544]1293  (ignoring-eintr
[11081]1294   (check-socket-error (#_accept sockfd addrp addrlenp))))
[6]1295
1296(defun c_getsockname (sockfd addrp addrlenp)
[11081]1297  (check-socket-error (#_getsockname sockfd addrp addrlenp)))
[6]1298
1299(defun c_getpeername (sockfd addrp addrlenp)
[11081]1300  (check-socket-error (#_getpeername sockfd addrp addrlenp)))
[6]1301
[10685]1302#-windows-target
[6]1303(defun c_socketpair (domain type protocol socketsptr)
[10574]1304  (check-socket-error (#_socketpair domain type protocol socketsptr)))
[6]1305
1306
1307(defun c_sendto (sockfd msgptr len flags addrp addrlen)
[11758]1308  (ignoring-eintr (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen))))
[6]1309
1310(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp)
[11758]1311  (ignoring-eintr (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp))))
[6]1312
1313(defun c_shutdown (sockfd how)
[11081]1314  (check-socket-error (#_shutdown sockfd how)))
[6]1315
1316(defun c_setsockopt (sockfd level optname optvalp optlen)
[11081]1317  (check-socket-error (#_setsockopt sockfd level optname optvalp optlen)))
[6]1318
1319(defun c_getsockopt (sockfd level optname optvalp optlenp)
[11081]1320  (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp)))
[6]1321
[10685]1322#-windows-target
[6]1323(defun c_sendmsg (sockfd msghdrp flags)
[11081]1324  (check-socket-error (#_sendmsg sockfd msghdrp flags)))
[6]1325
[10685]1326#-windows-target
[6]1327(defun c_recvmsg (sockfd msghdrp flags)
[11081]1328  (check-socket-error   (#_recvmsg sockfd msghdrp flags)))
[6]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
[10685]1344#-(or windows-target solaris-target)
[6]1345(defun %get-ip-interfaces ()
[2036]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)))
[7732]1353               (when (and (not (%null-ptr-p addr))
1354                          (eql (pref addr :sockaddr.sa_family) #$AF_INET))
[2036]1355                 (push (make-ip-interface
[10052]1356                        :name (%get-cstring (pref q :ifaddrs.ifa_name))
[10698]1357                        :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr))
[10865]1358                        :netmask (ntohl
1359                                  (pref (pref q :ifaddrs.ifa_netmask)
1360                                       :sockaddr_in.sin_addr.s_addr))
[10109]1361                        :flags (pref q :ifaddrs.ifa_flags)
1362                        :address-family #$AF_INET)
1363                       res))))
1364        (#_freeifaddrs (pref p :address))))))
[6]1365
[10109]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    )
[6]1376
[10109]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
[10698]1424                                  :addr (ntohl address)
[10865]1425                                  :netmask (ntohl netmask)
[10109]1426                                  :flags if-flags
1427                                  :address-family address-family)
1428                                 res)))))))))
1429        (fd-close sock)))
1430    res))
1431)
1432
1433
[10865]1434
1435
1436#+windows-target
1437(defun %get-ip-interfaces ()
[12267]1438  (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
[10865]1439    (unwind-protect
[13990]1440         (rlet ((realoutlen #>DWORD 0))
1441           (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
1442                              (* 2 reservedlen)))
1443                ()
1444             (%stack-block ((buf reservedlen))
1445               (if (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               (let* ((noutbytes (pref realoutlen #>DWORD)))
1456                 (when (< noutbytes reservedlen)
1457                   (let* ((interfaces nil))
1458
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               (let* ((err (#_WSAGetLastError)))
1476                 (unless (eql err #$WSAEFAULT)
1477                   (return)))))))
[12267]1478      (#_closesocket socket))))
[10865]1479
[10109]1480     
1481
1482
[6]1483(defloadvar *ip-interfaces* ())
1484
1485(defun ip-interfaces ()
1486  (or *ip-interfaces*
1487      (setq *ip-interfaces* (%get-ip-interfaces))))
1488
1489;;; This should presumably happen after a configuration change.
1490;;; How do we detect a configuration change ?
1491(defun %reset-ip-interfaces ()
1492  (setq *ip-interfaces* ()))
1493
1494;;; Return the first non-loopback interface that's up and whose address
1495;;; family is #$AF_INET.  If no such interface exists, return
1496;;; the loopback interface.
1497(defun primary-ip-interface ()
1498  (let* ((ifaces (ip-interfaces)))
1499    (or (find-if #'(lambda (i)
1500                     (and (eq #$AF_INET (ip-interface-address-family i))
[8240]1501                          (ip-interface-addr i)
[6]1502                          (let* ((flags (ip-interface-flags i)))
1503                            (and (not (logtest #$IFF_LOOPBACK flags))
1504                                 (logtest #$IFF_UP flags)))))
1505                 ifaces)
1506        (car ifaces))))
1507
1508(defun primary-ip-interface-address ()
1509  (let* ((iface (primary-ip-interface)))
1510    (if iface
1511      (ip-interface-addr iface)
1512      (error "Can't determine primary IP interface"))))
1513         
1514         
[423]1515(defmethod stream-io-error ((stream socket) errno where)
1516  (socket-error stream where errno))
Note: See TracBrowser for help on using the repository browser.