sockets/resolv.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;;                     ;;;
  26 ;;; RESOLVER CONDITIONS ;;;
  27 ;;;                     ;;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29
  30 (define-constant +resolver-error-map+
  31   `((:eai-again      . resolver-again-error)
  32     (:eai-fail       . resolver-fail-error)
  33     (:eai-noname     . resolver-no-name-error)
  34     (:eai-nodata     . resolver-no-name-error)
  35     (:eai-addrfamily . resolver-no-name-error)
  36     (:eai-service    . resolver-no-service-error)))
  37
  38 (defun resolver-error-condition (id)
  39   (cdr (assoc id +resolver-error-map+)))
  40
  41 (defmacro resolver-error-code (id)
  42   `(addrerr-value ,id))
  43
  44 (define-condition resolver-error (system-error)
  45   ((data :initarg :data :reader resolver-error-data))
  46   (:documentation "Signaled when an error occurs while trying to resolve an address."))
  47
  48 (defmacro define-resolver-error (name code identifier format-string &optional documentation)
  49   `(progn
  50      (export ',name)
  51      (define-condition ,name (resolver-error)
  52        ((code :initform ,code)
  53         (identifier :initform ,identifier))
  54        (:report (lambda (condition stream)
  55                   (format stream ,format-string (resolver-error-data condition))
  56                   (print-message-if-not-null condition stream)))
  57        (:documentation ,documentation))))
  58
  59 (define-resolver-error resolver-again-error (resolver-error-code :eai-again) :resolver-again
  60   "Temporary failure occurred while resolving: ~S"
  61   "Condition signaled when a temporary failure occurred.")
  62
  63 (define-resolver-error resolver-fail-error (resolver-error-code :eai-fail) :resolver-fail
  64   "Non recoverable error occurred while resolving: ~S"
  65   "Condition signaled when a non-recoverable error occurred.")
  66
  67 (define-resolver-error resolver-no-name-error (resolver-error-code :eai-noname) :resolver-no-name
  68   "Host or service not found: ~S"
  69   "Condition signaled when a host or service was not found.")
  70
  71 (define-resolver-error resolver-no-service-error (resolver-error-code :eai-service) :resolver-no-service
  72   "Service not found for specific socket type: ~S"
  73   "Condition signaled when a service was not found for the socket type requested.")
  74
  75 (define-resolver-error resolver-unknown-error 0 :resolver-unknown
  76   "Unknown error while resolving: ~S"
  77   "Condition signaled when an unknown error is signaled while resolving an address.")
  78
  79 (defun resolver-error (identifier &key data message)
  80   (let ((condition-class
  81          (resolver-error-condition identifier)))
  82     (if condition-class
  83         (error condition-class
  84                :code (resolver-error-code identifier)
  85                :identifier identifier
  86                :data data
  87                :message message)
  88         (error 'resolver-unknown-error
  89                :code (or (ignore-errors
  90                            (resolver-error-code identifier))
  91                          0)
  92                :identifier identifier
  93                :data data
  94                :message message))))
  95
  96 (define-constant +max-ipv4-value+ (1- (expt 2 32)))
  97
  98
  99 ;;;;;;;;;;;;;;;;;;;;
 100 ;;;;;;;;;;;;;;;;;;;;
 101 ;;;              ;;;
 102 ;;;  HOST LOOKUP ;;;
 103 ;;;              ;;;
 104 ;;;;;;;;;;;;;;;;;;;;
 105 ;;;;;;;;;;;;;;;;;;;;
 106
 107 (defun get-address-info (&key (node (null-pointer)) (service (null-pointer))
 108                          (hint-flags 0) (hint-family 0)
 109                          (hint-type 0) (hint-protocol 0))
 110   (with-foreign-objects ((hints 'et:addrinfo)
 111                          (res :pointer))
 112     (et:bzero hints et:size-of-addrinfo)
 113     (with-foreign-slots ((et:flags et:family et:socktype et:protocol)
 114                          hints et:addrinfo)
 115       (setf et:flags hint-flags)
 116       (setf et:family hint-family)
 117       (setf et:socktype hint-type)
 118       (setf et:protocol hint-protocol)
 119       (et:getaddrinfo node service hints res)
 120       (make-pointer (pointer-address (mem-ref res :pointer))))))
 121
 122 (defun get-name-info (sockaddr &key (want-host t) want-service (flags 0))
 123   (assert (or want-host want-service))
 124   (let ((salen et:size-of-sockaddr-storage))
 125     (with-foreign-objects ((host :char et:ni-maxhost)
 126                            (service :char et:ni-maxserv))
 127       (et:getnameinfo sockaddr salen
 128                       host (if want-host et:ni-maxhost 0)
 129                       service (if want-service et:ni-maxserv 0)
 130                       flags)
 131       (values (and want-host (foreign-string-to-lisp host et:ni-maxhost))
 132               (and want-service (foreign-string-to-lisp service et:ni-maxserv))))))
 133
 134 (defclass host ()
 135   ((truename  :initarg :truename  :reader host-truename)
 136    (aliases   :initarg :aliases   :reader host-aliases)
 137    (addresses :initarg :addresses :reader host-addresses)))
 138
 139 (defmethod initialize-instance :after ((host host) &key)
 140   (with-slots (addresses) host
 141     (unless (consp addresses)
 142       (setf addresses (list addresses)))))
 143
 144 (defgeneric random-address (host))
 145 (defmethod random-address ((host host))
 146   (with-slots (addresses) host
 147     (nth (random (length addresses))
 148          addresses)))
 149
 150 (defun make-host (truename addresses &optional aliases)
 151   (make-instance 'host
 152                  :truename truename
 153                  :aliases aliases
 154                  :addresses addresses))
 155
 156 (defmethod print-object ((host host) stream)
 157   (print-unreadable-object (host stream :type t :identity nil)
 158     (with-slots (truename aliases addresses) host
 159       (format stream "Cannonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~].~%Addresses: ~{~A~^, ~}"
 160               truename aliases addresses))))
 161
 162
 163 ;;
 164 ;; Error management
 165 ;;
 166
 167 (defun lookup-host-u8-vector-4 (host ipv6)
 168   (setf host (coerce host '(simple-array ub8 (4))))
 169
 170   (handler-case
 171       (ecase ipv6
 172         ((nil)
 173          (with-foreign-object (sin 'et:sockaddr-storage)
 174            (make-sockaddr-in sin host)
 175            (return-from lookup-host-u8-vector-4
 176              (make-host (get-name-info sin :flags et:ni-namereqd)
 177                         (list (make-address (copy-seq host)))))))
 178
 179         ((t)
 180          (with-foreign-object (sin6 'et:sockaddr-storage)
 181            (let ((ipv6addr (map-ipv4-vector-to-ipv6 host)))
 182              (make-sockaddr-in6 sin6 ipv6addr)
 183              (return-from lookup-host-u8-vector-4
 184                (make-host (get-name-info sin6 :flags et:ni-namereqd)
 185                           (list (make-address ipv6addr)))))))
 186         ((:ipv6)
 187          (resolver-error :eai-fail
 188                          :data host
 189                          :message "Received IPv4 address but IPv6-only was requested.")))
 190     (et:resolv-error (err)
 191       (resolver-error (et:system-error-identifier err) :data host))))
 192
 193 (defun lookup-host-u16-vector-8 (host ipv6)
 194   (setf host (coerce host '(simple-array ub16 (8))))
 195
 196   (handler-case
 197       (ecase ipv6
 198         ((nil)
 199          (resolver-error :eai-fail
 200                          :data host
 201                          :message "Received IPv6 address but IPv4-only was requested."))
 202
 203         ((:ipv6 t)
 204          (with-foreign-object (sin6 'et:sockaddr-storage)
 205            (make-sockaddr-in6 sin6 host)
 206            (return-from lookup-host-u16-vector-8
 207              (make-host (get-name-info sin6 :flags et:ni-namereqd)
 208                         (list (make-address (copy-seq host))))))))
 209     (et:resolv-error (err)
 210       (resolver-error (et:system-error-identifier err) :data host))))
 211
 212 (defun make-host-from-addrinfo (addrinfo)
 213   (let ((canonname (foreign-slot-value addrinfo 'et:addrinfo 'et:canonname))
 214         (addrlist
 215          (loop
 216             :for addrptr := addrinfo
 217                          :then (foreign-slot-value addrptr 'et:addrinfo 'et:next)
 218             :while (not (null-pointer-p addrptr))
 219             :collect (sockaddr-storage->sockaddr
 220                       (foreign-slot-value addrptr 'et:addrinfo 'et:addr)))))
 221     (make-host (if (null-pointer-p canonname)
 222                    nil
 223                    (foreign-string-to-lisp canonname))
 224                addrlist)))
 225
 226 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
 227   (declare (type host hostobj))
 228   (with-slots (addresses) hostobj
 229     (setf addresses
 230           (mapcar #'(lambda (address)
 231                       (if (ipv4-address-p address)
 232                           (make-address (map-ipv4-vector-to-ipv6 (name address)))
 233                           address))
 234                   addresses)))
 235   hostobj)
 236
 237 (defgeneric lookup-host (host &key &allow-other-keys))
 238
 239 (defmethod lookup-host :before (host &key (ipv6 *ipv6*))
 240   (check-type ipv6 (member nil :ipv6 t) "valid IPv6 configuration"))
 241
 242 (defmethod lookup-host ((host string) &key (ipv6 *ipv6*))
 243   (flet ((decide-family-and-flags ()
 244            (ecase ipv6
 245              ((nil) (values et:af-inet 0))
 246              ;; the freebsd I use rejects AI_V4MAPPED and AI_ALL(weird thing)
 247              ;; therefore I'll use AF_UNSPEC and do the mappings myself
 248              ((t)   (values
 249                      #-freebsd et:af-inet6
 250                      #+freebsd et:af-unspec
 251                      #+freebsd 0
 252                      #-freebsd
 253                      (logior et:ai-v4mapped
 254                              #+freebsd et:ai-v4mapped-cfg
 255                              et:ai-all)))
 256              (:ipv6 (values et:af-inet6 0)))))
 257
 258     (let (parsed)
 259       (cond
 260         ((setf parsed (dotted-to-vector host :errorp nil))
 261          (return-from lookup-host
 262            (lookup-host-u8-vector-4 parsed ipv6)))
 263
 264         ((setf parsed (colon-separated-to-vector host :errorp nil))
 265          (return-from lookup-host
 266            (lookup-host-u16-vector-8 parsed ipv6)))
 267
 268         ;; FIXME: check for ASCII-only strings or implement IDN
 269         (t
 270          (multiple-value-bind (family flags)
 271              (decide-family-and-flags)
 272            (setf flags (logior flags et:ai-canonname et:ai-addrconfig))
 273            (handler-case
 274                (let* ((addrinfo
 275                        (get-address-info :node host
 276                                          :hint-flags flags
 277                                          :hint-family family
 278                                          :hint-type et:sock-stream
 279                                          :hint-protocol et:ipproto-ip))
 280                       (hostobj (make-host-from-addrinfo addrinfo)))
 281                  (when (string-not-equal (host-truename hostobj)
 282                                          host)
 283                    (setf (slot-value hostobj 'aliases) (list host)))
 284                  (et:freeaddrinfo addrinfo)
 285                  ;; mapping IPv4 addresses onto IPv6
 286                  #+freebsd
 287                  (when (eql ipv6 t)
 288                    (map-host-ipv4-addresses-to-ipv6 hostobj))
 289                  (return-from lookup-host hostobj))
 290              (et:resolv-error (err)
 291                (resolver-error (et:system-error-identifier err) :data host)))))))))
 292
 293 (defmethod lookup-host ((host ipv4addr) &key (ipv6 *ipv6*))
 294   (lookup-host-u8-vector-4 (name host) ipv6))
 295
 296 (defmethod lookup-host ((host ipv6addr) &key (ipv6 *ipv6*))
 297   (lookup-host-u16-vector-8 (name host) ipv6))
 298
 299 (defmethod lookup-host (host &key (ipv6 *ipv6*))
 300   (etypecase host
 301     ((simple-array * (4)) ; IPv4 address
 302      (lookup-host-u8-vector-4 host ipv6))
 303
 304     ((simple-array * (8)) ; IPv6 address
 305      (lookup-host-u16-vector-8 host ipv6))))
 306
 307
 308
 309 ;;;;;;;;;;;;;;;;;;;;;;;
 310 ;;;;;;;;;;;;;;;;;;;;;;;
 311 ;;;                 ;;;
 312 ;;;  SERVICE LOOKUP ;;;
 313 ;;;                 ;;;
 314 ;;;;;;;;;;;;;;;;;;;;;;;
 315 ;;;;;;;;;;;;;;;;;;;;;;;
 316
 317 (defclass service ()
 318   ((name     :initarg :name     :reader service-name)
 319    (port     :initarg :port     :reader service-port)
 320    (protocol :initarg :protocol :reader service-protocol)))
 321
 322 (defun make-service (name port protocol)
 323   (make-instance 'service
 324                  :name name
 325                  :port port
 326                  :protocol protocol))
 327
 328 (defmethod print-object ((service service) stream)
 329   (print-unreadable-object (service stream :type t :identity nil)
 330     (with-slots (name port protocol) service
 331       (format stream "Name: ~A. Port: ~A. Protocol: ~A" name port protocol))))
 332
 333 (defun socket-type-from-int (alien-val)
 334   (case alien-val
 335     (#.et:sock-stream    :tcp)
 336     (#.et:sock-dgram     :udp)
 337     (#.et:sock-seqpacket :sctp)
 338     (#.et:sock-raw       :raw)
 339     (t                   :unknown)))
 340
 341 (defun lookup-service-number (port-number protocol &key name-required)
 342   (declare (type ub32 port-number))
 343   (with-foreign-object (sin 'et:sockaddr-in)
 344     (let ((service
 345            (nth-value 1
 346             (progn
 347               (et:bzero sin et:size-of-sockaddr-in)
 348               (with-foreign-slots ((et:family et:port) sin et:sockaddr-in)
 349                 (setf et:family et:af-inet
 350                       et:port (htons port-number)))
 351               (get-name-info sin
 352                              :flags (logior
 353                                      (case protocol
 354                                        (:udp et:ni-dgram)
 355                                        (t 0))
 356                                      (if name-required
 357                                          et:ni-namereqd 0))
 358                              :want-host nil :want-service t)))))
 359       (make-service service port-number protocol))))
 360
 361 (defun protocol-type-from-int (protocol)
 362   (case protocol
 363     (:tcp et:sock-stream)
 364     (:udp et:sock-dgram)
 365     (:any 0)))
 366
 367 (defun lookup-service-name (port protocol)
 368   (let* ((addrinfo
 369           (get-address-info :service port
 370                             :hint-type (protocol-type-from-int protocol)))
 371          (port-number
 372           (ntohs (foreign-slot-value (foreign-slot-value addrinfo 'et:addrinfo 'et:addr)
 373                                      'et:sockaddr-in 'et:port)))
 374          (true-protocol
 375           (socket-type-from-int (foreign-slot-value addrinfo 'et:addrinfo 'et:socktype))))
 376     (et:freeaddrinfo addrinfo)
 377     (return-from lookup-service-name
 378       (make-service port port-number true-protocol))))
 379
 380 (defun lookup-service (port &key (protocol :tcp) (name-required nil))
 381   (check-type protocol (member :tcp :udp :any))
 382
 383   (let ((parsed-number (parse-number-or-nil port :ub16)))
 384     (handler-case
 385         (if parsed-number
 386             (lookup-service-number parsed-number protocol
 387                                    :name-required name-required)
 388             (lookup-service-name port protocol))
 389       (et:resolv-error (err)
 390         (resolver-error (et:system-error-identifier err) :data port)))))
 391
 392
 393
 394 ;;;;;;;;;;;;;;;;;;;;;;;;
 395 ;;;;;;;;;;;;;;;;;;;;;;;;
 396 ;;;                  ;;;
 397 ;;;  PROTOCOL LOOKUP ;;;
 398 ;;;                  ;;;
 399 ;;;;;;;;;;;;;;;;;;;;;;;;
 400 ;;;;;;;;;;;;;;;;;;;;;;;;
 401
 402 (defclass protocol ()
 403   ((name     :initarg :name     :reader protocol-name)
 404    (aliases  :initarg :aliases  :reader protocol-aliases)
 405    (protonum :initarg :protonum :reader protocol-number)))
 406
 407 (defun make-protocol (name protonum &optional aliases)
 408   (make-instance 'protocol
 409                  :name name
 410                  :protonum protonum
 411                  :aliases aliases))
 412
 413 (defmethod print-object ((protocol protocol) stream)
 414   (print-unreadable-object (protocol stream :type t :identity nil)
 415     (with-slots (name aliases protonum) protocol
 416       (format stream "Name: ~S. Protocol number: ~A. Aliases: ~{~S~^, ~}"
 417               name protonum aliases))))
 418
 419 (define-condition unknown-protocol (system-error)
 420   ((name :initarg :name :initform nil :reader protocol-name))
 421   (:report (lambda (condition stream)
 422              (format stream "Unknown protocol: ~S"
 423                      (protocol-name condition))))
 424   (:documentation "Condition raised when a network protocol is not found."))
 425
 426 (defun make-protocol-from-protoent (protoent)
 427   (with-foreign-slots ((et:name et:proto et:aliases) protoent et:protoent)
 428     (let ((alias-strings
 429            (loop
 430               :for i :from 0
 431               :for alias := (mem-aref et:aliases :string i)
 432               :while alias :collect alias)))
 433       (make-protocol et:name et:proto alias-strings))))
 434
 435 (defun get-protocol-by-number (protonum)
 436   (make-protocol-from-protoent (et:getprotobynumber protonum)))
 437
 438 (defun get-protocol-by-name (protoname)
 439   (make-protocol-from-protoent (et:getprotobyname protoname)))
 440
 441 (defun lookup-protocol (proto)
 442   (let ((parsed-number (parse-number-or-nil proto)))
 443     (handler-case
 444         (if parsed-number
 445             (get-protocol-by-number parsed-number)
 446             (get-protocol-by-name proto))
 447       (unix-error (err)
 448         (declare (ignore err))
 449         (error 'unknown-protocol :name proto)))))