; ; dns.scm ; ; Implementation of the RFC1035 ;;; This file is part of the Scheme Untergrund Networking package. ;;; Copyright (c) 2002 by Marcus Crestani. ;;; Copyright (c) 2002-2003 by Martin Gasbichler ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. ; domain names - implementation and specification ; based on the PLT-implementation. ; ; ; TODO: ; - test, test, test ; - types from newer RFCs (41, unknown) ; - more documentation ; ; --- ; sample usage & documentation: ; ; is a 32bit integer internet->address, shortly address32. ; is a string in standard dot notation "xxx.xxx.xxx.xxx". ; is a string ; ; can either be a domainname, an ip-string or an ip-address32. ; if it is a domainname, its ip is looked up on a nameserver listed in ; /etc/resolv.conf. ; ; (dns-find-nameserver) --> ; this parses the /etc/resolv.conf file and returns the first found ; nameserver in address32 format. ; ; ; ; (dns-lookup-name [nameserver]) --> ; (dns-lookup-ip [nameserver]) --> ; (dns-lookup-nameserver [nameserver]) ; --> ; (dns-lookup-mail-exchanger [nameserver]) ; --> ; ; dns-lookup-name, dns-lookup-ip, dns-lookup-nameserver and ; dns-lookup-mail-exchanger are "simple lookup functions", ; they return the wanted information or #f. ; dns-lookup-ip can either be given an ip-string or an ip-address32. ; ; concurrent dns lookup: ; if a list of nameservers is given to the optional argument, ; a concurrent lookup to all nameservers in this list is started. ; The nameservers in this list could either be ip-strings or ip-address32s. ; example: (dns-lookup-name "www.uni-tuebingen.de" (dns-find-nameserver-list)) ; starts an concurrent lookup which contacts all nameservers in ; /etc/resolv.conf. ; ; ; (dns-lookup [nameserver]) ; --> ; (show-dns-message the whole message, human readable ; ; a is a record, with several entries, which holds the whole ; query/response dialog. the simplest way to get detailed information about ; the record structure is to view the result of show-dns-message. ; ; dns-lookup returns much more information than the simple lookup functions, ; only useful in very special cases. ; ; ; some lookups return a hostname (e.g. mx). ; many applications need instead of a hostname a ip address. ; force-ip and force-ip-list guarantee that a ip address is ; returned. ; ; (force-ip ) --> ; (force-ip-list ) --> ; ; ; useful converters: ; ; (address32->ip-string ) -> ; (ip-string->address32 ) -> ;; --- error conditions ;; supertype of all errors signaled by this library (define-condition-type 'dns-error '(error)) (define dns-error? (condition-predicate 'dns-error)) (define-condition-type 'parse-error '(dns-error)) (define parse-error? (condition-predicate 'parse)) (define-condition-type 'unexpected-eof-from-server '(dns-error)) (define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server)) (define-condition-type 'bad-address '(dns-error)) (define bad-address? (condition-predicate 'bad-address)) (define-condition-type 'no-nameservers '(dns-error)) (define no-nameservers? (condition-predicate 'no-nameservers)) (define-condition-type 'no-nameserver-given '(dns-error)) (define no-nameserver-given? (condition-predicate 'no-nameserver-given)) (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)) (define-condition-type 'not-a-ip '(dns-error)) (define not-a-ip? (condition-predicate 'not-a-ip)) ;; supertype of all errors signaled if the dns server returned a non-sero ;; reply code (define-condition-type 'dns-server-error '(dns-error)) (define dns-server-error? (condition-predicate 'dns-server-error)) (define-condition-type 'dns-format-error '(dns-server-error)) (define dns-format-error? (condition-predicate 'dns-format-error)) (define-condition-type 'dns-server-failure '(dns-server-error)) (define dns-server-failure? (condition-predicate 'dns-server-failure)) (define-condition-type 'dns-name-error '(dns-server-error)) (define dns-name-error? (condition-predicate 'dns-name-error)) (define-condition-type 'dns-not-implemented '(dns-server-error)) (define dns-not-implemented? (condition-predicate 'dns-not-implemented)) (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)) (define (dns-error->string condition) (string-append "dns-error: " (case condition ((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") ((no-nameserver-given) "dns-find-nameserver: no nameservers given") ((bad-nameserver) "send-receive-message: could not establish connection to server (no valid nameserver given)") ((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 ;; off (define *nul* (ascii->char 0)) ;; on (define *on* (ascii->char 1)) ;; message types (define-enumerated-type message-type :message-type message-type? the-message-types message-type-name message-type-number (unknown ; types, which are not yet implemented a ; a host address ns ; an authoritative name server md ; (obsolete) mf ; (obsolete) cname ; the canonical name for an alias soa ; marks the start of a zone of authority mb ; (experimental) mg ; (experimental) mr ; (experimental) null ; (experimental) wks ; a well known service description ptr ; a domain name pointer hinfo ; host information minfo ; (experimental) mx ; mail exchange txt)) ; text strings ;; message classes (define-enumerated-type message-class :message-class message-class? the-message-classes message-class-name message-class-number (placeholder ; this starts at 0... in ; the Internet cs ; (obsolete) ch ; the CHAOS class hs)) ; Hesoid ;;; -- useful stuff ;; number: 0<= x < 256 ;; octet-pair: (char char) ;; octet-quad: (char char char char) ;; name: string *{"." string} ;; octets: *{(char *char)} nullchar ;; octet-ip: (char char char char) ;; address32: 0 <= x < 2^32-1 ;; ip-string: "www.xxx.yyy.zzz" ;; ip-string-arpa: "zzz.yyy.xxx.www.in-addr.arpa" ;; encodes numbers (16bit) to octets (define (number->octet-pair n) (list (ascii->char (arithmetic-shift n -8)) (ascii->char (modulo n 256)))) ;; decodes octets to numbers (16bit) (define (octet-pair->number a b) (+ (arithmetic-shift (char->ascii a) 8) (char->ascii b))) ;; encodes numbers (32bit) to octets, needed for ttl (define (number->octet-quad n) (list (ascii->char (arithmetic-shift n -24)) (ascii->char (modulo (arithmetic-shift n -16) 256)) (ascii->char (modulo (arithmetic-shift n -8) 256)) (ascii->char (modulo n 256)))) ;; decodes octets to numbers, needed for 32bit ttl (define (octet-quad->number a b c d) (+ (arithmetic-shift (char->ascii a) 24) (arithmetic-shift (char->ascii b) 16) (arithmetic-shift (char->ascii c) 8) (char->ascii d))) ;; encodes a domain-name string to octets (define (name->octets s) (define (encode-portion s) (cons (ascii->char (string-length s)) (string->list s))) (let loop ((s s)) (cond ((regexp-search (rx (: bos (submatch (* (~ "."))) "." (submatch (* any)))) s) => (lambda (match) (append (encode-portion (match:substring match 1)) (loop (match:substring match 2))))) (else (if (= 0 (string-length s)) (list *nul*) ;;; TODO isn't this case an error? (append (encode-portion s) (list *nul*))))))) ;; for tcp: message has to be tagged with its length (define (add-size-tag m) (append (number->octet-pair (length m)) m)) ;; calculates a "random" number, needed for message-ids ;; TODO use SRFI-27 (define random (let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) (lambda (limit) (quotient (* (modulo (crank) 314159265) limit) 314159265)))) ;; checks if v is a address32 (define (address32? v) (and (number? v) (<= 0 v #xffffffff))) ;; filters types in a list of rrs (define (filter-type list type) (filter (lambda (rr) (eq? (resource-record-type rr) type)) list)) ;; sorts a mx-resource-record-list by preference. needed for dns-lookup-mail-exchanger. (define (sort-by-preference mx-list) (sort-list mx-list (lambda (a b) (< (resource-record-data-mx-preference (resource-record-data a)) (resource-record-data-mx-preference (resource-record-data b)))))) ;; returns a IP if available (additonal type-a processing) (define (force-ip name) (let loop ((result (dns-lookup-name name))) (if (ip-string? result) result (loop (dns-lookup-name result))))) ;; returns a list of IPs (additional type-a processing) (define (force-ip-list names) (map (lambda (elem) (force-ip elem)) names)) ;; a standard query header, usefull for most queries (define (make-std-query-header id question-count) (let* ((qr 'query) ; querytype: query 0, response 1 (opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2 (aa #f) ; authorative answer (in answers only) (tc #f) ; truncation (size matters only with UDP) (rd #t) ; recursion desired: nameserver pursues the query recursivly (optional) (ra #f) ; recursion available (in answers only) (zero 0) ; future use (response-code 0) ; response code: error conditions (in answers only) (question-count question-count) (answer-count 0) ; answer count (in answers only) (nameserver-count 0) ; name server resources (in answers only) (additional-count 0)) ; additional records (in answers only) (make-header id (make-flags qr opcode aa tc rd ra zero response-code) question-count answer-count nameserver-count additional-count))) ;; makes a query-message (header and question only) ;; TODO does this really work for several questions as well? (define (make-query-message header question . questions) (let ((questions (cons question questions))) (make-message header questions '() '() '() (apply append (header->octets header) (map question->octets questions))))) (define (make-simple-query-message name type class) (make-query-message (make-std-query-header (random 256) 1) (make-question name type class))) ;; makes a resource record for ans, nss, ars (name, type, class, ttl, data) (define (make-octet-rr name type class ttl rdata) (let* ((name (name->octets name)) (type (number->octet-pair (message-type-number type))) (class (number->octet-pair (message-class-number class))) (ttl (number->octet-quad ttl)) (rdlength (number->octet-pair (length rdata))) (rdata rdata)) (append name type class ttl rdlength rdata))) ;;; -- parsed message records ;;; -- dns-message: complete data-structure of an dns-lookup (define-record-type dns-message :dns-message (make-dns-message query reply cache? protocol tried-nameservers) dns-message? (query dns-message-query) (reply dns-message-reply) (cache? dns-message-cache?) (protocol dns-message-protocol) (tried-nameservers dns-message-tried-nameservers)) ;; message (define-record-type message :message (make-message header questions answers nameservers additionals source) message? (header message-header) (questions message-questions) (answers message-answers) (nameservers message-nameservers) (additionals message-additionals) (source message-source)) ;; header (define-record-type header :header (make-header id flags question-count answer-count nameserver-count additional-count) header? (id header-id) (flags header-flags) (question-count header-question-count) (answer-count header-answer-count) (nameserver-count header-nameserver-count) (additional-count header-additional-count)) ;;; -- message constructors: encode to octet-messages ;; makes an message header (define (header->octets header) (let* ((header-id (number->octet-pair (header-id header))) (header-question-count (number->octet-pair (header-question-count header))) (header-answer-count (number->octet-pair (header-answer-count header))) (header-nameserver-count (number->octet-pair (header-nameserver-count header))) (header-additional-count (number->octet-pair (header-additional-count header)))) (append header-id (flags->octets (header-flags header)) header-question-count header-answer-count header-nameserver-count header-additional-count))) ;; flags (define-record-type flags :flags (make-flags query-type opcode authoritative? truncated? recursion-desired? recursion-available? zero response-code) flags? (query-type flags-query-type) (opcode flags-opcode) (authoritative? flags-authoritative?) (truncated? flags-truncated?) (recursion-desired? flags-recursion-desired?) (recursion-available? flags-recursion-available?) (zero flags-zero) (response-code flags-response-code)) (define (make-flags-from-numbers querytype opcode authoritative? truncated? recursion-desired? recursion-available? zero response-code) (make-flags (if (zero? querytype) 'query 'response) opcode (not (zero? authoritative?)) (not (zero? truncated?)) (not (zero? recursion-desired?)) (not (zero? recursion-available?)) zero (case response-code ((0) 'dns-no-error) ((1) 'dns-format-error) ((2) 'dns-server-failure) ((3) 'dns-name-error) ((4) 'dns-not-implemented) ((5) 'dns-refused)))) (define (flags->octets flags) (define (boolean->0/1 bool) (if bool 1 0)) (list (ascii->char (+ (arithmetic-shift (if (eq? (flags-query-type flags) 'query) 0 1) 7) (arithmetic-shift (flags-opcode flags) 3) (arithmetic-shift (boolean->0/1 (flags-authoritative? flags)) 2) (arithmetic-shift (boolean->0/1 (flags-truncated? flags)) 1) (boolean->0/1 (flags-recursion-desired? flags)))) (ascii->char (+ (arithmetic-shift (boolean->0/1 (flags-recursion-available? flags)) 7) (arithmetic-shift (flags-zero flags) 4) (flags-response-code flags))))) ;; question (define-record-type question :question (make-question name type class) question? (name question-name) (type question-type) (class question-class)) ;; makes a question (name, type, class) (define (question->octets q) (let* ((qname (name->octets (question-name q))) (qtype (number->octet-pair (message-type-number (question-type q)))) (qclass (number->octet-pair (message-class-number (question-class q))))) (append qname qtype qclass))) ;;type resource-record (define-record-type resource-record :resource-record (make-resource-record name type class ttl data) resource-record? (name resource-record-name) (type resource-record-type) (class resource-record-class) (ttl resource-record-ttl) (data resource-record-data)) ;; cache (define-record-type cache :cache (make-cache answer ttl time) cache? (answer cache-answer) (ttl cache-ttl) (time cache-time)) ;;; -- message parser ;; parses a domain-name in an message. returns the name and the rest of the message. (define (parse-name start message) (let ((v (char->ascii (car start)))) (cond ((zero? v) ;; End of name (values #f (cdr start))) ((zero? (bitwise-and #xc0 v)) ;; Normal label (let loop ((len v) (start (cdr start)) (accum '())) (cond ((zero? len) (call-with-values (lambda () (parse-name start message)) (lambda (s start) (let ((s0 (list->string (reverse! accum)))) (values (if s (string-append s0 "." s) s0) start))))) (else (loop (- len 1) (cdr start) (cons (car start) accum)))))) (else ;; Compression offset (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) (char->ascii (cadr start))))) (call-with-values (lambda () (parse-name (list-tail message offset) message)) (lambda (s ignore-start) (values s (cddr start))))))))) ;; parses a question in a message. returns the question and the rest of the message. (define (parse-question start message) (call-with-values (lambda () (parse-name start message)) (lambda (name start) (let ((type (vector-ref the-message-types (octet-pair->number (car start) (cadr start)))) (start (cddr start))) (let ((class (vector-ref the-message-classes (octet-pair->number (car start) (cadr start)))) (start (cddr start))) (values (make-question name type class) start)))))) ;; parses a resourcerecord in a message. returns the rr and the rest of the message. (define (parse-rr start message) (call-with-values (lambda () (parse-name start message)) (lambda (name start) (let ((type (vector-ref the-message-types (octet-pair->number (car start) (cadr start)))) (start (cddr start))) (let ((class (vector-ref the-message-classes (octet-pair->number (car start) (cadr start)))) (start (cddr start))) (let ((ttl (octet-quad->number (car start) (cadr start) (caddr start) (cadddr start))) (start (cddddr start))) (let ((len (octet-pair->number (car start) (cadr start))) (start (cddr start))) ;; Extract next len bytes of data: (let loop ((len len) (start start) (accum '())) (if (zero? len) (values (make-resource-record name type class ttl (parse-resource-record-data type class (reverse! accum) message)) start) (loop (- len 1) (cdr start) (cons (car start) accum))))))))))) ;;; -- resource-record-data-type records (define-record-type resource-record-data-a :resource-record-data-a (make-resource-record-data-a ip) resource-record-data-a? (ip resource-record-data-a-ip)) (define-record-type resource-record-data-ns :resource-record-data-ns (make-resource-record-data-ns name) resource-record-data-ns? (name resource-record-data-ns-name)) (define-record-type resource-record-data-cname :resource-record-data-cname (make-resource-record-data-cname name) resource-record-data-cname? (name resource-record-data-cname-name)) ;; ### ;; hinfo not correctly implemented, trying to find examples (define-record-type resource-record-data-hinfo :resource-record-data-hinfo (make-resource-record-data-hinfo data) resource-record-data-hinfo? (data resource-record-data-hinfo-data)) (define-record-type resource-record-data-mx :resource-record-data-mx (make-resource-record-data-mx preference exchanger) resource-record-data-mx? (preference resource-record-data-mx-preference) (exchanger resource-record-data-mx-exchanger)) (define-record-type resource-record-data-ptr :resource-record-data-ptr (make-resource-record-data-ptr name) resource-record-data-ptr? (name resource-record-data-ptr-name)) (define-record-type resource-record-data-soa :resource-record-data-soa (make-resource-record-data-soa mname rname serial refresh retry expire minimum) resource-record-data-soa? (mname resource-record-data-soa-mname) (rname resource-record-data-soa-rname) (serial resource-record-data-soa-serial) (refresh resource-record-data-soa-refresh) (retry resource-record-data-soa-retry) (expire resource-record-data-soa-expire) (minimum resource-record-data-soa-minimum)) ;; ### same as hinfo (define-record-type resource-record-data-txt :resource-record-data-txt (make-resource-record-data-txt text) resource-record-data-txt? (text resource-record-data-txt-text)) ;; ### same as hinfo and txt (define-record-type resource-record-data-wks :resource-record-data-wks (make-resource-record-data-wks data) resource-record-data-wks? (data resource-record-data-wks-data)) ;; (define (parse-resource-record-data type class data message) (cond ((eq? type (message-type a)) (make-resource-record-data-a (octet-ip->address32 data))) ((eq? type (message-type ns)) (make-resource-record-data-ns (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type cname)) (make-resource-record-data-cname (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type mx)) (make-resource-record-data-mx (octet-pair->number (car data) (cadr data)) (call-with-values (lambda ()(parse-name (cddr data) message)) (lambda (name rest) name)))) ((eq? type (message-type ptr)) (make-resource-record-data-ptr (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type soa)) (call-with-values (lambda () (parse-name data message)) (lambda (mname rest) (call-with-values (lambda () (parse-name rest message)) (lambda (rname rest) (let ((serial (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) (rest (cddddr rest))) (let ((refresh (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) (rest (cddddr rest))) (let ((retry (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) (rest (cddddr rest))) (let ((expire (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) (rest (cddddr rest))) (let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) (rest (cddddr rest))) (make-resource-record-data-soa mname rname serial refresh retry expire minimum))))))))))) ((eq? type (message-type hinfo)) (make-resource-record-data-hinfo (list->string data))) ((eq? type (message-type txt)) (make-resource-record-data-txt (list->string data))) ((eq? type (message-type wks)) (make-resource-record-data-wks data)) (else (list data)))) ;; parses n-times a message with parse. returns a list of parse-returns. (define (parse-n parse start message n) (let loop ((n n) (start start) (accum '())) (if (zero? n) (values (reverse! accum) start) (call-with-values (lambda () (parse start message)) (lambda (rr start) (loop (- n 1) start (cons rr accum))))))) ;; parses a message-headers flags. returns the flags. (define (parse-flags message) (let ((v0 (list-ref message 2)) (v1 (list-ref message 3))) ;; Check for error code: (let ((response-code (bitwise-and #xf (char->ascii v1))) (zero (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4)) (ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7)) (rd (bitwise-and 1 (char->ascii v0))) (tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1)) (aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2)) (opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3)) (qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7))) (make-flags-from-numbers qr opcode aa tc rd ra zero response-code)))) ;; parses a message-header. returns the header. (define (parse-header message) (let ((id (octet-pair->number (list-ref message 0) (list-ref message 1))) (flags (parse-flags message)) (question-count (octet-pair->number (list-ref message 4) (list-ref message 5))) (an-count (octet-pair->number (list-ref message 6) (list-ref message 7))) (ns-count (octet-pair->number (list-ref message 8) (list-ref message 9))) (ar-count (octet-pair->number (list-ref message 10) (list-ref message 11)))) (make-header id flags question-count an-count ns-count ar-count))) ;; parses a message. returns the parsed message. (define (parse message) (let* ((header (parse-header message)) (start (list-tail message 12))) (call-with-values (lambda () (parse-n parse-question start message (header-question-count header))) (lambda (qds start) (call-with-values (lambda () (parse-n parse-rr start message (header-answer-count header))) (lambda (ans start) (call-with-values (lambda () (parse-n parse-rr start message (header-nameserver-count header))) (lambda (nss start) (call-with-values (lambda () (parse-n parse-rr start message (header-additional-count header))) (lambda (ars start) (if (not (null? start)) (dns-error 'parse-error)) (make-message header qds ans nss ars message))))))))))) ;;; -- send, receive and validate message ;; checks if the received reply is valid. returns #t or error-msg. (define (reply-acceptable? reply query) ;; Check correct id (if (not (= (header-id (message-header reply)) (header-id (message-header query)))) ;; TODO replace error (error "send-receive-message: bad reply id from server")) ;; Check for error code: (let ((response-code (flags-response-code (header-flags (message-header reply))))) (if (not (eq? response-code 'dns-no-error)) (dns-error response-code)))) (define *max-tries* 3) (define *timeout* 1) ;; connects to nameserver and sends and receives messages. returns the reply. ;; here: via TCP (define (send-receive-message-tcp nameservers query) (receive (reply hit-ns other-nss) (let ((sockets (filter socket? (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 (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) (k #f)) (lambda () (connect-socket-no-wait sock addr) sock)))))) nameservers)))) (let* ((ws (map socket:outport sockets)) (wport-nameserver-alist (map cons ws nameservers)) (wport-socket-alist (map cons ws sockets))) (dynamic-wind (lambda () 'nothing-to-be-done-before) (lambda () (let loop-port-channels ((tried-channels '()) (number-tries 1)) (letrec ((delete-list (lambda (elems list) (cond ((null? elems) list) ((null? list) '()) (else (delete-list (cdr elems) (delete (car elems) list)))))) (ws-new (delete-list tried-channels ws))) (if (or (null? ws-new) (>= number-tries *max-tries*)) (dns-error 'bad-nameserver) (let ((ready (apply select-port-channels *timeout* ws))) (if (= (length tried-channels) (length ws)) (dns-error 'bad-nameserver) (let loop-ready-channels ((ready-channels ready)) (if (null? ready-channels) (loop-port-channels (append tried-channels ready) (+ number-tries 1)) (let* ((w (car ready-channels)) (hit-ns (cdr (assoc w wport-nameserver-alist))) (sock (cdr (assoc w wport-socket-alist)))) (if (not (connect-socket-successful? sock)) (loop-ready-channels (cdr ready-channels)) (let ((query-string (list->string (add-size-tag (message-source query)))) (r (socket:inport sock))) (call-with-current-continuation (lambda (k) (with-handler (lambda (k) (k (loop-ready-channels (cdr ready-channels)))) (lambda () (display query-string 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 (and (not (= 0 (string-length s))) (not (= len (string-length s)))) (dns-error 'unexpected-eof-from-server)) (values (parse (string->list s)) hit-ns (delete hit-ns nameservers)))))))))))))))))))) (lambda () (for-each close-socket sockets))))) (reply-acceptable? reply query) (values reply hit-ns other-nss))) ;; here: via UDP (define (send-receive-message-udp nameservers query) (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 (message-source 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) (let loop-port-channels ((tried-channels '()) (number-tries 1)) (letrec ((delete-list (lambda (elems list) (cond ((null? elems) list) ((null? list) '()) (else (delete-list (cdr elems) (delete (car elems) list)))))) (rs-new (delete-list tried-channels rs))) (if (or (null? rs-new) (>= number-tries *max-tries*)) (dns-error 'bad-nameserver) (let ((ready (apply select-port-channels *timeout* rs-new))) (if (= (length tried-channels) (length rs)) (dns-error 'bad-nameserver) (let loop-ready-channels ((ready-channels ready)) (if (null? ready-channels) (loop-port-channels (append tried-channels ready) (+ number-tries 1)) (let* ((r (car ready-channels)) (hit-ns (cdr (assoc r rport-nameserver-alist)))) (if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist)))) (loop-ready-channels (cdr ready-channels)) ;; 512 is the maximum udp-message size: (let ((answer (string->list (read-string/partial 512 r)))) (if (null? answer) (loop-ready-channels (cdr ready-channels)) (values (parse answer) hit-ns (delete hit-ns nameservers))))))))))))))) (lambda () (for-each close-socket sockets))))) (reply-acceptable? reply query) (if (flags-truncated? (header-flags (message-header reply))) (send-receive-message-tcp nameservers query) (values reply hit-ns other-nss)))) ;;; -- cache ;; creates the cache, an empty string-table (define cache (make-string-table)) ;; resets the cache (define (dns-clear-cache!) (set! cache (make-string-table))) ;; searches in a dns-msg for the shortest ttl. this is needed for cache-management. (define (find-shortest-ttl dns-msg) (letrec ((minimum #f) (find-shortest-ttl-1 (lambda (dns-msg) (cond ((dns-message? dns-msg) (find-shortest-ttl-1 (dns-message-reply dns-msg))) ((message? dns-msg) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-answers dns-msg)) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-nameservers dns-msg)) (for-each (lambda (x) (find-shortest-ttl-1 x)) (message-additionals dns-msg)) minimum) ((resource-record? dns-msg) (cond ((not minimum) (set! minimum (resource-record-ttl dns-msg))) (else (if (and (not minimum) (> minimum (resource-record-ttl dns-msg))) (set! minimum (resource-record-ttl dns-msg)))))))))) (find-shortest-ttl-1 dns-msg))) (define (make-key qds nameserver) (let*;; cache-key relevant data ((name (question-name (car qds))) (type (question-type (car qds))) (class (question-class (car qds)))) (format #f "~a;~a;~a;~a" nameserver name (message-type-name type) (message-class-name class)))) (define (lookup-cache qds nameserver) (let* ((key (make-key qds nameserver)) (found-data (table-ref cache key))) (cond ((and found-data ;; checks if cached-data is still valid (< (time) (+ (cache-time found-data) (cache-ttl found-data)))) found-data) (else #f)))) (define (update-cache! key entry) (table-set! cache key entry)) (define (dns-query-no-cache query protocol nameservers tried) ;; returns new retrieved data (receive (dns-msg hit-ns nss-with-no-reply) (send-receive-message nameservers query protocol) (values (make-dns-message query dns-msg #f protocol (reverse tried)) hit-ns nss-with-no-reply))) (define (dns-query-with-cache query protocol nameservers tried) (let ((qds (message-questions query))) (let lp ((ns nameservers)) (if (null? ns) (receive (reply-msg hit-ns nss-with-no-reply) (send-receive-message nameservers query protocol) (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 query reply-msg #f protocol (reverse tried)) hit-ns nss-with-no-reply)) (cond ((lookup-cache qds (car ns)) => (lambda (found-data) ;; returns cached data (values (make-dns-message query (cache-answer found-data) #t protocol '()) #f nameservers))) (else (lp (cdr ns)))))))) (define-enumerated-type network-protocol :network-protocol network-protocol? network-protocols network-protocol-name network-protocol-index (udp tcp)) (define (send-receive-message nameservers query protocol) ((cond ((eq? protocol (network-protocol tcp)) send-receive-message-tcp) ((eq? protocol (network-protocol udp)) send-receive-message-udp)) nameservers query)) ;; makes a dns-query. optional cache-check. ;; returns a dns-message with cache-flag and either cache-data or new received data. (define (dns-query/cache query use-cache? protocol nameservers tried) (if use-cache? (dns-query-with-cache query protocol nameservers tried) (dns-query-no-cache query protocol nameservers tried))) ;; dns and recursion ;; recursion means, if the demanded information is not available from the ;; nameserver, another nameserver (usualy an authority) has to be contacted. ;; normally the recursion is done for us by the nameserver istself, but ;; this feature is technically optional (RFC 1035). ;; dns-get-information implements the resovler-side recursion. ;; it returns a dns-message (define (dns-get-information query protocol check-answer . args) (receive (nameservers use-cache?) (lookup-optional-args args) (let lp ((tried '()) (nss nameservers)) (if (null? nss) (if (null? tried) (dns-error 'no-nameserver-given) (dns-error 'bad-address)) (receive (dns-msg hit-ns nss-with-no-reply) (dns-query/cache query use-cache? protocol nss tried) (if (check-answer dns-msg) dns-msg (let ((auth? (flags-authoritative? (header-flags (message-header (dns-message-reply dns-msg)))))) (if auth? (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 (filter (lambda (elem) (eq? (resource-record-type elem) (message-type a))) (message-additionals (dns-message-reply dns-msg))))) (lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried) (lset-union equal? nss-with-no-reply (lset-difference equal? other-nameservers tried)))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parsing of /etc/resolv.conf (define-condition-type 'resolv.conf-parse-error '(dns-error)) (define resolv.conf-parse-error? (condition-predicate 'resolv.conf-parse-error)) (define (parse-nameserver rest-of-line) (let ((match (regexp-search (rx (: (submatch (** 1 3 digit) "." (** 1 3 digit) "." (** 1 3 digit) "." (** 1 3 digit)) (* white))); don't complain about tailing white space rest-of-line))) (if match (cons 'nameserver (match:substring match 1)) (signal 'resolv.conf-parse-error)))) ; could be more restrictive... (define domain-name-regexp (rx (+ (| alphanum #\. #\-)))) (define (parse-domain rest-of-line) (let ((match (regexp-search (rx (: (submatch ,domain-name-regexp) (* white))); don't complain about tailing white space rest-of-line))) (if match (cons 'domain (match:substring match 1)) (signal 'resolv.conf-parse-error)))) (define (parse-search rest-of-line) (let ((domains (regexp-fold-right domain-name-regexp (lambda (match junk accu) (cons (match:substring match 0) accu)) '() rest-of-line))) (if (null? domains) (signal 'resolv.conf-parse-error) (cons 'search domains)))) (define (parse-sortlist rest-of-line) (let ((netmask-pairs (regexp-fold-right (rx (+ (| digit #\. #\/))) (lambda (match junk accu) (cons (match:substring match 0) accu)) '() rest-of-line))) (if (null? netmask-pairs) (signal 'resolv.conf-parse-error) (cons 'sortlist netmask-pairs)))) (define (parse-options rest-of-line) (regexp-fold-right (rx (| "debug" "no_tld_query" (: "ndots:" (submatch digit)))) (lambda (match junk accu) (let ((str (match:substring match 0))) (cond ((string=? str "debug") (cons 'debug accu)) ((string=? str "no_tld_query") (cons 'no_tld_query accu)) (else (cons (cons 'ndots (string->number (match:substring match 1))) accu))))) '() rest-of-line)) (define *resolv.conf-cache*) (define *resolv.conf-cache-date* 0) (define *resolv.conf-file* "/etc/resolv.conf") (define (resolv.conf) (let ((actual-m-time (file-info:mtime (file-info *resolv.conf-file*)))) (if (> actual-m-time *resolv.conf-cache-date*) (parse-resolv.conf!)) *resolv.conf-cache*)) (define (parse-resolv.conf!) (let ((actual-m-time (file-info:mtime (file-info *resolv.conf-file*))) (contents (really-parse-resolv.conf *resolv.conf-file*))) (set! *resolv.conf-cache* contents) (set! *resolv.conf-cache-date* actual-m-time))) (define (really-parse-resolv.conf file-name) ;; accumulate nameserver entries ;; domain and search are mutual exclusive, take the last (define (adjust-result rev-result have-search-or-domain? nameservers) (cond ((null? rev-result) (if (null? nameservers) '() (list (cons 'nameserver nameservers)))) ((eq? (caar rev-result) 'domain) (if have-search-or-domain? (adjust-result (cdr rev-result) have-search-or-domain? nameservers) (cons (car rev-result) (adjust-result (cdr rev-result) #t nameservers)))) ((eq? (caar rev-result) 'search) (if have-search-or-domain? (adjust-result (cdr rev-result) have-search-or-domain? nameservers) (cons (car rev-result) (adjust-result (cdr rev-result) #t nameservers)))) ((eq? (caar rev-result) 'nameserver) (adjust-result (cdr rev-result) have-search-or-domain? (cons (cdar rev-result) nameservers))) (else (cons (car rev-result) (adjust-result (cdr rev-result) have-search-or-domain? nameservers))))) (with-input-from-file file-name (lambda () (let loop ((rev-result '())) (let ((l (read-line))) (cond ((eof-object? l) (adjust-result rev-result #f '())) ((regexp-search (rx (: bos ("#;"))) l) (loop rev-result)) ((regexp-search (rx (: bos "nameserver" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-nameserver (match:substring match 1)) rev-result)))) ((regexp-search (rx (: bos "domain" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-domain (match:substring match 1)) rev-result)))) ((regexp-search (rx (: bos "search" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-search (match:substring match 1)) rev-result)))) ((regexp-search (rx (: bos "sortlist" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-sortlist (match:substring match 1)) rev-result)))) ((regexp-search (rx (: bos "options" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-options (match:substring match 1)) rev-result)))) ;; skips lines with parse errors, instead of ;; raising a 'resolv.conf-parse-error (else (loop rev-result)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Figure out the default name servers (define (dns-find-nameserver-list) (cond ((assoc 'nameserver (resolv.conf)) => (lambda (nameserver.list) (cdr nameserver.list))) (else '("127.0.0.1")))) ;; returns the first found nameserver (define (dns-find-nameserver) (let ((ns (dns-find-nameserver-list))) (if (null? ns) (dns-error 'no-nameservers) (car ns)))) ;; computes the nameservers argument of the lookup functions. ;; if a nameserver-name is given and not a nameserver-ip ;; (dns-lookup-name nameserver) is called. ;; use-cache? defaults to #t (define (lookup-optional-args args) (if (null? args) (values (map ip-string->address32 (dns-find-nameserver-list)) #t) (values (map (lambda (nameserver) (cond ((address32? nameserver) nameserver) ((ip-string? nameserver) (ip-string->address32 nameserver)) (else (map dns-lookup-name (dns-find-nameserver-list))))) (car args)) (if (null? (cdr args)) #t (cadr args))))) ;; dns-lookup with more options than dns-lookup-* (define (dns-lookup name type . args) (receive (nameservers use-cache?) (lookup-optional-args args) (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr.arpa-string (address32->ip-string name)) (ip-string->in-addr.arpa-string name))) (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (make-simple-query-message maybe-ip-string type (message-class in)) (make-simple-query-message name type (message-class in)))) (protocol (network-protocol udp)) (check-answer (lambda (dns-msg) #t)) (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) (answers (message-answers (dns-message-reply dns-msg)))) dns-msg))) ;; looks up a hostname, returns an ip. ;; (dns-lookup-name nameservers) (define (dns-lookup-name name . args) (receive (nameservers use-cache?) (lookup-optional-args args) (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr.arpa-string (address32->ip-string name)) (ip-string->in-addr.arpa-string name))) (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (dns-error 'not-a-hostname) (make-simple-query-message name (message-type a) (message-class in)))) (protocol (network-protocol udp)) (check-answer (lambda (dns-msg) (let* ((reply (dns-message-reply dns-msg)) (answers (message-answers reply))) (not (null? (filter-type answers (message-type a))))))) (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a)))) (resource-record-data-a-ip (resource-record-data (car answers)))))) ;; looks up an ip, returns a hostname ;; (dns-inverse-lookup [nameserver]) (define (dns-lookup-ip ip . args) (receive (nameservers use-cache?) (lookup-optional-args args) (let* ((maybe-ip-string (if (address32? ip) (ip-string->in-addr.arpa-string (address32->ip-string ip)) (ip-string->in-addr.arpa-string ip))) (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (make-simple-query-message maybe-ip-string (message-type ptr) (message-class in)) (dns-error 'not-a-ip))) (protocol (network-protocol udp)) (check-answer (lambda (dns-msg) (let* ((reply (dns-message-reply dns-msg)) (answers (message-answers reply))) (not (null? (filter-type answers (message-type ptr))))))) (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr)))) (resource-record-data-ptr-name (resource-record-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 [nameserver]) (define (dns-lookup-nameserver name . args) (receive (nameservers use-cache?) (lookup-optional-args args) (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr.arpa-string (address32->ip-string name)) (ip-string->in-addr.arpa-string name))) (query (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (dns-error 'not-a-hostname) (make-simple-query-message name (message-type ns) (message-class in)))) (protocol (network-protocol udp)) (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 (message-type soa)))) (not (null? (filter-type answers (message-type ns)))))))) (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) (reply (dns-message-reply dns-msg)) (soa (filter-type (message-nameservers reply) (message-type soa))) (nss (filter-type (message-answers reply) (message-type ns))) (add (filter-type (message-additionals reply) (message-type a)))) (if (null? nss) (list (dns-lookup-name (resource-record-data-soa-mname (resource-record-data (car soa))))) (map (lambda (elem) (resource-record-data-a-ip (resource-record-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 [nameserver]) (define (dns-lookup-mail-exchanger name . args) (receive (nameservers use-cache?) (lookup-optional-args args) (let* ((ip-string (if (address32? name) (ip-string->in-addr.arpa-string (address32->ip-string name)) (ip-string->in-addr.arpa-string name))) (query (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (dns-error 'not-a-hostname) (make-simple-query-message name (message-type mx) (message-class in)))) (protocol (network-protocol tcp)) (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 (message-type mx)))) (not (null? (filter-type answers (message-type cname)))) (not (null? (filter-type answers (message-type a)))))))) (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?)) (reply (dns-message-reply dns-msg)) (mx (filter-type (message-answers reply) (message-type mx))) (soa (filter-type (message-nameservers reply)(message-type soa))) (cname (filter-type (message-answers reply) (message-type cname))) (a (filter-type (message-answers reply) (message-type a)))) (cond ((not (null? a)) (list (resource-record-data-a-ip (resource-record-data (car a))))) ((not (null? cname)) (dns-lookup-mail-exchanger (resource-record-data-cname-name (resource-record-data (car cname))))) ((null? mx) (list (resource-record-data-soa-rname (resource-record-data (car soa))))) (else (map (lambda (elem) (resource-record-data-mx-exchanger (resource-record-data elem))) (sort-by-preference mx))))))) ;;; pretty-prints a dns-msg (define (pretty-print-dns-message dns-msg . maybe-port) (let ((d (lambda (n s1 s2) (letrec ((loop (lambda (n) (if (zero? n) "" (string-append " " (loop (- n 1))))))) (display (loop n)) (display s1) (display ": ") (display s2) (newline))))) (with-current-output-port* (if (null? maybe-port) (current-output-port) (car maybe-port)) (lambda () (define (show-dns-message dns-msg) (cond ((dns-message? dns-msg) (begin (d 0 "DNS-MESSAGE" "") (d 1 "QUERY" "")(show-dns-message (dns-message-query dns-msg))(newline) (d 1 "REPLY" "")(show-dns-message (dns-message-reply dns-msg))(newline) (d 1 "CACHE?" (if (dns-message-cache? dns-msg) "found in cache" "not found in cache")) (d 1 "PROTOCOL" (let ((protocol (dns-message-protocol dns-msg))) (cond ((eq? protocol (network-protocol tcp)) "TCP") ((eq? protocol (network-protocol udp)) "UDP")))) (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message-tried-nameservers dns-msg)) 1) (begin (display " had perform recursion: ") (dns-message-tried-nameservers dns-msg)) (begin (display " without recursion: ") (dns-message-tried-nameservers dns-msg)))))) ((message? dns-msg) (begin (d 2 "MESSAGE" "") (d 3 "Header " "")(show-dns-message (message-header dns-msg)) (d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message-questions dns-msg)) (d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message-answers dns-msg)) (d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message-nameservers dns-msg)) (d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message-additionals dns-msg)))) ((header? dns-msg) (begin (d 4 "id" (header-id dns-msg)) (d 4 "Flags" "")(show-dns-message (header-flags dns-msg)) (d 4 "question-count " (header-question-count dns-msg)) (d 4 "answer-count " (header-answer-count dns-msg)) (d 4 "nameserver-count " (header-nameserver-count dns-msg)) (d 4 "additional-count " (header-additional-count dns-msg)))) ((flags? dns-msg) (begin (d 5 "querytype" (flags-query-type dns-msg)) (d 5 "opcode" (flags-opcode dns-msg)) (d 5 "authoritative?" (flags-authoritative? dns-msg)) (d 5 "truncated?" (flags-truncated? dns-msg)) (d 5 "recursion-desired?" (flags-recursion-desired? dns-msg)) (d 5 "recursion-available?" (flags-recursion-available? dns-msg)) (d 5 "zero" (flags-zero dns-msg)) (d 5 "response-code" (flags-response-code dns-msg)))) ((question? dns-msg) (begin (d 4 "name " (question-name dns-msg)) (d 4 "type " (message-type-name (question-type dns-msg))) (d 4 "class" (message-class-name (question-class dns-msg))))) ((resource-record? dns-msg) (begin (d 4 "name " (resource-record-name dns-msg)) (d 4 "type "(message-type-name (resource-record-type dns-msg))) (d 4 "class" (message-class-name (resource-record-class dns-msg))) (d 4 "ttl " (resource-record-ttl dns-msg)) (d 4 "data " "") (show-dns-message (resource-record-data dns-msg)))) ((resource-record-data-a? dns-msg) (d 5 "ip " (resource-record-data-a-ip dns-msg))) ((resource-record-data-ns? dns-msg) (d 5 "name " (resource-record-data-ns-name dns-msg))) ((resource-record-data-cname? dns-msg) (d 5 "name " (resource-record-data-cname-name dns-msg))) ((resource-record-data-mx? dns-msg) (begin (d 5 "preference " (resource-record-data-mx-preference dns-msg)) (d 5 "exchanger " (resource-record-data-mx-exchanger dns-msg)))) ((resource-record-data-ptr? dns-msg) (d 5 "name " (resource-record-data-ptr-name dns-msg))) ((resource-record-data-soa? dns-msg) (begin (d 5 "mname " (resource-record-data-soa-mname dns-msg)) (d 5 "rname " (resource-record-data-soa-rname dns-msg)) (d 5 "serial " (resource-record-data-soa-serial dns-msg)) (d 5 "refresh " (resource-record-data-soa-refresh dns-msg)) (d 5 "expire " (resource-record-data-soa-expire dns-msg)) (d 5 "minimum " (resource-record-data-soa-expire dns-msg)))) ;; ### ((resource-record-data-hinfo? dns-msg) (d 5 "data " (resource-record-data-hinfo-data dns-msg))) ((resource-record-data-txt? dns-msg) (d 5 "text " (resource-record-data-txt-text dns-msg))) ((resource-record-data-wks? dns-msg) (d 5 "data " (resource-record-data-wks-data dns-msg))) )) (show-dns-message dns-msg))))) (define (socket-address->fqdn addr . args) (receive (ip32 port) (socket-address->internet-address addr) (apply dns-lookup-ip ip32 args))) ;; Some code to test the components of domain names ;;(define label-regexp ;; (rx (: alpha (? (* (| alphanumeric "-")) alphanumeric)))) ;;(define (unqualified-hostname name) ;; (regexp-search? (rx (: ,label-regexp)) name)) (define (maybe-dns-lookup-name name . args) (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) (if (dns-error? cond) (k #f) (more))) (lambda () (apply dns-lookup-name name args)))))) (define (maybe-dns-lookup-ip ip-addr . args) (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) (if (dns-error? cond) (k #f) (more))) (lambda () (apply dns-lookup-ip ip-addr args)))))) (define (domains-for-search) (cond ((assoc 'domain (resolv.conf)) => (lambda (pair) (list (cdr pair)))) ((assoc 'search (resolv.conf)) => (lambda (pair) (cdr pair))) (else '()))) (define (host-fqdn name-or-socket-address . args) (if (socket-address? name-or-socket-address) (apply socket-address->fqdn name-or-socket-address args) (let ((name name-or-socket-address)) (cond ((apply maybe-dns-lookup-name name args) => (lambda (ip) (apply dns-lookup-ip ip args))) (else (let lp ((domains (domains-for-search))) (if (null? domains) #f (cond ((apply maybe-dns-lookup-name (string-append name "." (car domains)) args) => (lambda (ip) (apply dns-lookup-ip ip args))) (else (lp (cdr domains))))))))))) (define (system-fqdn . args) (apply host-fqdn (system-name) args))