sockets/resolv.lisp

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