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