From: Juho Snellman Date: Fri, 2 Mar 2007 00:59:07 +0000 (+0000) Subject: 1.0.3.6: Make sb-bsd-sockets use getaddrinfo/getnameinfo where available X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=27763fafd1b170518ac2e85b9344fdddddcfd7c5;p=sbcl.git 1.0.3.6: Make sb-bsd-sockets use getaddrinfo/getnameinfo where available * Generally thread-safe functions (though not on OS X) unlike gethostbyaddr/gethostbyname. * The interfaces are not totally compatible (e.g. no aliases data available, different error codes, etc). Try to make this change as transparent as possible. * Clean up old CMUCL compability cruft * Delete the obsolete documentation generator * Add a little extra documentation on the name-service to the manual --- diff --git a/BUGS b/BUGS index 93c7c37..e68157d 100644 --- a/BUGS +++ b/BUGS @@ -886,7 +886,7 @@ WORKAROUND: strongly suspected problems, as of 0.8.3.10: please update this bug instead of creating new ones - gethostbyname, gethostbyaddr in sb-bsd-sockets + gethostbyaddr in sb-bsd-sockets 284: Thread safety: special variables There are lots of special variables in SBCL, and I feel sure that at diff --git a/NEWS b/NEWS index 934ee22..211e7fe 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,10 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.4 relative to sbcl-1.0.3: + * incompatible change: the thread-safe (on most platforms) getaddrinfo + and getnameinfo sockets functions are used instead of gethostbyaddr + and gethostbyname, on platforms where the newer functions are available. + As a result, the ALIASES field of HOST-ENT will always be NIL on these + platforms. * bug fix: >= and <= gave wrong results when used with NaNs. * bug fix: the #= and ## reader macros now interact reasonably with funcallable instances. diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index 0b80a64..96d11a1 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -33,25 +33,25 @@ ;; some of these may be linux-specific (:integer so-debug "SO_DEBUG" - "Enable debugging in underlying protocol modules") + "Enable debugging in underlying protocol modules") (:integer so-reuseaddr "SO_REUSEADDR" "Enable local address reuse") - (:integer so-type "SO_TYPE") ;get only - (:integer so-error "SO_ERROR") ;get only (also clears) + (:integer so-type "SO_TYPE") ;get only + (:integer so-error "SO_ERROR") ;get only (also clears) (:integer so-dontroute "SO_DONTROUTE" "Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address") (:integer so-broadcast "SO_BROADCAST" "Request permission to send broadcast datagrams") (:integer so-sndbuf "SO_SNDBUF") -#+linux (:integer so-passcred "SO_PASSCRED") + #+linux (:integer so-passcred "SO_PASSCRED") (:integer so-rcvbuf "SO_RCVBUF") (:integer so-keepalive "SO_KEEPALIVE" "Send periodic keepalives: if peer does not respond, we get SIGPIPE") (:integer so-oobinline "SO_OOBINLINE" "Put out-of-band data into the normal input queue when received") (:integer so-no-check "SO_NO_CHECK") -#+linux (:integer so-priority "SO_PRIORITY") + #+linux (:integer so-priority "SO_PRIORITY") (:integer so-linger "SO_LINGER" "For reliable streams, pause a while on closing when unsent messages are queued") -#+linux (:integer so-bsdcompat "SO_BSDCOMPAT") + #+linux (:integer so-bsdcompat "SO_BSDCOMPAT") (:integer so-sndlowat "SO_SNDLOWAT") (:integer so-rcvlowat "SO_RCVLOWAT") (:integer so-sndtimeo "SO_SNDTIMEO") @@ -84,6 +84,7 @@ (:integer NO-RECOVERY "NO_RECOVERY" "Non recoverable errors, FORMERR, REFUSED, NOTIMP.") (:integer NO-DATA "NO_DATA" "Valid name, no data record of requested type.") (:integer NO-ADDRESS "NO_ADDRESS" "No address, look for MX record.") + (:function h-strerror ("hstrerror" c-string (errno int))) (:integer O-NONBLOCK "O_NONBLOCK") (:integer f-getfl "F_GETFL") @@ -98,22 +99,22 @@ (:integer msg-dontroute "MSG_DONTROUTE") (:integer msg-dontwait "MSG_DONTWAIT") (:integer msg-nosignal "MSG_NOSIGNAL") -#+linux (:integer msg-confirm "MSG_CONFIRM") -#+linux (:integer msg-more "MSG_MORE") + #+linux (:integer msg-confirm "MSG_CONFIRM") + #+linux (:integer msg-more "MSG_MORE") ;; for socket-receive (:type socklen-t "socklen_t") (:type size-t "size_t") (:type ssize-t "ssize_t") - #| + #| ;;; stat is nothing to do with sockets, but I keep it around for testing ;;; the ffi glue (:structure stat ("struct stat" - (t dev "dev_t" "st_dev") - ((alien:integer 32) atime "time_t" "st_atime"))) + (t dev "dev_t" "st_dev") + ((alien:integer 32) atime "time_t" "st_atime"))) (:function stat ("stat" (integer 32) - (file-name (* t)) + (file-name (* t)) (buf (* t)))) |# (:structure protoent ("struct protoent" @@ -213,7 +214,76 @@ (addr (* t)) (len int) (af int))) -;;; should be using getaddrinfo instead? + + ;; Re-entrant gethostbyname + + #+linux + (:function gethostbyname-r ("gethostbyname_r" + int + (name c-string) + (ret (* hostent)) + (buf (* char)) + (buflen long) + (result (* (* hostent))) + (h-errnop (* int)))) + ;; getaddrinfo / getnameinfo + + #+sb-bsd-sockets-addrinfo + (:structure addrinfo ("struct addrinfo" + (integer flags "int" "ai_flags") + (integer family "int" "ai_family") + (integer socktype "int" "ai_socktype") + (integer protocol "int" "ai_protocol") + (integer addrlen "size_t""ai_addrlen") + ((* sockaddr-in) addr "struct sockaddr*" "ai_addr") + (c-string canonname "char *" "ai_canonname") + ((* t) next "struct addrinfo*" "ai_next"))) + + #+sb-bsd-sockets-addrinfo + (:function getaddrinfo ("getaddrinfo" + int + (node c-string) + (service c-string) + (hints (* addrinfo)) + (res (* (* addrinfo))))) + + #+sb-bsd-sockets-addrinfo + (:function freeaddrinfo ("freeaddrinfo" + void + (res (* addrinfo)))) + + #+sb-bsd-sockets-addrinfo + (:function gai-strerror ("gai_strerror" + c-string + (error-code int))) + + #+sb-bsd-sockets-addrinfo + (:function getnameinfo ("getnameinfo" + int + (address (* sockaddr-in)) + (address-length size-t) + (host (* char)) + (host-len size-t) + (service (* char)) + (service-len size-t) + (flags int))) + + (:integer EAI-FAMILY "EAI_FAMILY") + (:integer EAI-SOCKTYPE "EAI_SOCKTYPE") + (:integer EAI-BADFLAGS "EAI_BADFLAGS") + (:integer EAI-NONAME "EAI_NONAME") + (:integer EAI-SERVICE "EAI_SERVICE") + (:integer EAI-ADDRFAMILY "EAI_ADDRFAMILY") + (:integer EAI-NODATA "EAI_NODATA") + (:integer EAI-MEMORY "EAI_MEMORY") + (:integer EAI-FAIL "EAI_FAIL") + (:integer EAI-AGAIN "EAI_AGAIN") + (:integer EAI-SYSTEM "EAI_SYSTEM") + + (:integer NI-NAMEREQD "NI_NAMEREQD") + + ;; Socket options + (:function setsockopt ("setsockopt" int (socket int) (level int) diff --git a/contrib/sb-bsd-sockets/defpackage.lisp b/contrib/sb-bsd-sockets/defpackage.lisp index e431cf3..d0d23b8 100644 --- a/contrib/sb-bsd-sockets/defpackage.lisp +++ b/contrib/sb-bsd-sockets/defpackage.lisp @@ -7,32 +7,8 @@ (defpackage "SB-BSD-SOCKETS-INTERNAL" (:nicknames "SOCKINT") (:shadow close listen) - #+cmu (:shadowing-import-from "CL" with-array-data) - #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data) - #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL") - #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL")) - -;;; SBCL changes a lot of package prefixes. To avoid littering the -;;; code with conditionals, we use the SBCL package prefixes -;;; throughout. This means that we need to create said packages -;;; first, if we're using CMUCL - -;;; One thing that this exercise really has made clear is just how much -;;; of the alien stuff is scattered around the cmucl package space -;;; seemingly at random. Hmm. - -#+cmu -(eval-when (:compile-toplevel :load-toplevel) - (defun add-package-nickname (name nickname) - (let ((p (find-package name))) - (rename-package p (package-name p) - (cons nickname (package-nicknames name))))) - (add-package-nickname "EXT" "SB-EXT") - (add-package-nickname "ALIEN" "SB-ALIEN") - (add-package-nickname "UNIX" "SB-UNIX") - (add-package-nickname "C-CALL" "SB-C-CALL") - (add-package-nickname "KERNEL" "SB-KERNEL") - (add-package-nickname "SYSTEM" "SB-SYS")) + (:shadowing-import-from "SB-KERNEL" with-array-data) + (:use "COMMON-LISP" "SB-ALIEN" "SB-EXT" "SB-C-CALL")) (defpackage "SB-BSD-SOCKETS" (:export socket local-socket inet-socket @@ -49,6 +25,7 @@ host-ent-addresses host-ent-address host-ent-aliases host-ent-name name-service-error + getaddrinfo ;; not sure if these are really good names or not netdb-internal-error netdb-success-error @@ -84,55 +61,13 @@ arguments to fit Lisp style more closely. " )) -#|| - -

