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