; ; 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 '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") ((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 ;; 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)) ;; converts an octeted-ip to a 32bit integer internet-address (define (octet-ip->address32 ip) (+ (arithmetic-shift (char->ascii (list-ref ip 0)) 24) (arithmetic-shift (char->ascii (list-ref ip 1)) 16) (arithmetic-shift (char->ascii (list-ref ip 2)) 8) (char->ascii (list-ref ip 3)))) ;; converts a 32 bit integer internet-address to an octeted-ip (define (address32->octet-ip ip) (list (arithmetic-shift ip -24) (modulo (arithmetic-shift ip -16) 256) (modulo (arithmetic-shift ip -8) 256) (modulo ip 256))) ;; converts an ip-string to an 32bit integer internet-address (define (ip-string->address32 ip) (octet-ip->address32 (ip-string->octet-ip ip))) ;; converts an ip-string to an 32bit integer internet-address (define (address32->ip-string ip) (format #f "~a.~a.~a.~a" (arithmetic-shift ip -24) (modulo (arithmetic-shift ip -16) 256) (modulo (arithmetic-shift ip -8) 256) (modulo ip 256))) ;; converts an octeted-ip to an human readable ip-string (define (octet-ip->ip-string s) (format #f "~a.~a.~a.~a" (char->ascii (list-ref s 0)) (char->ascii (list-ref s 1)) (char->ascii (list-ref s 2)) (char->ascii (list-ref s 3)))) (define ip-string-regexp (rx (: bos (submatch (** 1 3 digit)) "." (submatch (** 1 3 digit)) "." (submatch (** 1 3 digit)) "." (submatch (** 1 3 digit)) eos))) ;; converts an ip-string to octets (define (ip-string->octet-ip s) (cond ((regexp-search ip-string-regexp s) => (lambda (match) (list (ascii->char (string->number (match:substring match 1))) (ascii->char (string->number (match:substring match 2))) (ascii->char (string->number (match:substring match 3))) (ascii->char (string->number (match:substring match 4)))))) (else (error "invalid ip-string" s)))) ;; 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 a string is a ip (define (ip-string? s) (define (byte-as-string? string) (let ((number (string->number string))) (and number (>= number 0) (< number 256)))) (cond ((regexp-search ip-string-regexp s) => (lambda (match) (and (byte-as-string? (match:substring match 1)) (byte-as-string? (match:substring match 2)) (byte-as-string? (match:substring match 3)) (byte-as-string? (match:substring match 4))))) (else #f))) ;; checks if v is a address32 (define (address32? v) (and (number? v) (<= 0 v #xffffffff))) ;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip) (define (ip-string->in-addr-arpa s) (cond ((regexp-search ip-string-regexp s) => (lambda (match) (string-append (match:substring match 4) "." (match:substring match 3) "." (match:substring match 2) "." (match:substring match 1) "." "in-addr.arpa"))) (else #f))) ;; filters types in a list of rrs (define (filter-type list type) (filter (lambda (rr) (eq? (rr-type rr) type)) list)) ;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger. (define (sort-by-preference mx-list) (sort-list mx-list (lambda (a b) (< (rr-data-mx-preference (rr-data a)) (rr-data-mx-preference (rr-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)) ;;; -- message constructors: encode to octet-messages ;; makes an message header (define (make-octet-header id header-flags question-count answer-count nameserver-count additional-count) (let* ((header-id (number->octet-pair id)) (header-question-count (number->octet-pair question-count)) (header-answer-count (number->octet-pair answer-count)) (header-nameserver-count (number->octet-pair nameserver-count)) (header-additional-count (number->octet-pair additional-count))) (append header-id header-flags header-question-count header-answer-count header-nameserver-count header-additional-count))) (define (make-octet-header-flags qr opcode aa tc rd ra zero response-code) (list (ascii->char (+ (arithmetic-shift qr 7) (arithmetic-shift opcode 3) (arithmetic-shift aa 2) (arithmetic-shift tc 1) rd)) (ascii->char (+ (arithmetic-shift ra 7) (arithmetic-shift zero 4) response-code)))) ;; a standard query header, usefull for most queries (define (make-std-octet-query-header id question-count) (let* ((qr 0) ; querytype: query 0, response 1 (opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2 (aa 0) ; authorative answer (in answers only) (tc 0) ; truncation (size matters only with UDP) (rd 1) ; recursion desired: nameserver pursues the query recursivly (optional) (ra 0) ; 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-octet-header id (make-octet-header-flags qr opcode aa tc rd ra zero response-code) question-count answer-count nameserver-count additional-count))) ;; makes a question (name, type, class) (define (make-octet-question name type class) (let* ((qname (name->octets name)) (qtype (number->octet-pair (message-type-number type))) (qclass (number->octet-pair (message-class-number class)))) (append qname qtype qclass))) ;; makes a query-message (header and question only) (define (make-octet-query-message id name type class) (append (make-std-octet-query-header id 1) (make-octet-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)) ;; flags (define-record-type flags :flags (make-flags querytype 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)))) ;; question (define-record-type question :question (make-question name type class) question? (name question-name) (type question-type) (class question-class)) ;;type rr (define-record-type rr :rr (make-rr name type class ttl data) rr? (name rr-name) (type rr-type) (class rr-class) (ttl rr-ttl) (data rr-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-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start) (loop (- len 1) (cdr start) (cons (car start) accum))))))))))) ;;; -- rr-data-type records (define-record-type rr-data-a :rr-data-a (make-rr-data-a ip) rr-data-a? (ip rr-data-a-ip)) (define-record-type rr-data-ns :rr-data-ns (make-rr-data-ns name) rr-data-ns? (name rr-data-ns-name)) (define-record-type rr-data-cname :rr-data-cname (make-rr-data-cname name) rr-data-cname? (name rr-data-cname-name)) ;; ### ;; hinfo not correctly implemented, trying to find examples (define-record-type rr-data-hinfo :rr-data-hinfo (make-rr-data-hinfo data) rr-data-hinfo? (data rr-data-hinfo-data)) (define-record-type rr-data-mx :rr-data-mx (make-rr-data-mx preference exchanger) rr-data-mx? (preference rr-data-mx-preference) (exchanger rr-data-mx-exchanger)) (define-record-type rr-data-ptr :rr-data-ptr (make-rr-data-ptr name) rr-data-ptr? (name rr-data-ptr-name)) (define-record-type rr-data-soa :rr-data-soa (make-rr-data-soa mname rname serial refresh retry expire minimum) rr-data-soa? (mname rr-data-soa-mname) (rname rr-data-soa-rname) (serial rr-data-soa-serial) (refresh rr-data-soa-refresh) (retry rr-data-soa-retry) (expire rr-data-soa-expire) (minimum rr-data-soa-minimum)) ;; ### same as hinfo (define-record-type rr-data-txt :rr-data-txt (make-rr-data-txt text) rr-data-txt? (text rr-data-txt-text)) ;; ### same as hinfo and txt (define-record-type rr-data-wks :rr-data-wks (make-rr-data-wks data) rr-data-wks? (data rr-data-wks-data)) ;; (define (parse-rr-data type class data message) (cond ((eq? type (message-type a)) (make-rr-data-a (octet-ip->address32 data))) ((eq? type (message-type ns)) (make-rr-data-ns (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type cname)) (make-rr-data-cname (call-with-values (lambda () (parse-name data message)) (lambda (name rest) name)))) ((eq? type (message-type mx)) (make-rr-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-rr-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-rr-data-soa mname rname serial refresh retry expire minimum))))))))))) ((eq? type (message-type hinfo)) (make-rr-data-hinfo (list->string data))) ((eq? type (message-type txt)) (make-rr-data-txt (list->string data))) ((eq? type (message-type wks)) (make-rr-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 (and (char=? (car reply) (car query)) (char=? (cadr reply) (cadr query)))) ;; TODO replace display (display "send-receive-message: bad reply id from server")) ;; Check for error code: (let ((response-code (flags-response-code (parse-flags reply)))) (if (not (eq? response-code 'dns-no-error)) (dns-error response-code)))) ;; #t if message is truncated (could happen via UDP) (define (truncated? reply) (flags-truncated? (parse-flags reply))) ;; 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 (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)) (wport-nameserver-alist (map cons ws nameservers)) (wport-socket-alist (map cons ws sockets))) (dynamic-wind (lambda () #f) (lambda () (let* ((ready-ports (apply select-port-channels #f ws)) (w (car ready-ports)) (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) (values (parse 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 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* ((ready (apply select-port-channels #f rs)) (r (car ready)) (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 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) ((rr? dns-msg) (cond ((not minimum) (set! minimum (rr-ttl dns-msg))) (else (if (and (not minimum) (> minimum (rr-ttl dns-msg))) (set! minimum (rr-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 question protocol nameservers tried) ;; returns new retrieved data (receive (dns-msg hit-ns nss-with-no-reply) (send-receive-message nameservers question protocol) (values (make-dns-message (parse question) dns-msg #f protocol (reverse tried)) hit-ns nss-with-no-reply))) (define (dns-query-with-cache question protocol nameservers tried) (let ((qds (message-questions (parse question)))) (let lp ((ns nameservers)) (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))) ;; returns new retrieved data and updates cache (values (make-dns-message (parse question) 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 (parse question) (cache-answer found-data) #t protocol '()) #f nameservers))) (else (lp (cdr ns)))))))) (define (send-receive-message nameservers question protocol) ((cond ((eq? protocol 'tcp) send-receive-message-tcp) ((eq? protocol 'udp) send-receive-message-udp)) nameservers question)) ;; 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 question use-cache? protocol nameservers tried) (if use-cache? (dns-query-with-cache question protocol nameservers tried) (dns-query-no-cache question 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 question use-cache? protocol nameservers check-answer) (let lp ((tried '()) (nss nameservers)) (if (null? nss) (dns-error 'bad-address) (receive (dns-msg hit-ns nss-with-no-reply) (dns-query/cache question 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? (rr-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 (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) (let ((actual-m-time (file-info:mtime (file-info "/etc/resolv.conf")))) (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 "/etc/resolv.conf"))) (contents (really-parse-resolv.conf "/etc/resolv.conf"))) (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 (: "nameserver" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-nameserver (match:substring match 1)) rev-result)))) ((regexp-search (rx (: "domain" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-domain (match:substring match 1)) rev-result)))) ((regexp-search (rx (: "search" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (loop (cons (parse-search (match:substring match 1)) rev-result)))) ((regexp-search (rx (: "sortlist" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (parse-sortlist (match:substring match 1)))) ((regexp-search (rx (: "options" (+ (| " " "\t") (submatch (* any)) eos))) l) => (lambda (match) (parse-options (match:substring match 1)))) (else (signal 'resolv.conf-parse-error)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Figure out the default name servers (define (dns-find-nameserver-list) (cond ((assoc 'nameserver (resolv.conf)) => (lambda (nameserver.list) (cdr nameserver.list))) (else '()))) ;; returns the first found nameserver (define (dns-find-nameserver) (let ((ns (dns-find-nameserver-list))) (if (null? ns) (dns-error 'no-nameservers) (car ns)))) ;; 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) (map ip-string->address32 (dns-find-nameserver-list)) (map (lambda (nameserver) (cond ((address32? nameserver) nameserver) ((ip-string? nameserver) (ip-string->address32 nameserver)) (else (map (dns-lookup-name nameserver (dns-find-nameserver-list)))))) (car args)))) ;; dns-lookup with more options than dns-lookup-* (define (dns-lookup name type . nameservers) (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr-arpa (address32->ip-string name)) (ip-string->in-addr-arpa name))) (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 (message-class in)) (make-octet-query-message (random 256) name type (message-class 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)))) dns-msg)) ;; looks up a hostname, returns an ip. ;; (dns-lookup-name nameservers) (define (dns-lookup-name name . nameservers) (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr-arpa (address32->ip-string name)) (ip-string->in-addr-arpa 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 (message-type a) (message-class 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 (message-type a))))))) (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a)))) (rr-data-a-ip (rr-data (car answers))))) ;; looks up an ip, returns a hostname ;; (dns-inverse-lookup [nameserver]) (define (dns-lookup-ip ip . nameservers) (let* ((maybe-ip-string (if (address32? ip) (ip-string->in-addr-arpa (address32->ip-string ip)) (ip-string->in-addr-arpa 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 (message-type ptr) (message-class 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 (message-type ptr))))))) (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer)) (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type 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 [nameserver]) (define (dns-lookup-nameserver name . nameservers) (let* ((maybe-ip-string (if (address32? name) (ip-string->in-addr-arpa (address32->ip-string name)) (ip-string->in-addr-arpa 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 (message-type ns) (message-class 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 (message-type soa)))) (not (null? (filter-type answers (message-type 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) (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 (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 [nameserver]) (define (dns-lookup-mail-exchanger name . nameservers) (let* ((ip-string (if (address32? name) (ip-string->in-addr-arpa (address32->ip-string name)) (ip-string->in-addr-arpa 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 (message-type mx) (message-class 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 (message-type mx)))) (not (null? (filter-type answers (message-type cname)))) (not (null? (filter-type answers (message-type 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) (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 (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 (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 'tcp) "TCP") ((eq? 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-querytype 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))))) ((rr? dns-msg) (begin (d 4 "name " (rr-name dns-msg)) (d 4 "type "(message-type-name (rr-type dns-msg))) (d 4 "class" (message-class-name (rr-class dns-msg))) (d 4 "ttl " (rr-ttl dns-msg)) (d 4 "data " "") (show-dns-message (rr-data dns-msg)))) ((rr-data-a? dns-msg) (d 5 "ip " (rr-data-a-ip dns-msg))) ((rr-data-ns? dns-msg) (d 5 "name " (rr-data-ns-name dns-msg))) ((rr-data-cname? dns-msg) (d 5 "name " (rr-data-cname-name dns-msg))) ((rr-data-mx? dns-msg) (begin (d 5 "preference " (rr-data-mx-preference dns-msg)) (d 5 "exchanger " (rr-data-mx-exchanger dns-msg)))) ((rr-data-ptr? dns-msg) (d 5 "name " (rr-data-ptr-name dns-msg))) ((rr-data-soa? dns-msg) (begin (d 5 "mname " (rr-data-soa-mname dns-msg)) (d 5 "rname " (rr-data-soa-rname dns-msg)) (d 5 "serial " (rr-data-soa-serial dns-msg)) (d 5 "refresh " (rr-data-soa-refresh dns-msg)) (d 5 "expire " (rr-data-soa-expire dns-msg)) (d 5 "minimum " (rr-data-soa-expire dns-msg)))) ;; ### ((rr-data-hinfo? dns-msg) (d 5 "data " (rr-data-hinfo-data dns-msg))) ((rr-data-txt? dns-msg) (d 5 "text " (rr-data-txt-text dns-msg))) ((rr-data-wks? dns-msg) (d 5 "data " (rr-data-wks-data dns-msg))) )) (show-dns-message dns-msg))))) (define *fqdn-lock* (make-lock)) (define *fqdn-cache* '()) (define (socket-address->fqdn addr cache?) (receive (ip32 port) (socket-address->internet-address addr) (internet-address->fqdn ip32 cache?))) (define (internet-address->fqdn ip32 cache?) (if cache? (begin (obtain-lock *fqdn-lock*) (cond ((assv ip32 *fqdn-cache*) => (lambda (pair) (release-lock *fqdn-lock*) (cdr pair))) (else (release-lock *fqdn-lock*) (let ((fqdn (dns-lookup-ip ip32))) (set! *fqdn-cache* (cons (cons ip32 fqdn) *fqdn-cache*)) fqdn)))) (dns-lookup-ip ip32))) (define (is-fqdn? name) (regexp-search? (rx #\.) name)) (define (maybe-dns-lookup-name name) (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) (if (dns-error? cond) (k #f) (more))) (lambda () (dns-lookup-name name)))))) (define (maybe-dns-lookup-ip ip-addr) (call-with-current-continuation (lambda (k) (with-handler (lambda (cond more) (if (dns-error? cond) (k #f) (more))) (lambda () (dns-lookup-ip ip-addr)))))) (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) (if (socket-address? name-or-socket-address) (socket-address->fqdn name-or-socket-address #f) (let ((name name-or-socket-address)) (if (is-fqdn? name) name (let lp ((domains (domains-for-search))) (if (null? domains) #f (cond ((maybe-dns-lookup-name (string-append name "." (car domains))) => (lambda (ip) (dns-lookup-ip ip))) (else (lp (cdr domains)))))))))) (define (system-fqdn) (host-fqdn (system-name)))