Contents

- -
    -
  1. General concepts -
  2. Methods applicable to all sockets -
  3. Socket Options -
  4. Methods applicable to a particular subclass -
      -
    1. INET-SOCKET - Internet Protocol (TCP, UDP, raw) sockets -
    2. Methods on LOCAL-SOCKET - Local-domain sockets -
    -
  5. Name resolution (DNS, /etc/hosts, &c) -
- -

General concepts

- -

Most of the functions are modelled on the BSD socket API. BSD sockets -are widely supported, portably ("portable" by Unix standards, at least) -available on a variety of systems, and documented. There are some -differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly - -

- - -|# - -(in-package :sb-bsd-sockets) - -(defmethod asdf:hyperdocumentation - ((package (eql #.*package*)) symbol kind) - (declare (ignore kind)) - (format nil "file://~A#~A" - #.(namestring - (merge-pathnames "index.html" - (or *load-pathname* *compile-file-pathname*))) - symbol)) +;;; gethostbyname/gethostbyaddr are generally not thread safe. POSIX +;;; 1003.1-2003 defines an alternative API, which is specified in the +;;; RFC to be thread-safe. If it seems to be available, use it. +;;; +;;; Unfortunately the manual page claims that these functions are not +;;; thread-safe on OS X, but they probably can't be any worse than +;;; gethostbyname and gethostbyaddr. +(let ((addr (sb-alien::find-dynamic-foreign-symbol-address "getaddrinfo"))) + (when addr + (pushnew :sb-bsd-sockets-addrinfo *features*))) diff --git a/contrib/sb-bsd-sockets/doc.lisp b/contrib/sb-bsd-sockets/doc.lisp deleted file mode 100644 index 534d61d..0000000 --- a/contrib/sb-bsd-sockets/doc.lisp +++ /dev/null @@ -1,236 +0,0 @@ -;;;; the old documentation extracted / generator for db-sockets / sb-bsd-sockets -;;;; -;;;; Not used anymore as the documentation is now integrated into the user manual, -;;;; but I didn't have heart yet to delete this. -- NS 20040801 - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext ))) -(in-package :db-doc) -;;; turn water into wine ^W^W^W lisp into HTML - -#| -OK. We need a design - -1) The aim is to document the current package, given a system. -2) The assumption is that the system is loaded; this makes it easier to -do cross-references and stuff -3) We output HTML on *standard-output* -4) Hyperlink wherever useful -5) We're allowed to intern symbols all over the place if we like - -|# - -;;; note: break badly on multiple packages - - -(defvar *symbols* nil - "List of external symbols to print; derived from parsing DEFPACKAGE form") - - -(defun worth-documenting-p (symbol) - (and symbol - (eql (symbol-package symbol) *package*) - (or (ignore-errors (find-class symbol)) - (boundp symbol) (fboundp symbol)))) - -(defun linkable-symbol-p (word) - (labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c) - (eql c #\-)))) - (and (every #'symbol-char word) - (some #'upper-case-p word) - (worth-documenting-p (find-symbol word))))) - -(defun markup-word (w) - (if (symbolp w) (setf w (princ-to-string w))) - (cond ((linkable-symbol-p w) - (format nil "~A" - w w)) - ((and (> (length w) 0) - (eql (elt w 0) #\_) - (eql (elt w (1- (length w))) #\_)) - (format nil "~A" (subseq w 1 (1- (length w))))) - (t w))) -(defun markup-space (w) - (let ((para (search (coerce '(#\Newline #\Newline) 'string) w))) - (if para - (format nil "~A

