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

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

SOCKET-ERRORs from failed connection attempts report remote address.
Fixes ticket:941.

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