sockets/dns/lookup.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; lookup.lisp --- High-level name lookup.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;; Copyright (C) 2006-2007, Luis Oliveira  <loliveira@common-lisp.net>
   7 ;;;
   8 ;;; This code is free software; you can redistribute it and/or
   9 ;;; modify it under the terms of the version 2.1 of
  10 ;;; the GNU Lesser General Public License as published by
  11 ;;; the Free Software Foundation, as clarified by the
  12 ;;; preamble found here:
  13 ;;;     http://opensource.franz.com/preamble.html
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU Lesser General
  21 ;;; Public License along with this library; if not, write to the
  22 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  23 ;;; Boston, MA 02110-1301, USA
  24
  25 (in-package :net.sockets)
  26
  27 (define-constant +max-ipv4-value+ (1- (expt 2 32))
  28   :documentation "Integer denoting 255.255.255.255")
  29
  30 ;;;; High-level Interface
  31
  32 ;;; TODO: caching
  33
  34 (defun reply-error-condition (reply query-type)
  35   (cond ((null reply) 'resolver-again-error)
  36         ((dns-flag-p reply :name-error) 'resolver-no-name-error)
  37         ((or (dns-flag-p reply :format-error)
  38              (dns-flag-p reply :server-failure)
  39              (dns-flag-p reply :not-implemented))
  40          'resolver-fail-error)
  41         ((loop :for rr :across (dns-message-answer reply)
  42                :never (eq query-type (dns-record-type rr)))
  43          'resolver-no-name-error)))
  44
  45 (defun check-reply-for-errors (reply host query-type)
  46   (when-let ((condition (reply-error-condition reply query-type)))
  47     (error condition :data host)))
  48
  49 (defun dns-lookup-host-by-address (address)
  50   (let ((reply (dns-query address :type :ptr)))
  51     (check-reply-for-errors reply address :ptr)
  52     (let ((hostname (remove-trailing-dot
  53                      (dns-rr-data (aref (dns-message-answer reply) 0)))))
  54       (values (list address)
  55               hostname
  56               (list (cons hostname address))))))
  57
  58 (defun lookup-host-by-address (address ipv6)
  59   (cond ((and (eq ipv6 :ipv6)
  60               (ipv4-address-p address))
  61          (setf address (map-ipv4-address-to-ipv6 address)))
  62         ((and (member ipv6 '(nil t))
  63               (ipv6-ipv4-mapped-p address))
  64          (setf address (map-ipv6-address-to-ipv4 address))))
  65   (nth-value-or 0
  66     (search-host-by-address address)
  67     (dns-lookup-host-by-address address)))
  68
  69 (defun process-one-reply (reply query-type)
  70   (let ((truename (dns-record-name (aref (dns-message-question reply) 0)))
  71         addresses aliases)
  72     (loop :for rr :across (dns-message-answer reply) :do
  73        (switch ((dns-record-type rr) :test #'eq)
  74          (:cname (setf truename (dns-rr-data rr)))
  75          (query-type (let ((address (ensure-address (dns-rr-data rr)))
  76                            (name (remove-trailing-dot (dns-record-name rr))))
  77                        (push address addresses)
  78                        (push (cons name address) aliases)))
  79          (t (warn "Invalid RR type: ~S" (dns-record-type rr)))))
  80     (values (nreverse addresses)
  81             (remove-trailing-dot truename)
  82             (nreverse aliases))))
  83
  84 (defun dns-lookup-host-in-one-domain (host query-type)
  85   (let ((reply (dns-query host :type query-type)))
  86     (check-reply-for-errors reply host query-type)
  87     (process-one-reply reply query-type)))
  88
  89 (defun merge-a-and-aaaa-replies (4-reply 6-reply)
  90   (multiple-value-bind (4-addresses 4-truename 4-aliases)
  91       (process-one-reply 4-reply :a)
  92     (multiple-value-bind (6-addresses 6-truename 6-aliases)
  93         (process-one-reply 6-reply :aaaa)
  94       (declare (ignore 6-truename))
  95       (values (nconc 4-addresses 6-addresses)
  96               4-truename
  97               (nconc 4-aliases 6-aliases)))))
  98
  99 (defun dns-lookup-host-in-a-and-aaaa (host)
 100   (let* ((4-reply (dns-query host :type :a))
 101          (4-err (reply-error-condition 4-reply :a))
 102          (6-reply (dns-query host :type :aaaa))
 103          (6-err (reply-error-condition 6-reply :aaaa)))
 104     (cond
 105       ((and 4-err 6-err)
 106        (error (if (member 'resolver-fail-error (list 4-err 6-err)
 107                           :test #'eq)
 108                   'resolver-fail-error
 109                   'resolver-no-name-error)
 110               :data host))
 111       (4-err (process-one-reply 6-reply :aaaa))
 112       (6-err (process-one-reply 4-reply :a))
 113       (t (merge-a-and-aaaa-replies 4-reply 6-reply)))))
 114
 115 (defun dns-lookup-host-by-name (host ipv6)
 116   (case ipv6
 117     ((nil)   (dns-lookup-host-in-one-domain host :a))
 118     ((:ipv6) (dns-lookup-host-in-one-domain host :aaaa))
 119     ((t)     (dns-lookup-host-in-a-and-aaaa host))))
 120
 121 (defun lookup-host-by-name (host ipv6)
 122   (nth-value-or 0
 123     (search-host-by-name host ipv6)
 124     (dns-lookup-host-by-name host ipv6)))
 125
 126 ;; TODO: * implement address selection as per RFC 3484
 127 ;;       * add caching
 128 ;;       * profile the whole thing
 129 (defun lookup-host (host &key (ipv6 *ipv6*))
 130   "Looks up a host by name or address.  IPV6 determines the IPv6
 131 behaviour, defaults to *IPV6*."
 132   (check-type ipv6 *ipv6*-type "one of T, NIL or :IPV6")
 133   (let ((address (if (stringp host)
 134                      (ignore-parse-errors (ensure-address host))
 135                      (ensure-address host))))
 136     (update-monitor *resolv.conf-monitor*)
 137     (update-monitor *hosts-monitor*)
 138     (cond (address
 139            (lookup-host-by-address address ipv6))
 140           (t
 141            (check-type host string "a string")
 142            (lookup-host-by-name host ipv6)))))
 143
 144 (defun convert-or-lookup-inet-address (address &optional (ipv6 *ipv6*))
 145   "If ADDRESS is an inet-address designator, it is converted, if
 146 necessary, to an INET-ADDRESS object and returned.  Otherwise it
 147 is assumed to be a host name which is then looked up in order to
 148 return its primary address as the first return value and the
 149 remaining address list as the second return value."
 150   (or (ignore-parse-errors (ensure-address address :internet))
 151       (let ((addresses (lookup-host address :ipv6 ipv6)))
 152         (values (car addresses) (cdr addresses)))))