~A" - (subseq w 0 (1+ para)) - (markup-space (subseq w (1+ para) nil))) - w))) - -(defun text-markup (text) - (let ((start-word 0) (end-word 0)) - (labels ((read-word () - (setf end-word - (position-if - (lambda (x) (member x '(#\Space #\, #\. #\Newline))) - text :start start-word)) - (subseq text start-word end-word)) - (read-space () - (setf start-word - (position-if-not - (lambda (x) (member x '(#\Space #\, #\. #\Newline))) - text :start end-word )) - (subseq text end-word start-word))) - (with-output-to-string (o) - (loop for inword = (read-word) - do (princ (markup-word inword) o) - while (and start-word end-word) - do (princ (markup-space (read-space)) o) - while (and start-word end-word)))))) - - -(defun do-defpackage (form stream) - (setf *symbols* nil) - (destructuring-bind (defn name &rest options) form - (when (string-equal name (package-name *package*)) - (format stream "

Package ~A

~%" name) - (when (documentation *package* t) - (princ (text-markup (documentation *package* t)))) - (let ((exports (assoc :export options))) - (when exports - (setf *symbols* (mapcar #'symbol-name (cdr exports))))) - 1))) - -(defun do-defclass (form stream) - (destructuring-bind (defn name super slots &rest options) form - (when (interesting-name-p name) - (let ((class (find-class name))) - (format stream "

