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