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

Last change on this file since 8941 was 8941, checked in by gb, 12 years ago

Enforce "deadline" on active connect; ensure that any timeouts in
low-level connect code are expressed in milliseconds. Close the
fd if connection attempts fail.

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