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