+ Reworked condition signalling
+ TCP almost works + Cleanup
This commit is contained in:
mainzelm
parent
6cc2305e6b
commit
5f3582d017
|
|
@ -113,6 +113,9 @@
|
|||
(define-condition-type 'no-nameservers '(dns-error))
|
||||
(define no-nameservers? (condition-predicate 'no-nameservers))
|
||||
|
||||
(define-condition-type 'bad-nameserver '(dns-error))
|
||||
(define bad-nameserver? (condition-predicate 'bad-nameserver))
|
||||
|
||||
(define-condition-type 'not-a-hostname '(dns-error))
|
||||
(define not-a-hostname? (condition-predicate 'not-a-hostname))
|
||||
|
||||
|
|
@ -139,38 +142,42 @@
|
|||
(define-condition-type 'dns-refused '(dns-server-error))
|
||||
(define dns-refused? (condition-predicate 'dns-refused))
|
||||
|
||||
(define (dns-error condition . stuff)
|
||||
(apply signal condition (dns-error->string condition) stuff))
|
||||
|
||||
;; called by the error-handlers, prints out error descriptions
|
||||
(define (dns-error-messages condition more)
|
||||
(display "dns-error: ")
|
||||
(cond
|
||||
((invalid-type? condition)
|
||||
(display "make-octet-question: invalid DNS query type\n"))
|
||||
((invalid-class? condition)
|
||||
(display "make-octet-question: invalid DNS query class\n"))
|
||||
((parse-error? condition)
|
||||
(display "parse: error parsing server message\n"))
|
||||
((unexpected-eof-from-server? condition)
|
||||
(display "send-receive-message: unexpected EOF from server\n"))
|
||||
((bad-address? condition)
|
||||
(display "dns-get-information: bad address (in combination with query type)\n"))
|
||||
((no-nameservers? condition)
|
||||
(display "dns-find-nameserver: no nameservers found in /etc/resolv.conf\n"))
|
||||
((not-a-hostname? condition)
|
||||
(display "no hostname given\n"))
|
||||
((not-a-ip? condition)
|
||||
(display "no ip given\n"))
|
||||
((dns-format-error? condition)
|
||||
(display "error from server: (1) format error\n"))
|
||||
((dns-server-failure? condition)
|
||||
(display "error from server: (2) server failure\n"))
|
||||
((dns-name-error? condition)
|
||||
(display "error from server: (3) name error\n"))
|
||||
((dns-not-implemented? condition)
|
||||
(display "error from server: (4) not implemented\n"))
|
||||
((dns-refused? condition)
|
||||
(display "error from server: (5) refused\n"))
|
||||
(else (more))))
|
||||
(define (dns-error->string condition)
|
||||
(string-append
|
||||
"dns-error: "
|
||||
(case condition
|
||||
((invalid-type)
|
||||
"make-octet-question: invalid DNS query type")
|
||||
((invalid-class)
|
||||
"make-octet-question: invalid DNS query class")
|
||||
((parse-error)
|
||||
"parse: error parsing server message")
|
||||
((unexpected-eof-from-server)
|
||||
"send-receive-message: unexpected EOF from server")
|
||||
((bad-address)
|
||||
"dns-get-information: bad address (in combination with query type)")
|
||||
((no-nameservers)
|
||||
"dns-find-nameserver: no nameservers found in /etc/resolv.conf")
|
||||
((bad-nameserver)
|
||||
"send-receive-message: nameserver refused connection")
|
||||
((not-a-hostname)
|
||||
"no hostname given")
|
||||
((not-a-ip)
|
||||
"no ip given")
|
||||
((dns-format-error)
|
||||
"error from server: (1) format error")
|
||||
((dns-server-failure)
|
||||
"error from server: (2) server failure")
|
||||
((dns-name-error)
|
||||
"error from server: (3) name error")
|
||||
((dns-not-implemented)
|
||||
"error from server: (4) not implemented")
|
||||
((dns-refused)
|
||||
"error from server: (5) refused")
|
||||
(else (error "Unknown dns-error" condition)))))
|
||||
|
||||
|
||||
;;; -- globals and types
|
||||
|
|
@ -457,9 +464,9 @@
|
|||
(define (make-octet-question name type class)
|
||||
(if *debug* (display "make-octet-question\n"))
|
||||
(if (not (assoc type types))
|
||||
(signal 'invalid-type))
|
||||
(dns-error 'invalid-type))
|
||||
(if (not (assoc class classes))
|
||||
(signal 'invalid-class))
|
||||
(dns-error 'invalid-class))
|
||||
|
||||
(let* ((qname (name->octets name))
|
||||
(qtype (number->octet-pair (cadr (assoc type types))))
|
||||
|
|
@ -778,7 +785,7 @@
|
|||
(lambda () (parse-n parse-rr start message (header:arc header)))
|
||||
(lambda (ars start)
|
||||
(if (not (null? start))
|
||||
(signal 'parse-error))
|
||||
(dns-error 'parse-error))
|
||||
(make-message header qds ans nss ars message)))))))))))
|
||||
|
||||
|
||||
|
|
@ -796,86 +803,114 @@
|
|||
(let ((rcode (flags:rcode (parse-flags reply))))
|
||||
(if (not (zero? rcode))
|
||||
(case rcode
|
||||
((1) (signal 'dns-format-error))
|
||||
((2) (signal 'dns-server-failure))
|
||||
((3) (signal 'dns-name-error))
|
||||
((4) (signal 'dns-not-implemented))
|
||||
((5) (signal 'dns-refused))))))
|
||||
((1) (dns-error 'dns-format-error))
|
||||
((2) (dns-error 'dns-server-failure))
|
||||
((3) (dns-error 'dns-name-error))
|
||||
((4) (dns-error 'dns-not-implemented))
|
||||
((5) (dns-error 'dns-refused))))))
|
||||
|
||||
;; #t if message is truncated (could happen via UDP)
|
||||
(define (truncated? reply)
|
||||
(let ((trunc (flags:trunc (parse-flags reply))))
|
||||
(= trunc 1)))
|
||||
|
||||
|
||||
;; connects to nameserver and sends and receives messages. returns the reply.
|
||||
;; here: via TCP
|
||||
(define (send-receive-message-tcp nameserver question)
|
||||
(error "tcp doesn't work yet")
|
||||
(if *debug* (display "send-receive-message\n"))
|
||||
(let* ((query question)
|
||||
(reply
|
||||
(let ((socket (socket-connect protocol-family/internet
|
||||
socket-type/stream
|
||||
nameserver 53)))
|
||||
(let ((r (socket:inport socket))
|
||||
(w (socket:outport socket)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(display (list->string (add-size-tag query)) w)
|
||||
(force-output w)
|
||||
|
||||
(let ((a (read-char r))
|
||||
(b (read-char r)))
|
||||
(let ((len (octet-pair->number a b)))
|
||||
(let ((s (read-string len r)))
|
||||
(if (not (= len (string-length s)))
|
||||
(signal 'unexpected-eof-from-server))
|
||||
(string->list s)))))
|
||||
(lambda ()
|
||||
(close-socket socket)))))))
|
||||
(define (send-receive-message-tcp nameservers query)
|
||||
(receive (reply hit-ns other-nss)
|
||||
(let ((sockets (map (lambda (nameserver)
|
||||
(let ((sock (create-socket protocol-family/internet
|
||||
socket-type/stream))
|
||||
(addr (internet-address->socket-address
|
||||
nameserver 53)))
|
||||
;; we ignore the return value and select
|
||||
;; unconditionally later
|
||||
(connect-socket-no-wait sock addr)
|
||||
sock))
|
||||
nameservers)))
|
||||
(let* ((ws (map socket:outport sockets))
|
||||
(wsv (list->vector ws))
|
||||
(wport-nameserver-alist (map cons ws nameservers))
|
||||
(wport-socket-alist (map cons ws sockets)))
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda ()
|
||||
(receive (ignore-r write-ready ignore-e)
|
||||
;;; TODO this should circumvent the buffer
|
||||
(select '#() wsv '#())
|
||||
(let* ((w (vector-ref write-ready 0))
|
||||
(hit-ns (cdr (assoc w wport-nameserver-alist)))
|
||||
(sock (cdr (assoc w wport-socket-alist))))
|
||||
(if (not (connect-socket-successful? sock))
|
||||
(dns-error 'bad-nameserver hit-ns))
|
||||
(let ((query-string (list->string query))
|
||||
(r (socket:inport sock)))
|
||||
(display (list->string (add-size-tag query)) w)
|
||||
(force-output w)
|
||||
(let ((a (read-char r))
|
||||
(b (read-char r)))
|
||||
(let ((len (octet-pair->number a b)))
|
||||
(let ((s (read-string len r)))
|
||||
(if (not (= len (string-length s)))
|
||||
(dns-error 'unexpected-eof-from-server))
|
||||
(values (string->list s)
|
||||
hit-ns
|
||||
(delete hit-ns nameservers)))))))))
|
||||
(lambda ()
|
||||
(for-each close-socket sockets)))))
|
||||
(reply-acceptable? reply query)
|
||||
(parse reply)))
|
||||
(values (parse reply)
|
||||
hit-ns
|
||||
other-nss)))
|
||||
|
||||
;; here: via UDP
|
||||
(define (send-receive-message-udp nameservers question)
|
||||
(define (send-receive-message-udp nameservers query)
|
||||
(if *debug* (display "send-receive-message\n"))
|
||||
(let* ((query question)
|
||||
(reply
|
||||
(let ((sockets (map (lambda (nameserver)
|
||||
(socket-connect protocol-family/internet
|
||||
socket-type/datagram
|
||||
nameserver 53))
|
||||
nameservers)))
|
||||
(let ((rs (map socket:inport sockets))
|
||||
(ws (map socket:outport sockets)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(let ((query-string (list->string query))
|
||||
(rsv (list->vector rs)))
|
||||
(for-each (lambda (w) (display query-string w)) ws)
|
||||
(for-each force-output ws)
|
||||
(receive (read-ready ignore-w ignore-e)
|
||||
(select rsv '#() '#())
|
||||
(let ((r (vector-ref read-ready 0)))
|
||||
(string->list (read-string/partial 512 r)))))) ; 512 is the maximum udp-message size
|
||||
(lambda ()
|
||||
(for-each close-socket sockets)))))))
|
||||
(reply-acceptable? reply query)
|
||||
(if (truncated? reply)
|
||||
(send-receive-message-tcp nameservers question)
|
||||
(values (parse reply)
|
||||
(car nameservers); kludge
|
||||
'(kludge)))))
|
||||
(receive (reply hit-ns other-nss)
|
||||
(let ((sockets (map (lambda (nameserver)
|
||||
(let ((sock (create-socket protocol-family/internet
|
||||
socket-type/datagram))
|
||||
(addr (internet-address->socket-address
|
||||
nameserver 53)))
|
||||
(connect-socket sock addr)
|
||||
sock))
|
||||
nameservers)))
|
||||
(let ((rs (map socket:inport sockets))
|
||||
(ws (map socket:outport sockets)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(let ((query-string (list->string query))
|
||||
(rsv (list->vector rs))
|
||||
(rport-nameserver-alist (map cons rs nameservers))
|
||||
(rport-socket-alist (map cons rs sockets)))
|
||||
(for-each (lambda (w) (display query-string w)) ws)
|
||||
(for-each force-output ws)
|
||||
(receive (read-ready ignore-w ignore-e)
|
||||
;;; TODO this should circumvent the buffer
|
||||
(select rsv '#() '#())
|
||||
(let* ((r (vector-ref read-ready 0))
|
||||
(hit-ns (cdr (assoc r rport-nameserver-alist))))
|
||||
(if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist))))
|
||||
(dns-error 'bad-nameserver hit-ns))
|
||||
;;; 512 is the maximum udp-message size:
|
||||
(values (string->list (read-string/partial 512 r))
|
||||
hit-ns
|
||||
(delete hit-ns nameservers))))))
|
||||
(lambda ()
|
||||
(for-each close-socket sockets)))))
|
||||
(reply-acceptable? reply query)
|
||||
(if (truncated? reply)
|
||||
(send-receive-message-tcp nameservers query)
|
||||
(values (parse reply)
|
||||
hit-ns
|
||||
other-nss))))
|
||||
|
||||
|
||||
;;; -- cache
|
||||
|
||||
;; creates the cache, an emoty string-table
|
||||
;; creates the cache, an empty string-table
|
||||
(define cache (make-string-table))
|
||||
|
||||
;; resets the cache
|
||||
|
|
@ -932,7 +967,7 @@
|
|||
(values
|
||||
(make-dns-message (parse question) dns-msg #f protocol (reverse tried))
|
||||
hit-ns
|
||||
nss-with-no-reply))))
|
||||
nss-with-no-reply)))
|
||||
|
||||
(define (dns-query-with-cache question protocol nameservers tried)
|
||||
(let ((qds (message:questions (parse question))))
|
||||
|
|
@ -940,7 +975,8 @@
|
|||
(if (null? ns)
|
||||
(receive (reply-msg hit-ns nss-with-no-reply)
|
||||
(send-receive-message nameservers question protocol)
|
||||
(update-cache! (make-key qds hit-ns) (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
|
||||
(update-cache! (make-key qds hit-ns)
|
||||
(make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
|
||||
;; returns new retrieved data and updates cache
|
||||
(values (make-dns-message (parse question) reply-msg #f protocol (reverse tried))
|
||||
hit-ns
|
||||
|
|
@ -974,19 +1010,20 @@
|
|||
;; dns-get-information implements the resovler-side recursion.
|
||||
;; it returns a dns-message
|
||||
(define (dns-get-information question use-cache? protocol nameservers check-answer)
|
||||
(if *debug* (display "dns-get-information\n"))
|
||||
(let lp ((tried '()) (nss nameservers))
|
||||
(if (null? nss)
|
||||
(signal 'bad-address)
|
||||
(dns-error 'bad-address)
|
||||
(receive (dns-msg hit-ns nss-with-no-reply)
|
||||
(dns-query/cache question use-cache? protocol nss tried)
|
||||
(if *debug* (display "dns-get-information:check-success\n"))
|
||||
(if (check-answer dns-msg)
|
||||
dns-msg
|
||||
(let ((auth? (not (zero? (flags:auth (header:flags
|
||||
(message:header (dns-message:reply dns-msg))))))))
|
||||
(let ((auth? (not
|
||||
(zero?
|
||||
(flags:auth (header:flags
|
||||
(message:header
|
||||
(dns-message:reply dns-msg))))))))
|
||||
(if auth?
|
||||
(signal 'bad-address)
|
||||
(dns-error 'bad-address)
|
||||
;; other nameservers names are found in the nameserver-part,
|
||||
;; but their ip-adresses are found in the additonal-rrs
|
||||
(let ((other-nameservers
|
||||
|
|
@ -1006,9 +1043,11 @@
|
|||
(cond
|
||||
((eof-object? l)
|
||||
(if (null? ns)
|
||||
(signal 'no-nameservers)
|
||||
(dns-error 'no-nameservers)
|
||||
ns))
|
||||
((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
|
||||
((regexp-search
|
||||
(posix-string->regexp
|
||||
"nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
|
||||
=> (lambda (match)
|
||||
(loop (append ns (list (ip-string->address32 (match:substring match 1)))))))
|
||||
(else
|
||||
|
|
@ -1019,240 +1058,152 @@
|
|||
(define (dns-find-nameserver)
|
||||
(let ((ns (dns-find-nameserver-list)))
|
||||
(if (null? ns)
|
||||
(signal 'no-nameservers)
|
||||
(dns-error 'no-nameservers)
|
||||
(car ns))))
|
||||
|
||||
|
||||
|
||||
;; concurrent-lookup
|
||||
;; starts a <lookup>-lookup to all nameservers in (dns-find-nameserver-list)
|
||||
(define (concurrent-lookup lookup name nameservers)
|
||||
(let* ((return 'no-value)
|
||||
(lock (make-lock))
|
||||
(queue (make-queue))
|
||||
(nameserver-list (map (lambda (nameserver)
|
||||
(if (address32? nameserver)
|
||||
(address32->ip-string nameserver)
|
||||
nameserver))
|
||||
nameservers)))
|
||||
|
||||
(obtain-lock lock)
|
||||
|
||||
(spawn (lambda ()
|
||||
(for-each (lambda (nameserver)
|
||||
(spawn
|
||||
(lambda ()
|
||||
;(display "query sent to ")(display nameserver)(display " \n")
|
||||
(let* ((result (apply lookup (list name nameserver))))
|
||||
(enqueue! queue result)
|
||||
;(display "received reply from ")(display nameserver)(display ": ")(display result)(newline)
|
||||
(release-lock lock)))))
|
||||
nameserver-list)))
|
||||
|
||||
(obtain-lock lock)
|
||||
(let loop ((count (length nameserver-list)))
|
||||
(if (not (queue-empty? queue))
|
||||
(let ((result (dequeue! queue)))
|
||||
(if (or result (= 1 (length nameserver-list)))
|
||||
result
|
||||
(loop (- count 1))))))))
|
||||
|
||||
;; checks the arguments of the simple lookup functions.
|
||||
;; checks the nameservers argument of the lookup functions.
|
||||
;; if a nameserver-name is given and not a nameserver-ip
|
||||
;; (dns-lookup-name nameserver) is called.
|
||||
(define (check-args args)
|
||||
(if (null? args)
|
||||
(address32->ip-string (dns-find-nameserver) )
|
||||
(let ((nameserver (car args)))
|
||||
(cond
|
||||
((ip-string? nameserver) nameserver)
|
||||
((address32? nameserver) (address32->ip-string nameserver))
|
||||
(else (address32->ip-string (dns-lookup-name nameserver)))))))
|
||||
|
||||
(dns-find-nameserver-list)
|
||||
(map (lambda (nameserver)
|
||||
(cond
|
||||
((address32? nameserver) nameserver)
|
||||
((ip-string? nameserver) (ip-string->address32 nameserver))
|
||||
(else (dns-lookup-name nameserver (dns-find-nameserver-list)))))
|
||||
(car args))))
|
||||
|
||||
;; dns-lookup with more options than dns-lookup-*
|
||||
;; optional: nameserver could be passed to the function.
|
||||
(define (dns-lookup name type . args)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (if (address32? name)
|
||||
(define (dns-lookup name type . nameservers)
|
||||
(let* ((maybe-ip-string (if (address32? name)
|
||||
(ip-string->in-addr (address32->ip-string name))
|
||||
(ip-string->in-addr name)))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string type 'in)
|
||||
(make-octet-query-message (random 256) name type 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg) #t))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (message:answers (dns-message:reply dns-msg))))
|
||||
(if (not (null? answers))
|
||||
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
|
||||
(display "no answers received - but resolved information in other sections.\n"))
|
||||
dns-msg))))))
|
||||
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) maybe-ip-string type 'in)
|
||||
(make-octet-query-message (random 256) name type 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameservers (check-args nameservers))
|
||||
(check-answer (lambda (dns-msg) #t))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
||||
(answers (message:answers (dns-message:reply dns-msg))))
|
||||
(if (not (null? answers))
|
||||
(for-each (lambda (x) (show-dns-message x)(newline)) answers)
|
||||
;;; TODO remove display
|
||||
(display "no answers received - but resolved information in other sections.\n"))
|
||||
dns-msg))
|
||||
|
||||
|
||||
;; returns a lookup-function with concurrent-flag
|
||||
(define (make-lookup-function simple-lookup-function)
|
||||
(lambda (name . args)
|
||||
(if (null? args)
|
||||
(simple-lookup-function name)
|
||||
(if (list? (car args))
|
||||
(concurrent-lookup simple-lookup-function name (car args))
|
||||
(simple-lookup-function name (car args))))))
|
||||
|
||||
;; looks up a hostname, returns an ip.
|
||||
;; (dns-lookup-name <name> nameservers)
|
||||
(define (dns-simple-lookup-name name nameservers)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (if (address32? name)
|
||||
(define (dns-lookup-name name . nameservers)
|
||||
(let* ((maybe-ip-string (if (address32? name)
|
||||
(ip-string->in-addr (address32->ip-string name))
|
||||
(ip-string->in-addr name)))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(signal 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'a 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'a))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
|
||||
(rr-data-a:ip (rr:data (car answers)))))))))
|
||||
|
||||
(define dns-lookup-name (make-lookup-function dns-simple-lookup-name))
|
||||
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(dns-error 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'a 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameservers (check-args nameservers))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'a))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
|
||||
(rr-data-a:ip (rr:data (car answers)))))
|
||||
|
||||
;; looks up an ip, returns a hostname
|
||||
;; (dns-inverse-lookup <name> [nameserver])
|
||||
(define (dns-simple-lookup-ip ip . args)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (if (address32? ip)
|
||||
(define (dns-lookup-ip ip . nameservers)
|
||||
(let* ((maybe-ip-string (if (address32? ip)
|
||||
(ip-string->in-addr (address32->ip-string ip))
|
||||
(ip-string->in-addr ip)))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) ip-string 'ptr 'in)
|
||||
(signal 'not-a-ip)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'ptr))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
|
||||
(rr-data-ptr:name (rr:data (car answers)))))))))
|
||||
|
||||
(define dns-lookup-ip (make-lookup-function dns-simple-lookup-ip))
|
||||
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(make-octet-query-message (random 256) maybe-ip-string 'ptr 'in)
|
||||
(dns-error 'not-a-ip)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameservers (check-args nameservers))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply)))
|
||||
(not (null? (filter-type answers 'ptr))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
||||
(answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
|
||||
(rr-data-ptr:name (rr:data (car answers)))))
|
||||
|
||||
(define dns-inverse-lookup dns-lookup-ip)
|
||||
|
||||
|
||||
;; looks up an authoritative nameserver for a hostname
|
||||
;; returns a list of nameservers
|
||||
;; (dns-lookup-nameserver <name> [nameserver])
|
||||
(define (dns-simple-lookup-nameserver name . args)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (if (address32? name)
|
||||
(define (dns-lookup-nameserver name . nameservers)
|
||||
(let* ((maybe-ip-string (if (address32? name)
|
||||
(ip-string->in-addr (address32->ip-string name))
|
||||
(ip-string->in-addr name)))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(signal 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'ns 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply))
|
||||
(nameservers (message:nameservers reply)))
|
||||
(or (not (null? (filter-type nameservers 'soa)))
|
||||
(not (null? (filter-type answers 'ns)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(nss (filter-type (message:answers reply) 'ns))
|
||||
(add (filter-type (message:additionals reply) 'a)))
|
||||
(if (null? nss)
|
||||
(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
|
||||
(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))))))
|
||||
|
||||
(define dns-lookup-nameserver (make-lookup-function dns-simple-lookup-nameserver))
|
||||
|
||||
(question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(dns-error 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'ns 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'udp)
|
||||
(nameservers (check-args nameservers))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply))
|
||||
(nameservers (message:nameservers reply)))
|
||||
(or (not (null? (filter-type nameservers 'soa)))
|
||||
(not (null? (filter-type answers 'ns)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(nss (filter-type (message:answers reply) 'ns))
|
||||
(add (filter-type (message:additionals reply) 'a)))
|
||||
(if (null? nss)
|
||||
(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
|
||||
(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))
|
||||
|
||||
;; looks up a mail-exchanger for a hostname.
|
||||
;; returns a list of mail-exchanger, sorted by their preference
|
||||
;; if there are no mx-records in the answer-section,
|
||||
;; implementation based on RFC2821
|
||||
;; (dns-lookup-mail-exchanger <name> [nameserver])
|
||||
(define (dns-simple-lookup-mail-exchanger name . args)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(dns-error-messages condition more)
|
||||
(exit #f))
|
||||
(lambda ()
|
||||
(let* ((ip-string (if (address32? name)
|
||||
(ip-string->in-addr (address32->ip-string name))
|
||||
(ip-string->in-addr name)))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(signal 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'mx 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'tcp)
|
||||
(nameserver (check-args args))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply))
|
||||
(nameservers (message:nameservers reply)))
|
||||
(or (not (null? (filter-type answers 'mx)))
|
||||
(not (null? (filter-type answers 'cname)))
|
||||
(not (null? (filter-type answers 'a)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(mx (filter-type (message:answers reply) 'mx))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(cname (filter-type (message:answers reply) 'cname))
|
||||
(a (filter-type (message:answers reply) 'a)))
|
||||
|
||||
(cond
|
||||
((not (null? a))
|
||||
(list (rr-data-a:ip (rr:data (car a)))))
|
||||
((not (null? cname))
|
||||
(dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname)))))
|
||||
((null? mx)
|
||||
(list (rr-data-soa:rname (rr:data (car soa)))))
|
||||
(else
|
||||
(map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))))))
|
||||
|
||||
(define dns-lookup-mail-exchanger (make-lookup-function dns-simple-lookup-mail-exchanger))
|
||||
(define (dns-lookup-mail-exchanger name . nameservers)
|
||||
(let* ((ip-string (if (address32? name)
|
||||
(ip-string->in-addr (address32->ip-string name))
|
||||
(ip-string->in-addr name)))
|
||||
(question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
|
||||
(dns-error 'not-a-hostname)
|
||||
(make-octet-query-message (random 256) name 'mx 'in)))
|
||||
(use-cache? #t)
|
||||
(protocol 'tcp)
|
||||
(nameservers (check-args nameservers))
|
||||
(check-answer (lambda (dns-msg)
|
||||
(let* ((reply (dns-message:reply dns-msg))
|
||||
(answers (message:answers reply))
|
||||
(nameservers (message:nameservers reply)))
|
||||
(or (not (null? (filter-type answers 'mx)))
|
||||
(not (null? (filter-type answers 'cname)))
|
||||
(not (null? (filter-type answers 'a)))))))
|
||||
(dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
|
||||
(reply (dns-message:reply dns-msg))
|
||||
(mx (filter-type (message:answers reply) 'mx))
|
||||
(soa (filter-type (message:nameservers reply) 'soa))
|
||||
(cname (filter-type (message:answers reply) 'cname))
|
||||
(a (filter-type (message:answers reply) 'a)))
|
||||
|
||||
(cond
|
||||
((not (null? a))
|
||||
(list (rr-data-a:ip (rr:data (car a)))))
|
||||
((not (null? cname))
|
||||
(dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname)))))
|
||||
((null? mx)
|
||||
(list (rr-data-soa:rname (rr:data (car soa)))))
|
||||
(else
|
||||
(map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))
|
||||
|
||||
;;; pretty-prints a dns-msg
|
||||
(define (show-dns-message dns-msg)
|
||||
|
|
@ -1381,6 +1332,7 @@
|
|||
fqdn))))
|
||||
(dns-lookup-ip ip32)))
|
||||
|
||||
;;; TODO THIS USES gethostbyname
|
||||
(define (host-fqdn name-or-socket-address)
|
||||
(if (socket-address? name-or-socket-address)
|
||||
(socket-address->fqdn name-or-socket-address #f)
|
||||
|
|
@ -1390,6 +1342,7 @@
|
|||
(host-info name-or-socket-address)))
|
||||
#f)))
|
||||
|
||||
;;; TODO THIS USES gethostbyname
|
||||
(define (system-fqdn)
|
||||
(internet-address->fqdn (car (host-info:addresses (host-info (system-name))))
|
||||
#t))
|
||||
|
|
|
|||
Loading…
Reference in New Issue