From ef7f569cbd3a69a77c09bc214baacd47737f7e01 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 30 Jul 2020 03:44:45 +0200 Subject: [PATCH] Add the new function dns-query-asynchronous * lisp/net/dns.el (dns-query-asynchronous): New function. (dns--lookup, dns--filter): New internal functions. (dns-query): Reimplement on top of dns-query-asynchronous. --- etc/NEWS | 5 ++ lisp/net/dns.el | 176 ++++++++++++++++++++++++++++++++---------------- 2 files changed, 123 insertions(+), 58 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 8f5864961d2..fab2d85e8da 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -637,6 +637,11 @@ Formerly it made an exception for integer components of SOA records, because SOA serial numbers can exceed fixnum ranges on 32-bit platforms. Emacs now supports bignums so this old glitch is no longer needed. +--- +** The new function 'dns-query-asynchronous' has been added. +It takes the same parameters as 'dns-query', but adds a callback +parameter. + ** The Lisp variables 'previous-system-messages-locale' and 'previous-system-time-locale' have been removed, as they were created by mistake and were not useful to Lisp code. diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 1c46102554e..ef250f067ea 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -374,9 +374,14 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (set (intern key dns-cache) result) result)))) -(defun dns-query (name &optional type fullp reversep) +(defun dns-query-asynchronous (name callback &optional type fullp reversep) "Query a DNS server for NAME of TYPE. -If FULLP, return the entire record returned. +CALLBACK will be called with a single parameter: The result. + +If there's no result, or `dns-timeout' has passed, CALLBACK will +be called with nil as the parameter. + +If FULLP, return the entire record. If REVERSEP, look up an IP address." (setq type (or type 'A)) (unless (dns-servers-up-to-date-p) @@ -392,63 +397,118 @@ If REVERSEP, look up an IP address." (progn (message "No DNS server configuration found") nil) - (with-temp-buffer - (set-buffer-multibyte nil) - (let* ((process - (condition-case () - (let ((server (car dns-servers)) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (if (featurep 'make-network-process '(:type datagram)) - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :host server - :service "domain" - :type 'datagram) - ;; On MS-Windows datagram sockets are not - ;; supported, so we fall back on opening a TCP - ;; connection to the DNS server. + (dns--lookup name callback type fullp))) + +(defun dns--lookup (name callback type full) + (with-current-buffer (generate-new-buffer " *dns*") + (set-buffer-multibyte nil) + (let* ((tcp nil) + (process + (condition-case () + (let ((server (car dns-servers)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (if (featurep 'make-network-process '(:type datagram)) + (make-network-process + :name "dns" + :coding 'binary + :buffer (current-buffer) + :host server + :service "domain" + :type 'datagram) + ;; On MS-Windows datagram sockets are not + ;; supported, so we fall back on opening a TCP + ;; connection to the DNS server. + (progn + (setq tcp t) (open-network-stream "dns" (current-buffer) - server "domain"))) - (error - (message - "dns: Got an error while trying to talk to %s" - (car dns-servers)) - nil))) - (step 100) - (times (* dns-timeout 1000)) - (id (random 65000)) - (tcp-p (and process (not (process-contact process :type))))) - (when process - (process-send-string - process - (dns-write `((id ,id) - (opcode query) - (queries ((,name (type ,type)))) - (recursion-desired-p t)) - tcp-p)) - (while (and (zerop (buffer-size)) - (> times 0)) - (let ((step-sec (/ step 1000.0))) - (sit-for step-sec) - (accept-process-output process step-sec)) - (setq times (- times step))) - (condition-case nil - (delete-process process) - (error nil)) - (when (and (>= (buffer-size) 2) - ;; We had a time-out. - (> times 0)) - (let ((result (dns-read (buffer-string) tcp-p))) - (if fullp - result - (let ((answer (car (dns-get 'answers result)))) - (when (eq type (dns-get 'type answer)) - (if (eq type 'TXT) - (dns-get-txt-answer (dns-get 'answers result)) - (dns-get 'data answer)))))))))))) + server "domain")))) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) + (triggered nil) + (buffer (current-buffer)) + timer) + (if (not process) + (progn + (kill-buffer buffer) + (funcall callback nil)) + ;; Call the callback if we don't get any response at all. + (setq timer (run-at-time dns-timeout nil + (lambda () + (unless triggered + (setq triggered t) + (delete-process process) + (kill-buffer buffer) + (funcall callback nil))))) + (process-send-string + process + (dns-write `((id ,(random 65000)) + (opcode query) + (queries ((,name (type ,type)))) + (recursion-desired-p t)) + tcp)) + (set-process-filter + process + (lambda (process string) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (goto-char (point-min)) + ;; If this is DNS, then we always get the full data in + ;; one packet. If it's TCP, we may only get part of the + ;; data, but the first two bytes says how long the data + ;; is supposed to be. + (when (or (not tcp) + (>= (buffer-size) (dns-read-bytes 2))) + (setq triggered t) + (cancel-timer timer) + (dns--filter process callback type full tcp))))) + ;; In case we the process is deleted for some reason, then do + ;; a failure callback. + (set-process-sentinel + process + (lambda (_ state) + (when (and (eq state 'deleted) + ;; Ensure we don't trigger this callback twice. + (not triggered)) + (setq triggered t) + (cancel-timer timer) + (kill-buffer buffer) + (funcall callback nil)))))))) + +(defun dns--filter (process callback type full tcp) + (let ((message (buffer-string))) + (when (process-live-p process) + (delete-process process)) + (kill-buffer (current-buffer)) + (when (>= (length message) 2) + (let ((result (dns-read message tcp))) + (funcall callback + (if full + result + (let ((answer (car (dns-get 'answers result)))) + (when (eq type (dns-get 'type answer)) + (if (eq type 'TXT) + (dns-get-txt-answer (dns-get 'answers result)) + (dns-get 'data answer)))))))))) + +(defun dns-query (name &optional type fullp reversep) + "Query a DNS server for NAME of TYPE. +If FULLP, return the entire record returned. +If REVERSEP, look up an IP address." + (let ((result nil)) + (dns-query-asynchronous + name + (lambda (response) + (setq result (list response))) + type fullp reversep) + ;; Loop until we get the callback. + (while (not result) + (sleep-for 0.01)) + (car result))) (provide 'dns) -- 2.39.2