1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; lookup.lisp --- High-level name lookup.
5 ;;; Copyright (C) 2006-2008, Stelian Ionescu <sionescu@common-lisp.net>
6 ;;; Copyright (C) 2006-2007, Luis Oliveira <loliveira@common-lisp.net>
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
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.
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
25 (in-package :net.sockets
)
27 (define-constant +max-ipv4-value
+ (1- (expt 2 32))
28 :documentation
"Integer denoting 255.255.255.255")
30 ;;;; High-level Interface
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
))
41 ((loop :for rr
:across
(dns-message-answer reply
)
42 :never
(eq query-type
(dns-record-type rr
)))
43 'resolver-no-name-error
)))
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
)))
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
)
56 (list (cons hostname address
))))))
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
))))
66 (search-host-by-address address
)
67 (dns-lookup-host-by-address address
)))
69 (defun process-one-reply (reply query-type
)
70 (let ((truename (dns-record-name (aref (dns-message-question reply
) 0)))
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
)
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
)))
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
)
97 (nconc 4-aliases
6-aliases
)))))
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
)))
106 (error (if (member 'resolver-fail-error
(list 4-err
6-err
)
109 'resolver-no-name-error
)
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
)))))
115 (defun dns-lookup-host-by-name (host 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
))))
121 (defun lookup-host-by-name (host ipv6
)
123 (search-host-by-name host ipv6
)
124 (dns-lookup-host-by-name host ipv6
)))
126 ;; TODO: * implement address selection as per RFC 3484
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 (ensure-address host
:errorp nil
)
135 (ensure-address host
))))
136 (update-monitor *resolv.conf-monitor
*)
137 (update-monitor *hosts-monitor
*)
139 (lookup-host-by-address address ipv6
))
141 (check-type host string
"a string")
142 (lookup-host-by-name host ipv6
)))))
144 (defun ensure-hostname (address &key
(ipv6 *ipv6
*) (errorp t
))
145 "If ADDRESS is an inet-address designator, it is converted, if
146 necessary, to an INET-ADDRESS object and returned. Otherwise it
147 is assumed to be a host name which is then looked up in order to
148 return its primary address as the first return value and the
149 remaining address list as the second return value."
150 (flet ((%do-ensure-hostname
()
151 (or (ensure-address address
:family
:internet
:errorp nil
)
152 (let ((addresses (lookup-host address
:ipv6 ipv6
)))
153 (values (car addresses
) (cdr addresses
))))))
155 (%do-ensure-hostname
)
156 (ignore-some-conditions (socket-error resolver-error
)
157 (%do-ensure-hostname
)))))