net.sockets/dns/lookup.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- High-level name lookup.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (define-constant +max-ipv4-value+ (1- (expt 2 32))
   9   :documentation "Integer denoting 255.255.255.255")
  10
  11 ;;;; High-level Interface
  12
  13 ;;; TODO: caching
  14
  15 (defun reply-error-condition (reply query-type)
  16   (cond ((null reply) 'resolver-again-error)
  17         ((dns-flag-p reply :name-error) 'resolver-no-name-error)
  18         ((or (dns-flag-p reply :format-error)
  19              (dns-flag-p reply :server-failure)
  20              (dns-flag-p reply :not-implemented))
  21          'resolver-fail-error)
  22         ((loop :for rr :across (dns-message-answer reply)
  23                :never (eq query-type (dns-record-type rr)))
  24          'resolver-no-name-error)))
  25
  26 (defun check-reply-for-errors (reply host query-type)
  27   (when-let (condition (reply-error-condition reply query-type))
  28     (error condition :data host)))
  29
  30 (defun dns-lookup-host-by-address (address)
  31   (let ((reply (dns-query address :type :ptr)))
  32     (check-reply-for-errors reply address :ptr)
  33     (let ((hostname (remove-trailing-dot
  34                      (dns-rr-data (aref (dns-message-answer reply) 0)))))
  35       (values address '()
  36               hostname
  37               (list (cons hostname address))))))
  38
  39 (defun lookup-host-by-address (address ipv6)
  40   (cond ((and (eq :ipv6 ipv6)
  41               (ipv4-address-p address))
  42          (setf address (map-ipv4-address-to-ipv6 address)))
  43         ((and (member ipv6 '(nil t))
  44               (ipv6-ipv4-mapped-p address))
  45          (setf address (map-ipv6-address-to-ipv4 address))))
  46   (nth-value-or 0
  47     (search-host-by-address address)
  48     (dns-lookup-host-by-address address)))
  49
  50 (defun process-one-reply (reply query-type)
  51   (let ((truename (dns-record-name (aref (dns-message-question reply) 0)))
  52         addresses aliases)
  53     (loop :for rr :across (dns-message-answer reply) :do
  54        (switch ((dns-record-type rr) :test #'eq)
  55          (:cname (setf truename (dns-rr-data rr)))
  56          (query-type (let ((address (ensure-address (dns-rr-data rr)))
  57                            (name (remove-trailing-dot (dns-record-name rr))))
  58                        (push address addresses)
  59                        (push (cons name address) aliases)))
  60          (t (warn "Invalid RR type: ~S" (dns-record-type rr)))))
  61     (let ((addresses (nreverse addresses)))
  62       (values (car addresses) (cdr addresses)
  63               (remove-trailing-dot truename)
  64               (nreverse aliases)))))
  65
  66 (defun dns-lookup-host-in-one-domain (host query-type)
  67   (let ((reply (dns-query host :type query-type)))
  68     (check-reply-for-errors reply host query-type)
  69     (process-one-reply reply query-type)))
  70
  71 (defun merge-a-and-aaaa-replies (4-reply 6-reply)
  72   (multiple-value-bind (4-main 4-addresses 4-truename 4-aliases)
  73       (process-one-reply 4-reply :a)
  74     (multiple-value-bind (6-main 6-addresses 6-truename 6-aliases)
  75         (process-one-reply 6-reply :aaaa)
  76       (declare (ignore 6-truename))
  77       (values 4-main (nconc 4-addresses (list 6-main) 6-addresses)
  78               4-truename
  79               (nconc 4-aliases 6-aliases)))))
  80
  81 (defun dns-lookup-host-in-a-and-aaaa (host)
  82   (let* ((4-reply (dns-query host :type :a))
  83          (4-err (reply-error-condition 4-reply :a))
  84          (6-reply (dns-query host :type :aaaa))
  85          (6-err (reply-error-condition 6-reply :aaaa)))
  86     (cond
  87       ((and 4-err 6-err)
  88        (if (member 'resolver-fail-error (list 4-err 6-err))
  89            (error 'resolver-fail-error :data host)
  90            (error 'resolver-no-name-error :data host)))
  91       (4-err (process-one-reply 6-reply :aaaa))
  92       (6-err (process-one-reply 4-reply :a))
  93       (t (merge-a-and-aaaa-replies 4-reply 6-reply)))))
  94
  95 (defun dns-lookup-host-by-name (host ipv6)
  96   (case ipv6
  97     ((nil)   (dns-lookup-host-in-one-domain host :a))
  98     ((:ipv6) (dns-lookup-host-in-one-domain host :aaaa))
  99     ((t)     (dns-lookup-host-in-a-and-aaaa host))))
 100
 101 (defun lookup-host-by-name (host ipv6)
 102   (nth-value-or 0
 103     (search-host-by-name host ipv6)
 104     (dns-lookup-host-by-name host ipv6)))
 105
 106 ;; TODO: * implement address selection as per RFC 3484
 107 ;;       * add caching
 108 ;;       * profile the whole thing
 109 (defun lookup-host (host &key (ipv6 *ipv6*))
 110   "Looks up a host by name or address. IPV6 determines the
 111 IPv6 behaviour, defaults to *IPV6*.
 112 Returns 4 values:
 113 * an address
 114 * a list of additional addresses(if existent)
 115 * the canonical name of the host
 116 * an alist of all the host's names with their respective addresses"
 117   (check-type ipv6 *ipv6*-type "one of T, NIL or :IPV6")
 118   (let ((address (ensure-address host :errorp (not (stringp host)))))
 119     (update-monitor *resolv.conf-monitor*)
 120     (update-monitor *hosts-monitor*)
 121     (cond (address
 122            (lookup-host-by-address address ipv6))
 123           (t
 124            (check-type host string "a string")
 125            (lookup-host-by-name host ipv6)))))
 126
 127 (defun ensure-hostname (address &key (ipv6 *ipv6*) (errorp t))
 128   "If ADDRESS is an inet-address designator, it is converted, if
 129 necessary, to an INET-ADDRESS object and returned.  Otherwise it
 130 is assumed to be a host name which is then looked up in order to
 131 return its primary address as the first return value and the
 132 remaining address list as the second return value."
 133   (flet ((%do-ensure-hostname ()
 134            (or (ensure-address address :family :internet :errorp nil)
 135                (nth-value 0 (lookup-host address :ipv6 ipv6)))))
 136     (if errorp
 137         (%do-ensure-hostname)
 138         (ignore-some-conditions (socket-error resolver-error)
 139           (%do-ensure-hostname)))))