From: Fredrik Tolf <fredrik@dolda2000.com>
Date: Mon, 17 May 2010 23:11:28 +0000 (+0200)
Subject: COMMON-NET: Added a recursive DNS resolver.
X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=commitdiff_plain;h=6c36ab4ac92a1bd1898063a3854cbf9c0d8d645f

COMMON-NET: Added a recursive DNS resolver.
---

diff --git a/dns.lisp b/dns.lisp
index a9afc67..ce6117c 100644
--- a/dns.lisp
+++ b/dns.lisp
@@ -585,6 +585,133 @@
 (defvar *dns-resolver-config* (initialize-default-resolver))
 
 (defgeneric dns-server-address-for-record (record))
+(defmethod dns-server-address-for-record ((record a-record))
+  (make-instance 'udp4-address
+		 :host-address (slot-value record 'address)
+		 :port 53))
+(defmethod dns-server-address-for-record ((record aaaa-record))
+  (make-instance 'udp6-address
+		 :host-address (slot-value record 'address)
+		 :port 53))
+
+(define-condition dns-resolver-condition (condition)
+  ((query-name :initarg :query-name)
+   (query-type :initarg :query-type)
+   (config :initarg :config)))
+
+(define-condition dns-resolver-error (dns-error dns-resolver-condition) ())
+(define-condition domain-not-found-error (dns-resolver-error) ()
+  (:report (lambda (c s)
+	     (with-slots (query-name) c
+	       (format s "No name servers found for domain name ~A." query-name)))))
+(define-condition dns-name-error (dns-error dns-resolver-condition) ()
+  (:report (lambda (c s)
+	     (with-slots (query-name) c
+	       (format s "The domain name ~A does not exist." query-name)))))
+
+(define-condition dns-resolver-querying (dns-resolver-condition)
+  ((server :initarg :server)))
+
+(define-condition dns-resolver-got-resp (dns-resolver-condition)
+  ((server :initarg :server)
+   (response :initarg :response)))
+
+(define-condition dns-resolver-help (dns-resolver-condition) ())
+(define-condition dns-resolver-recursing (dns-resolver-condition) ())
+
+(define-condition dns-resolver-following-cname (dns-resolver-condition)
+  ((cname-rr :initarg :cname-rr)))
+
+(defun dns-resolve-name (name types &key (require-all t) (config *dns-resolver-config*))
+  (let ((name (etypecase name
+		(list name)
+		(string (parse-domain-name name))))
+	(types (etypecase types
+		 (list types)
+		 (symbol (list types))))
+	(cache (resolver-config-cache config)))
+    (flet ((check-cache ()
+	     (let ((cn-entry (domain-cache-get-entry cache name 'cname-record)))
+	       (when (and cn-entry (domain-cache-entry-records cn-entry))
+		 (let ((record (car (domain-cache-entry-records cn-entry))))
+		   (signal 'dns-resolver-following-cname :cname-rr record
+			   :query-name (unparse-domain-name name) :query-type types
+			   :config config)
+		   (return-from dns-resolve-name
+		     (dns-resolve-name (slot-value record 'cname) types :config config)))))
+	     (block skip
+	       (let ((records '())
+		     (got-some nil))
+		 (dolist (type types)
+		   (let ((entry (domain-cache-get-entry cache name type)))
+		     (cond (entry
+			    (setf records (append records (domain-cache-entry-records entry))
+				  got-some t))
+			   (require-all
+			    (return-from skip)))))
+		 (when got-some
+		   (return-from dns-resolve-name (values records name))))))
+	   (nearest-known-servers (name)
+	     (labels ((check1 (name)
+			(let ((entry (domain-cache-get-entry cache name 'ns-record)))
+			  (cond ((and entry (domain-cache-entry-records entry))
+				 (values (domain-cache-entry-records entry) name))
+				(name (check1 (cdr name)))
+				(t (values '() name))))))
+	       (check1 name)))
+	   (do-request (server)
+	     (signal 'dns-resolver-querying :server server
+		     :query-name (unparse-domain-name name) :query-type types
+		     :config config)
+	     (handler-case
+		 (let ((resp (dns-do-request (udp-address-for server 53)
+					     (dns-std-request (mapcar #'(lambda (type)
+									  `(,name ,type))
+								      types)))))
+		   (signal 'dns-resolver-got-resp :server server :response resp
+			   :query-name (unparse-domain-name name) :query-type types
+			   :config config)
+		   (dns-cache-response cache resp)
+		   (with-slots (resp-code) resp
+		     (when (eq (dns-packet-resp-code resp) :name-error)
+		       (error 'dns-name-error :query-name (unparse-domain-name name) :query-type types
+			      :config config))
+		     (eq resp-code :success)))
+	       (name-server-timeout () nil))))
+      (check-cache)
+      (signal 'dns-resolver-help :query-name (unparse-domain-name name) :query-type types
+	      :config config)
+      (dolist (help-server (resolver-config-help-servers config))
+	(do-request help-server)
+	(check-cache))
+      (signal 'dns-resolver-recursing :query-name (unparse-domain-name name) :query-type types
+	      :config config)
+      (let ((checked-domains '()))
+	(loop (multiple-value-bind (servers domain)
+		  (nearest-known-servers name)
+		(unless servers
+		  (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types
+			 :config config))
+		(if (find domain checked-domains :test 'equal)
+		    (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types
+			   :config config)
+		    (push domain checked-domains))
+		(macrolet ((dolist-random ((var list) &body body)
+			     (let ((copy (gensym "COPY")))
+			       `(let ((,copy ,list))
+				  (loop (unless ,copy (return))
+				     (let ((,var (elt ,list (random (length ,list)))))
+				       (setf ,copy (remove ,var ,copy))
+				       ,@body))))))
+		  (block found-server
+		    (dolist-random (record servers)
+		      (let* ((server (slot-value record 'ns-name)))
+			(dolist-random (record (handler-case
+						   (dns-resolve-name server '(a-record aaaa-record) :require-all nil :config config)
+						 (dns-resolver-error () '())))
+			  (when (do-request (dns-server-address-for-record record))
+			    (return-from found-server))))))
+		  (check-cache))))))))
 
 ;;; Misc.