Commit ef7f569c authored by Lars Ingebrigtsen's avatar Lars Ingebrigtsen

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.
parent 78919704
......@@ -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.
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment