scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ Reworked condition signalling 

+ TCP almost works
+ Cleanup
This commit is contained in:
mainzelm 2002-11-25 16:47:00 +00:00
parent 6cc2305e6b
commit 5f3582d017
1 changed files with 258 additions and 305 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

563
scheme/lib/dns.scm
View File

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