Class: ~A~%" - name name) - #+nil (format stream "

Superclasses: ~{~A ~}~%" - (mapcar (lambda (x) (text-markup (class-name x))) - (mop:class-direct-superclasses class))) - (if (documentation class 'type) - (format stream "

~A
~%" - (text-markup (documentation class 'type)))) - (when slots - (princ "

Slots:

" stream)) - t)))) - - -(defun interesting-name-p (name) - (cond ((consp name) - (and (eql (car name) 'setf) - (interesting-name-p (cadr name)))) - (t (member (symbol-name name) *symbols* :test #'string=)))) - -(defun markup-lambdalist (l) - (let (key-p) - (loop for i in l - if (eq '&key i) do (setf key-p t) - end - if (and (not key-p) (consp i)) - collect (list (car i) (markup-word (cadr i))) - else collect i))) - -(defun do-defunlike (form label stream) - (destructuring-bind (defn name lambdalist &optional doc &rest code) form - (when (interesting-name-p name) - (when (symbolp name) - (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=))) - (format stream "

(~A ~A)~A
~%" - name (string-downcase (princ-to-string name)) - (string-downcase - (format nil "~{ ~A~}" (markup-lambdalist lambdalist))) - label) - (if (stringp doc) - (format stream "

~A
~%" - (text-markup doc))) - t))) - -(defun do-defun (form stream) (do-defunlike form "Function" stream)) -(defun do-defmethod (form stream) (do-defunlike form "Method" stream)) -(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream)) -(defun do-boolean-sockopt (form stream) - (destructuring-bind (type lisp-name level c-name) form - (pushnew (symbol-name lisp-name) *symbols*) - - (do-defunlike `(defun ,lisp-name ((socket socket) argument) - ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty) - "Accessor" stream))) - -(defun do-form (form output-stream) - (cond ((not (listp form)) nil) - ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL") - (do-boolean-sockopt form output-stream)) - ((eq (car form) 'defclass) - (do-defclass form output-stream)) - ((eq (car form) 'eval-when) - (do-form (third form) output-stream)) - ((eq (car form) 'defpackage) - (do-defpackage form output-stream)) - ((eq (car form) 'defun) - (do-defun form output-stream)) - ((eq (car form) 'defmethod) - (do-defmethod form output-stream)) - ((eq (car form) 'defgeneric) - (do-defgeneric form output-stream)) - (t nil))) - -(defun do-file (input-stream output-stream) - "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM" - (let ((eof-marker (gensym))) - (if (< 0 - (loop for form = (read input-stream nil eof-marker) - until (eq form eof-marker) - if (do-form form output-stream) - count 1 #| and - do (princ "
" output-stream) |# )) - (format output-stream "
" - )))) - -(defvar *standard-sharpsign-reader* - (get-dispatch-macro-character #\# #\|)) - -(defun document-system (system &key - (output-stream *standard-output*) - (package *package*)) - "Produce HTML documentation for all files defined in SYSTEM, covering -symbols exported from PACKAGE" - (let ((*package* (find-package package)) - (*readtable* (copy-readtable)) - (*standard-output* output-stream)) - (set-dispatch-macro-character - #\# #\| - (lambda (s c n) - (if (eql (peek-char nil s t nil t) #\|) - (princ - (text-markup - (coerce - (loop with discard = (read-char s t nil t) - ;initially (princ "

") - for c = (read-char s t nil t) - until (and (eql c #\|) - (eql (peek-char nil s t nil t) #\#)) - collect c - finally (read-char s t nil t)) - 'string))) - (funcall *standard-sharpsign-reader* s c n)))) - (dolist (c (cclan:all-components 'sb-bsd-sockets)) - (when (and (typep c 'cl-source-file) - (not (typep c 'sb-bsd-sockets-system::constants-file))) - (with-open-file (in (component-pathname c) :direction :input) - (do-file in *standard-output*)))))) - -(defun start () - (with-open-file (*standard-output* "index.html" :direction :output) - (format t "SBCL BSD-Sockets API Reference~%") - (format t -" -") - (asdf:operate 'asdf:load-op 'sb-bsd-sockets) - (document-system 'sb-bsd-sockets :package :sb-bsd-sockets))) - -(start) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index 8d1d016..dfa826b 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -1,30 +1,28 @@ (in-package :sb-bsd-sockets) (defclass host-ent () - ((name :initarg :name :accessor host-ent-name) + ;; Unfortunately the docstring generator can't currently create. + ((name :initarg :name :accessor host-ent-name + :documentation "The name of the host") + ;; Deliberately not documented, since this isn't very useful, + ;; and the data isn't available when using getaddrinfo(). Unfortunately + ;; it is exported. (aliases :initarg :aliases :accessor host-ent-aliases) + ;; presently always AF_INET. Not exported. (address-type :initarg :type :accessor host-ent-address-type) - ; presently always AF_INET - (addresses :initarg :addresses :accessor host-ent-addresses)) - ;; FIXME: Our Texinfo documentation extracter need at least his to spit - ;; out the signature. Real documentation would be better... - (:documentation "")) + (addresses :initarg :addresses :accessor host-ent-addresses + :documentation "A list of addresses for this host.")) + (:documentation "This class represents the results of an address lookup.")) (defgeneric host-ent-address (host-ent) - ;; FIXME: Our Texinfo documentation extracter need at least his to spit - ;; out the signature. Real documentation would be better... - (:documentation "")) + (:documentation "Returns some valid address for HOST-ENT.")) (defmethod host-ent-address ((host-ent host-ent)) (car (host-ent-addresses host-ent))) -;(define-condition host-not-found-error (socket-error)) ; host unknown -;(define-condition no-address-error (socket-error)) ; valid name but no IP address -;(define-condition no-recovery-error (socket-error)) ; name server error -;(define-condition try-again-error (socket-error)) ; temporary - -(defun make-host-ent (h) - (if (sb-alien:null-alien h) (name-service-error "gethostbyname")) +(defun make-host-ent (h &optional errno) + (when (sb-grovel::foreign-nullp h) + (name-service-error "gethostbyname" errno)) (let* ((length (sockint::hostent-length h)) (aliases (loop for i = 0 then (1+ i) for al = (sb-alien:deref (sockint::hostent-aliases h) i) @@ -37,10 +35,7 @@ collect (ecase (sockint::hostent-type h) (#.sockint::af-inet (assert (= length 4)) - (let ((addr (make-array 4 :element-type '(unsigned-byte 8)))) - (loop for i from 0 below length - do (setf (elt addr i) (sb-alien:deref ad i))) - addr)) + (naturalize-unsigned-byte-8-array ad length)) #-win32 (#.sockint::af-local (sb-alien:cast ad sb-alien:c-string)))))) @@ -50,16 +45,30 @@ :aliases aliases :addresses addresses))) +(defun naturalize-unsigned-byte-8-array (array length) + (let ((addr (make-array 4 :element-type '(unsigned-byte 8)))) + (dotimes (i length) + (setf (elt addr i) (sb-alien:deref array i))) + addr)) + +;;; Resolving + (defun get-host-by-name (host-name) - "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition. + "Returns a HOST-ENT instance for HOST-NAME or signals a NAME-SERVICE-ERROR. HOST-NAME may also be an IP address in dotted quad notation or some other -weird stuff - see gethostbyname(3) for grisly details." +weird stuff - see gethostbyname(3) or getaddrinfo(3) for the details." + #+sb-bsd-sockets-addrinfo + (get-address-info host-name) + #-sb-bsd-sockets-addrinfo (make-host-ent (sockint::gethostbyname host-name))) (defun get-host-by-address (address) "Returns a HOST-ENT instance for ADDRESS, which should be a vector of - (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for -grisly details." + (integer 0 255), or signals a NAME-SERVICE-ERROR. See gethostbyaddr(3) + or gethostinfo(3) for details." + #+sb-bsd-sockets-addrinfo + (get-name-info address) + #-sb-bsd-sockets-addrinfo (sockint::with-in-addr packed-addr () (let ((addr-vector (coerce address 'vector))) (loop for i from 0 below (length addr-vector) @@ -69,85 +78,172 @@ grisly details." 4 sockint::af-inet))))) -;;; The remainder is my fault - gw +;;; Emulate the above two functions with getaddrinfo / getnameinfo + +#+sb-bsd-sockets-addrinfo +(defun get-address-info (node) + (sb-alien:with-alien ((res (* (* sockint::addrinfo)) :local + (sb-alien:make-alien (* sockint::addrinfo)))) + (let ((err (sockint::getaddrinfo node nil nil res))) + (if (zerop err) + (let ((host-ent (make-instance 'host-ent + :name node + :type sockint::af-inet + :aliases nil + :addresses nil))) + (loop for sap = (sb-alien:deref res) then (sockint::addrinfo-next info) + until (sb-alien::null-alien sap) + for info = (sb-alien:cast sap (* sockint::addrinfo)) + ;; Only handle AF_INET currently. + do (when (eq (sockint::addrinfo-family info) sockint::af-inet) + (let* ((sockaddr (sockint::addrinfo-addr info)) + (address (sockint::sockaddr-in-addr sockaddr))) + ;; The same effective result can be multiple time + ;; in the list, with different socktypes. Only record + ;; each address once. + (setf (host-ent-addresses host-ent) + (adjoin (naturalize-unsigned-byte-8-array address + 4) + (host-ent-addresses host-ent) + :test 'equalp))))) + (sockint::free-addrinfo (sb-alien:deref res)) + host-ent) + (addrinfo-error "getaddrinfo" err))))) + +(defconstant ni-max-host 1025) + +#+sb-bsd-sockets-addrinfo +(defun get-name-info (address) + (assert (= (length address) 4)) + (sockint::with-sockaddr-in sockaddr () + (sb-alien:with-alien ((host-buf (array char #.ni-max-host))) + (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet) + (dotimes (i 4) + (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i) + (aref address i))) + (let ((err (sockint::getnameinfo (sb-alien:alien-sap sockaddr) + (sb-alien:alien-size sockint::sockaddr-in :bytes) + (sb-alien:cast host-buf (* char)) ni-max-host + nil 0 + sockint::ni-namereqd))) + (if (zerop err) + (make-instance 'host-ent + :name (sb-alien::c-string-to-string + (sb-alien:alien-sap host-buf) + (sb-impl::default-external-format) + 'character) + :type sockint::af-inet + :aliases nil + :addresses (list address)) + (addrinfo-error "getnameinfo" err)))))) + +;;; Error handling (defvar *name-service-errno* 0 "The value of h_errno, after it's been fetched from Unix-land by calling GET-NAME-SERVICE-ERRNO") -(defun name-service-error (where) - ;; FIXME: Our Texinfo documentation extracter need at least his to spit - ;; out the signature. Real documentation would be better... - "" - (get-name-service-errno) - ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.". - ;; This special case treatment hasn't actually been tested yet. - #-win32 - (if (= *name-service-errno* sockint::NETDB-INTERNAL) - (socket-error where) - (let ((condition - (condition-for-name-service-errno *name-service-errno*))) - (error condition :errno *name-service-errno* :syscall where)))) +(defun name-service-error (where &optional errno) + ;; There was a dummy docstring here for the texinfo extractor, but I + ;; see no reason for this to be documented in the manual, and removed + ;; it. -- JES + (let ((*name-service-errno* (get-name-service-errno errno))) + ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.". + ;; This special case treatment hasn't actually been tested yet. + #-win32 + (if (= *name-service-errno* sockint::NETDB-INTERNAL) + (socket-error where) + (let ((condition + (condition-for-name-service-errno *name-service-errno*))) + (error condition :errno *name-service-errno* :syscall where))))) + +(defun addrinfo-error (where error-code) + (let ((condition (condition-for-name-service-error-code error-code))) + (error condition :error-code error-code :syscall where))) (define-condition name-service-error (condition) - ((errno :initform nil - :initarg :errno - :reader name-service-error-errno) + ((errno :initform nil :initarg :errno :reader name-service-error-errno) + (error-code :initform nil :initarg :error-code + :reader name-service-error-error-code) (symbol :initform nil :initarg :symbol :reader name-service-error-symbol) (syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall)) (:report (lambda (c s) - (let ((num (name-service-error-errno c))) + (let* ((errno (name-service-error-errno c)) + (error-code (name-service-error-error-code c))) (format s "Name service error in \"~A\": ~A (~A)" (name-service-error-syscall c) (or (name-service-error-symbol c) - (name-service-error-errno c)) - (get-name-service-error-message num)))))) + errno + error-code) + (get-name-service-error-message errno error-code)))))) -(defmacro define-name-service-condition (symbol name) +(defparameter *conditions-for-name-service-errno* nil) +;; getaddrinfo and getnameinfo return an error code, rather than using +;; h_errno. While on Linux there's no overlap between their possible +;; values, this doesn't seem to be guaranteed on all systems. +(defparameter *conditions-for-name-service-error-code* nil) + +;; Define a special name-service-error for variour error cases, and associate +;; them with the matching h_errno / error code. +(defmacro define-name-service-condition (errno-symbol error-code-symbol name) `(progn (define-condition ,name (name-service-error) - ((symbol :reader name-service-error-symbol :initform (quote ,symbol)))) - (push (cons ,symbol (quote ,name)) *conditions-for-name-service-errno*))) - -(defparameter *conditions-for-name-service-errno* nil) + ((errno-symbol :reader name-service-error-errno-symbol + :initform (quote ,errno-symbol)) + (error-code-symbol :reader name-service-error-error-code-symbol + :initform (quote ,error-code-symbol)))) + (push (cons ,errno-symbol (quote ,name)) + *conditions-for-name-service-errno*) + #+sb-bsd-sockets-addrinfo + (push (cons ,error-code-symbol (quote ,name)) + *conditions-for-name-service-error-code*))) #-win32 -(define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error) +(define-name-service-condition + sockint::NETDB-INTERNAL + nil ;; Doesn't map directly to any getaddrinfo error code + netdb-internal-error) #-win32 -(define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error) -(define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error) -(define-name-service-condition sockint::TRY-AGAIN try-again-error) -(define-name-service-condition sockint::NO-RECOVERY no-recovery-error) -;; this is the same as the next one -;;(define-name-service-condition sockint::NO-DATA no-data-error) -(define-name-service-condition sockint::NO-ADDRESS no-address-error) +(define-name-service-condition + sockint::NETDB-SUCCESS + nil ;; Doesn't map directly to any getaddrinfo error code + netdb-success-error) +(define-name-service-condition + sockint::HOST-NOT-FOUND + sockint::EAI-NONAME + host-not-found-error) +(define-name-service-condition + sockint::TRY-AGAIN + sockint::EAI-AGAIN + try-again-error) +(define-name-service-condition + sockint::NO-RECOVERY + sockint::EAI-FAIL + no-recovery-error) +(define-name-service-condition + sockint::NO-ADDRESS ;; Also defined as NO-DATA, with the same value + sockint::EAI-NODATA + no-address-error) (defun condition-for-name-service-errno (err) (or (cdr (assoc err *conditions-for-name-service-errno* :test #'eql)) - 'name-service)) + 'name-service-error)) -(defun get-name-service-errno () +(defun condition-for-name-service-error-code (err) + (or (cdr (assoc err *conditions-for-name-service-error-code* :test #'eql)) + 'name-service-error)) + +(defun get-name-service-errno (&optional errno) (setf *name-service-errno* - (sb-alien:alien-funcall - #-win32 - (sb-alien:extern-alien "get_h_errno" (function integer)) - #+win32 - (sb-alien:extern-alien "WSAGetLastError" (function integer))))) - -#-(and cmu solaris) -(progn - #+(and sbcl (not win32)) - (sb-alien:define-alien-routine "hstrerror" - sb-c-call:c-string - (errno integer)) - #+cmu - (alien:def-alien-routine "hstrerror" - sb-c-call:c-string - (errno integer)) - (defun get-name-service-error-message (num) - (hstrerror num)) -) - -;;; placeholder for hstrerror on windows -#+(and sbcl win32) -(defun hstrerror () 0) + (or errno + (sb-alien:alien-funcall + #-win32 + (sb-alien:extern-alien "get_h_errno" (function integer)) + #+win32 + (sb-alien:extern-alien "WSAGetLastError" (function integer)))))) + +(defun get-name-service-error-message (errno error-code) + #-win32 + (if errno + (sockint::h-strerror errno) + (sockint::gai-strerror error-code))) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.texinfo b/contrib/sb-bsd-sockets/sb-bsd-sockets.texinfo index ad85a60..760c5f0 100644 --- a/contrib/sb-bsd-sockets/sb-bsd-sockets.texinfo +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.texinfo @@ -151,14 +151,16 @@ across a network. @node Name Service @section Name Service -Presently name service is implemented by calling whatever -@code{gethostbyname(2)} uses. This may be any or all of -@file{/etc/hosts}, NIS, DNS, or something completely different. -Typically it's controlled by @file{/etc/nsswitch.conf}. - -Direct links to the asynchronous @code{resolver(3)} routines would be -nice to have eventually, so that we can do DNS lookups in parallel -with other things +Presently name service is implemented by calling out to the +@code{getaddrinfo(3)} and @code{gethostinfo(3)}, or to +@code{gethostbyname(3)} @code{gethostbyaddr(3)} on platforms where +the preferred functions are not available. The exact details of +the name resolving process (for example the choice of whether +DNS or a hosts file is used for lookup) are platform dependent. + +@c Direct links to the asynchronous @code{resolver(3)} routines would be +@c nice to have eventually, so that we can do DNS lookups in parallel +@c with other things. @include class-sb-bsd-sockets-host-ent.texinfo @@ -167,5 +169,3 @@ with other things @include fun-sb-bsd-sockets-get-host-by-address.texinfo @include fun-sb-bsd-sockets-host-ent-address.texinfo - -@include fun-sb-bsd-sockets-name-service-error.texinfo diff --git a/version.lisp-expr b/version.lisp-expr index 83360b1..4bcf678 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.3.5" +"1.0.3.6"