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

Last change on this file since 15093 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

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