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)))))