sockets/resolv.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; resolv.lisp --- Host, protocol and service lookups.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 (define-constant +max-ipv4-value+ (1- (expt 2 32))
  27   :documentation "Integer denoting 255.255.255.255")
  28
  29 ;;;; Host Lookup
  30
  31 (defun get-address-info (&key (node (null-pointer)) (service (null-pointer))
  32                          (hint-flags 0) (hint-family 0)
  33                          (hint-type 0) (hint-protocol 0))
  34   (with-foreign-objects ((hints 'addrinfo)
  35                          (res :pointer))
  36     (bzero hints size-of-addrinfo)
  37     (with-foreign-slots ((flags family socktype
  38                           protocol)
  39                          hints addrinfo)
  40       (setf flags    hint-flags
  41             family   hint-family
  42             socktype hint-type
  43             protocol hint-protocol)
  44       (getaddrinfo node service hints res)
  45       (make-pointer (pointer-address (mem-ref res :pointer))))))
  46
  47 (defun get-name-info (sockaddr &key (want-host t) want-service (flags 0))
  48   (assert (or want-host want-service))
  49   (let ((salen size-of-sockaddr-storage))
  50     (with-foreign-objects ((host :char ni-maxhost)
  51                            (service :char ni-maxserv))
  52       (getnameinfo sockaddr salen
  53                    host (if want-host ni-maxhost 0)
  54                    service (if want-service ni-maxserv 0)
  55                    flags)
  56       (values (and want-host (foreign-string-to-lisp
  57                               host #|:count ni-maxhost|#))
  58               (and want-service (foreign-string-to-lisp
  59                                  service #|:count ni-maxserv|#))))))
  60
  61 (defclass host ()
  62   ((truename :initarg :truename  :reader host-truename
  63              :documentation "The name of the host.")
  64    (aliases :initarg :aliases   :reader host-aliases
  65             :documentation "A list of aliases.")
  66    (addresses :initarg :addresses :reader host-addresses
  67               :documentation "A list of addresses."))
  68   (:documentation "Class representing a host: name, aliases and addresses."))
  69
  70 (defmethod initialize-instance :after ((host host) &key)
  71   (with-slots (addresses) host
  72     (setf addresses (alexandria:ensure-list addresses))))
  73
  74 (defun host-random-address (host)
  75   "Returns a random address from HOST's address list."
  76   (alexandria:random-elt (host-addresses host)))
  77
  78 (defun make-host (truename addresses &optional aliases)
  79   "Instantiates a HOST object."
  80   (make-instance 'host
  81                  :truename truename
  82                  :aliases aliases
  83                  :addresses addresses))
  84
  85 (defmethod print-object ((host host) stream)
  86   (print-unreadable-object (host stream :type t :identity nil)
  87     (with-slots (truename aliases addresses) host
  88       (format stream "Canonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~].~%~
  89                       Addresses: ~{~A~^, ~}"
  90               truename aliases addresses))))
  91
  92 ;;;; Auxiliary Functions
  93
  94 (defun lookup-host-u8-vector-4 (host ipv6)
  95   (coercef host 'ub8-sarray)
  96   (ecase ipv6
  97     ((nil)
  98      ;; Darwin's getnameinfo() seems buggy.  Signals a EAI_FAMILY
  99      ;; error on test LOOKUP-HOST.4.  We use gethostbyaddr() here
 100      ;; instead as a workaround.  FIXME: handle errors properly.
 101      #+darwin
 102      (with-foreign-object (addr 'in-addr-struct)
 103        (setf (foreign-slot-value addr 'in-addr-struct 'addr)
 104              (htonl (vector-to-integer host)))
 105        (let ((ptr (gethostbyaddr addr 4 af-inet)))
 106          (if (null-pointer-p ptr)
 107              (resolver-error -1 :data host)
 108              (make-host (foreign-slot-value
 109                          ptr 'hostent 'name)
 110                         (list (make-address (copy-seq host)))))))
 111      #-darwin
 112      (with-foreign-object (sin 'sockaddr-storage)
 113        (make-sockaddr-in sin host)
 114        (make-host (get-name-info sin :flags ni-namereqd)
 115                   (list (make-address (copy-seq host))))))
 116     ((t)
 117      (with-foreign-object (sin6 'sockaddr-storage)
 118        (let ((ipv6addr (map-ipv4-vector-to-ipv6 host)))
 119          (make-sockaddr-in6 sin6 ipv6addr)
 120          (make-host (get-name-info sin6 :flags ni-namereqd)
 121                     (list (make-address ipv6addr))))))
 122     ((:ipv6)
 123      (resolver-error
 124       :eai-fail :data host
 125       :message "Received IPv4 address but IPv6-only was requested."))))
 126
 127 (defun lookup-host-u16-vector-8 (host ipv6)
 128   (coercef host 'ub16-sarray)
 129   (ecase ipv6
 130     ((nil)
 131      (resolver-error
 132       :eai-fail :data host
 133       :message "Received IPv6 address but IPv4-only was requested."))
 134     ((:ipv6 t)
 135      (with-foreign-object (sin6 'sockaddr-storage)
 136        (make-sockaddr-in6 sin6 host)
 137        (make-host (get-name-info sin6 :flags ni-namereqd)
 138                   (list (make-address (copy-seq host))))))))
 139
 140 (defun make-host-from-addrinfo (addrinfo)
 141   (let ((canonname (foreign-slot-value
 142                     addrinfo 'addrinfo 'canonname))
 143         (addrlist
 144          (loop :for addrptr := addrinfo
 145                :then (foreign-slot-value addrptr 'addrinfo 'next)
 146                :while (not (null-pointer-p addrptr))
 147                :collect (sockaddr-storage->sockaddr
 148                         (foreign-slot-value
 149                          addrptr 'addrinfo 'addr)))))
 150     (make-host (if (null-pointer-p canonname)
 151                    nil
 152                    (foreign-string-to-lisp canonname))
 153                addrlist)))
 154
 155 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
 156   (declare (type host hostobj))
 157   (with-slots (addresses) hostobj
 158     (setf addresses
 159           (mapcar (lambda (address)
 160                     (if (ipv4-address-p address)
 161                         (make-address (map-ipv4-vector-to-ipv6
 162                                        (address-name address)))
 163                         address))
 164                   addresses)))
 165   hostobj)
 166
 167 ;;;; External Interface
 168
 169 (defgeneric lookup-host (name-or-address &key ipv6)
 170   (:documentation "Looks up a host by name or address.  IPV6
 171 determines the IPv6 behaviour, defaults to *IPV6*."))
 172
 173 (defmethod lookup-host ((host string) &key (ipv6 *ipv6*))
 174   (check-type ipv6 (member nil :ipv6 t) "valid IPv6 configuration")
 175   (flet ((decide-family-and-flags ()
 176            (case ipv6
 177              ((nil) (values af-inet 0))
 178              ;; freebsd 6.1 rejects AI_V4MAPPED and AI_ALL (weird thing)
 179              ;; therefore I'll use AF_UNSPEC and do the mappings myself
 180              ((t) #-(or windows bsd) (values af-inet6
 181                                              (logior ai-v4mapped ai-all))
 182                   #+(or windows bsd) (values af-unspec 0))
 183              (:ipv6 (values af-inet6 0)))))
 184     (multiple-value-bind (vector type) (address-to-vector host)
 185       (case type
 186         (:ipv4 (lookup-host-u8-vector-4 vector ipv6))
 187         (:ipv6 (lookup-host-u16-vector-8 vector ipv6))
 188         (t (multiple-value-bind (family flags)
 189                (decide-family-and-flags)
 190              #-windows (setf flags (logior flags ai-canonname ai-addrconfig))
 191              (let* ((addrinfo (get-address-info
 192                                :node host
 193                                :hint-flags flags
 194                                :hint-family family
 195                                :hint-type sock-stream
 196                                :hint-protocol ipproto-ip))
 197                     (hostobj (make-host-from-addrinfo addrinfo)))
 198                (when (string-not-equal (host-truename hostobj) host)
 199                  (setf (slot-value hostobj 'aliases) (list host)))
 200                (freeaddrinfo addrinfo)
 201                ;; mapping IPv4 addresses onto IPv6
 202                #+bsd
 203                (when (eq ipv6 t)
 204                  (map-host-ipv4-addresses-to-ipv6 hostobj))
 205                (values hostobj))))))))
 206
 207 ;;; FIXME: Doesn't return aliases, why?
 208 (defmethod lookup-host (host &key (ipv6 *ipv6*))
 209   (check-type ipv6 (member nil :ipv6 t) "valid IPv6 configuration")
 210   (multiple-value-bind (vector type) (address-to-vector host)
 211     (case type
 212       (:ipv4 (lookup-host-u8-vector-4 vector ipv6))
 213       (:ipv6 (lookup-host-u16-vector-8 vector ipv6))
 214       ;; better error?
 215       (t (error 'parse-error)))))
 216
 217 (defun convert-or-lookup-inet-address (address &optional (ipv6 *ipv6*))
 218   "If ADDRESS is an inet-address designator, it is converted, if
 219 necessary, to an INET-ADDRESS object and returned.  Otherwise it
 220 is assumed to be a host name which is then looked up in order to
 221 return its primary address as the first return value and the
 222 remaining address list as the second return value."
 223   (or (ignore-errors (ensure-address address :internet))
 224       (let ((addresses (host-addresses (lookup-host address :ipv6 ipv6))))
 225         (values (car addresses) (cdr addresses)))))
 226
 227 ;;;; Service Lookup
 228
 229 (defclass service ()
 230   ((name :initarg :name :reader service-name
 231          :documentation "The service name.")
 232    (port :initarg :port :reader service-port
 233           :documentation "The service's default port.")
 234    ;; why only these keyword? --luis
 235    (protocol :initarg :protocol :reader service-protocol
 236              :documentation "The service's protocol, :TCP or :UDP."))
 237   (:documentation "Class representing a service."))
 238
 239 (defun make-service (name port protocol)
 240   "Constructor for SERVICE objects."
 241   (make-instance 'service :name name :port port :protocol protocol))
 242
 243 (defmethod print-object ((service service) stream)
 244   (print-unreadable-object (service stream :type t :identity nil)
 245     (with-slots (name port protocol) service
 246       (format stream "Name: ~A Port: ~A Protocol: ~A" name port protocol))))
 247
 248 #+darwin
 249 (defun %get-service-name (port protocol)
 250   (let ((ptr (getservbyport port (ecase protocol
 251                                    (:tcp "tcp")
 252                                    (:udp "udp")
 253                                    (:any (cffi:null-pointer))))))
 254     (if (null-pointer-p ptr)
 255         (resolver-error -1 :data port) ; FIXME: wrong error
 256         (foreign-slot-value ptr 'servent 'name ))))
 257
 258 #-darwin
 259 (defun %get-service-name (port-arg protocol)
 260   (with-foreign-object (sin 'sockaddr-in)
 261     (bzero sin size-of-sockaddr-in)
 262     (with-foreign-slots
 263         ((family port) sin sockaddr-in)
 264       (setf family af-inet
 265             port (htons port-arg)))
 266     (nth-value 1 (get-name-info sin
 267                                 :flags (case protocol
 268                                          (:udp ni-dgram)
 269                                          (t 0))
 270                                 :want-host nil :want-service t))))
 271
 272 (defun lookup-service-number (port-number protocol)
 273   (declare (type ub32 port-number))
 274   (let ((service (%get-service-name port-number protocol)))
 275     (make-service service port-number protocol)))
 276
 277 (defun lookup-service-name (port protocol)
 278   (flet ((protocol-type-to-int (protocol)
 279            (case protocol
 280              (:tcp sock-stream)
 281              (:udp sock-dgram)
 282              (:any 0)))
 283          (socket-type-from-int (alien-val)
 284            (case alien-val
 285              (#.sock-stream :tcp)
 286              (#.sock-dgram :udp)
 287              (t :unknown))))
 288     (let* ((addrinfo (get-address-info
 289                       :service port
 290                       :hint-type (protocol-type-to-int protocol)))
 291            (port-number (ntohs (foreign-slot-value
 292                                 (foreign-slot-value addrinfo
 293                                                     'addrinfo 'addr)
 294                                 'sockaddr-in 'port)))
 295            (true-protocol
 296             (socket-type-from-int
 297              (foreign-slot-value addrinfo 'addrinfo 'socktype))))
 298       (freeaddrinfo addrinfo)
 299       (make-service port port-number true-protocol))))
 300
 301 ;;; This tries to parse stuff like "22" as a number instead of a
 302 ;;; protocol name.  Why bother?  If it does matter, then we should
 303 ;;; document this behaviour. --luis
 304 ;;;
 305 ;;; Hmm, changing the protocol argument to &OPTIONAL might have not
 306 ;;; been a great idea on my part. --luis
 307 (defun lookup-service (port-or-name &optional (protocol :tcp))
 308   "Lookup a service by port or name.  PROTOCOL should be one
 309 of :TCP, :UDP or :ANY."
 310   (check-type protocol (member :tcp :udp :any))
 311   (let ((parsed-number (parse-number-or-nil port-or-name :ub16)))
 312     (if
 313         (lookup-service-number parsed-number protocol)
 314         (lookup-service-name port-or-name protocol))))
 315
 316 ;;;; Protocol Lookup
 317
 318 (defclass protocol ()
 319   ((name :initarg :name :reader protocol-name
 320          :documentation "The protocol's primary name.")
 321    (aliases :initarg :aliases :reader protocol-aliases
 322             :documentation "A list of aliases for this protocol.")
 323    (number :initarg :number :reader protocol-number
 324            :documentation "The protocol number."))
 325   (:documentation "Class representing a protocol."))
 326
 327 (defun make-protocol (name number &optional aliases)
 328   "Constructor for PROTOCOL objects."
 329   (make-instance 'protocol :name name :number number :aliases aliases))
 330
 331 (defmethod print-object ((protocol protocol) stream)
 332   (print-unreadable-object (protocol stream :type t :identity nil)
 333     (with-slots (name aliases protonum) protocol
 334       (format stream "Name: ~S Protocol number: ~A Aliases: ~{~S~^, ~}"
 335               name protonum aliases))))
 336
 337 (define-condition unknown-protocol (system-error)
 338   ((name :initarg :name :initform nil :reader protocol-name))
 339   (:report (lambda (condition stream)
 340              (format stream "Unknown protocol: ~S" (protocol-name condition))))
 341   (:documentation "Condition raised when a network protocol is not found."))
 342
 343 (defun make-protocol-from-protoent (protoent)
 344   (with-foreign-slots ((name proto aliases)
 345                        protoent protoent)
 346     (let ((alias-strings
 347            (loop :for i :from 0
 348                  :for alias := (mem-aref aliases :string i)
 349                  :while alias :collect alias)))
 350       (make-protocol name proto alias-strings))))
 351
 352 ;;; Again, why bother parsing numbers in strings? --luis
 353 (defun lookup-protocol (name-or-number)
 354   "Lookup a protocol by name or number.  Signals an
 355 UNKNOWN-PROTOCOL error if no protocol is found."
 356   (let ((parsed-number (parse-number-or-nil name-or-number)))
 357     (handler-case
 358         (make-protocol-from-protoent
 359          (if parsed-number
 360              (getprotobynumber parsed-number)
 361              (getprotobyname name-or-number)))
 362       (posix-error ()
 363         (error 'unknown-protocol :name name-or-number)))))