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         ((dns-flag-p reply :server-failure) 'resolver-fail-error)
  38         ((loop :for rr :across (dns-message-answer reply)
  39                :never (eq query-type (dns-record-type rr)))
  40          'resolver-no-name-error)))
  41
  42 (defun check-reply-for-errors (reply host query-type)
  43   (when-let ((condition (reply-error-condition reply query-type)))
  44     (error condition :data host)))
  45
  46 (defun dns-lookup-host-by-address (address)
  47   (let ((reply (dns-query address :type :ptr)))
  48     (check-reply-for-errors reply address :ptr)
  49     (let ((hostname (remove-trailing-dot
  50                      (dns-rr-data (aref (dns-message-answer reply) 0)))))
  51       (values (list address)
  52               hostname
  53               (list (cons hostname address))))))
  54
  55 (defun lookup-host-by-address (address ipv6)
  56   (cond ((and (eq ipv6 :ipv6)
  57               (ipv4-address-p address))
  58          (setf address (map-ipv4-address-to-ipv6 address)))
  59         ((and (member ipv6 '(nil t))
  60               (ipv6-ipv4-mapped-p address))
  61          (setf address (map-ipv6-address-to-ipv4 address))))
  62   (nth-value-or 0
  63     (search-host-by-address address)
  64     (dns-lookup-host-by-address address)))
  65
  66 (defun process-one-reply (reply query-type)
  67   (let ((truename (dns-record-name (aref (dns-message-question reply) 0)))
  68         addresses aliases)
  69     (loop :for rr :across (dns-message-answer reply) :do
  70        (switch ((dns-record-type rr) :test #'eq)
  71          (:cname (setf truename (dns-rr-data rr)))
  72          (query-type (let ((address (ensure-address (dns-rr-data rr)))
  73                            (name (remove-trailing-dot (dns-record-name rr))))
  74                        (push address addresses)
  75                        (push (cons name address) aliases)))
  76          (t (warn "Invalid RR type: ~S" (dns-record-type rr)))))
  77     (values (nreverse addresses)
  78             (remove-trailing-dot truename)
  79             (nreverse aliases))))
  80
  81 (defun dns-lookup-host-in-one-domain (host query-type)
  82   (let ((reply (dns-query host :type query-type)))
  83     (check-reply-for-errors reply host query-type)
  84     (process-one-reply reply query-type)))
  85
  86 (defun merge-a-and-aaaa-replies (4-reply 6-reply)
  87   (multiple-value-bind (4-addresses 4-truename 4-aliases)
  88       (process-one-reply 4-reply :a)
  89     (multiple-value-bind (6-addresses 6-truename 6-aliases)
  90         (process-one-reply 6-reply :aaaa)
  91       (declare (ignore 6-truename))
  92       (values (nconc 4-addresses 6-addresses)
  93               4-truename
  94               (nconc 4-aliases 6-aliases)))))
  95
  96 (defun dns-lookup-host-in-a-and-aaaa (host)
  97   (let* ((4-reply (dns-query host :type :a))
  98          (4-err (reply-error-condition 4-reply :a))
  99          (6-reply (dns-query host :type :aaaa))
 100          (6-err (reply-error-condition 6-reply :aaaa)))
 101     (cond
 102       ((and 4-err 6-err)
 103        (error (if (member 'resolver-fail-error (list 4-err 6-err)
 104                           :test #'eq)
 105                   'resolver-fail-error
 106                   'resolver-no-name-error)
 107               :data host))
 108       (4-err (process-one-reply 6-reply :aaaa))
 109       (6-err (process-one-reply 4-reply :a))
 110       (t (merge-a-and-aaaa-replies 4-reply 6-reply)))))
 111
 112 (defun dns-lookup-host-by-name (host ipv6)
 113   (case ipv6
 114     ((nil)   (dns-lookup-host-in-one-domain host :a))
 115     ((:ipv6) (dns-lookup-host-in-one-domain host :aaaa))
 116     ((t)     (dns-lookup-host-in-a-and-aaaa host))))
 117
 118 (defun lookup-host-by-name (host ipv6)
 119   (nth-value-or 0
 120     (search-host-by-name host ipv6)
 121     (dns-lookup-host-by-name host ipv6)))
 122
 123 ;; TODO: * implement address selection as per RFC 3484
 124 ;;       * add caching
 125 ;;       * profile the whole thing
 126 (defun lookup-host (host &key (ipv6 *ipv6*))
 127   "Looks up a host by name or address.  IPV6 determines the IPv6
 128 behaviour, defaults to *IPV6*."
 129   (check-type ipv6 (member nil :ipv6 t) "one of NIL, :IPV6 or T")
 130   (let ((address (if (stringp host)
 131                      (ignore-parse-errors (ensure-address host))
 132                      (ensure-address host))))
 133     (update-monitor *resolv.conf-monitor*)
 134     (update-monitor *hosts-monitor*)
 135     (cond (address
 136            (lookup-host-by-address address ipv6))
 137           (t
 138            (check-type host string "a string")
 139            (lookup-host-by-name host ipv6)))))