diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index e2c3355..f006e06 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -14,31 +14,40 @@ ; --- ; sample usage & documentation: ; -; , and are strings. +; 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 or a ip. +; 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) --> +; (dns-find-nameserver) --> ; this parses the /etc/resolv.conf file and returns the first found -; nameserver. +; nameserver in address32 format. ; ; ; -; (dns-lookup-name [nameserver]) --> -; (dns-lookup-ip [nameserver]) --> +; (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: +; a concurrent lookup to all nameservers in /etc/resolv.conf is started, +; if the variable dns-concurrent-lookup is given as optional +; argument. ; -; (dns-lookup [nameserver]) --> +; +; (dns-lookup [nameserver]) +; --> ; (show-dns-message the whole message, human readable ; ; a is a record, with several entries, which holds the whole @@ -49,18 +58,20 @@ ; only useful in very special cases. ; ; -; (concurrent-lookup ) -; starts a concurrent lookup to all nameservers in /etc/resolv.conf. -; the simple lookup function defines the lookup type. -; -; ; 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 ) --> ; (force-ip-list ) --> +; +; +; useful converters: +; +; (address32->ip-string ) -> +; (ip-string->address32 ) -> + @@ -151,6 +162,8 @@ (else (more)))) +;; concurrent-flag +(define dns-concurrent-lookup 'dns-concurrent-lookup) ;;; -- globals and types @@ -254,9 +267,40 @@ (if *debug* (display "add-size-tag\n")) (append (number->octet-pair (length m)) m)) +;; converts an octeted-ip to a 32bit integer internet-address +(define (octet-ip->address32 ip) + (if *debug* (display "octet-ip->address32\n")) + (+ (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) + (if *debug* (display "number->octet-quad\n")) + (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) + (if *debug* (display "ip-string->address32\n")) + (octet-ip->address32 (string->octet-ip ip))) + +;; converts an ip-string to an 32bit integer internet-address +(define (address32->ip-string ip) +; (if *debug* (display "address32->ip-string\n")) + (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 (ip->string s) - (if *debug* (display "ip->string\n")) +(define (octet-ip->string s) + (if *debug* (display "octet-ip->string\n")) (format #f "~a.~a.~a.~a" (char->ascii (list-ref s 0)) @@ -265,8 +309,8 @@ (char->ascii (list-ref s 3)))) ;; converts an ip-string to octets -(define (string->ip s) - (if *debug* (display "string->ip\n")) +(define (string->octet-ip s) + (if *debug* (display "string->octet-ip\n")) (let loop ((s s) (result '())) (cond @@ -285,7 +329,7 @@ 314159265)))) ;; checks if a string is a ip -(define (ip? s) +(define (ip-string? s) (if *debug* (display "ip-string->in-addr\n")) (let loop ((s s) (count 0)) @@ -304,6 +348,10 @@ (= count 3) #t)))))) +;; 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 s) @@ -343,7 +391,7 @@ ;; returns a IP if available (additonal type-a processing) (define (force-ip name) (let loop ((result (dns-lookup-name name))) - (if (ip? result) + (if (ip-string? result) result (loop (dns-lookup-name result))))) @@ -612,7 +660,7 @@ (if *debug* (display "parse-rr-data\n")) (cond ((eq? type 'a) - (make-rr-data-a (ip->string data))) + (make-rr-data-a (octet-ip->address32 data))) ((eq? type 'ns) (make-rr-data-ns (call-with-values @@ -932,7 +980,7 @@ ns)) ((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l) => (lambda (match) - (loop (append ns (list (match:substring match 1)))))) + (loop (append ns (list (ip-string->address32 (match:substring match 1))))))) (else (loop ns)))))))) @@ -960,12 +1008,12 @@ (for-each (lambda (nameserver) (spawn (lambda () - (display "query sent to ")(display nameserver)(display " \n") + ;(display "query sent to ")(display nameserver)(display " \n") (let* ((result (apply lookup (list name nameserver)))) (enqueue! queue result) - (display "received reply from ")(display nameserver)(display ": ")(display result)(newline) + ;(display "received reply from ")(display nameserver)(display ": ")(display result)(newline) (release-lock lock))))) - (dns-find-nameserver-list)))) + (map (lambda (adr32) (address32->ip-string adr32)) (dns-find-nameserver-list))))) (let loop ((count (length nameserver-list))) (obtain-lock lock) @@ -974,16 +1022,17 @@ result (loop (- count 1))))))) -;; checks the arguments of the dns-lookup-* functions. +;; checks the arguments of the simple 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) - (dns-find-nameserver) + (address32->ip-string (dns-find-nameserver) ) (let ((nameserver (car args))) - (if (ip? nameserver) - nameserver - (dns-lookup-name nameserver))))) + (cond + ((ip-string? nameserver) nameserver) + ((address32? nameserver) (address32->ip-string nameserver)) + (else (address32->ip-string (dns-lookup-name nameserver))))))) ;; dns-lookup with more options than dns-lookup-* @@ -996,7 +1045,9 @@ (dns-error-messages condition more) (exit #f)) (lambda () - (let* ((ip-string (ip-string->in-addr name)) + (let* ((ip-string (if (address32? name) + (ip-string->in-addr (address32->ip-string name)) + (ip-string->in-addr name))) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (make-octet-query-message (random 256) ip-string type 'in) (make-octet-query-message (random 256) name type 'in))) @@ -1012,10 +1063,18 @@ dns-msg)))))) +;; returns a lookup-function with concurrent-flag +(define (make-lookup-function simple-lookup-function) + (lambda (name . args) + (if (null? args) + (simple-lookup-function name) + (if (eq? (car args) dns-concurrent-lookup) + (concurrent-lookup simple-lookup-function name) + (simple-lookup-function name (car args)))))) ;; looks up a hostname, returns an ip. ;; (dns-lookup-name [nameserver]) -(define (dns-lookup-name name . args) +(define (dns-simple-lookup-name name . args) (call-with-current-continuation (lambda (exit) (with-handler @@ -1023,7 +1082,9 @@ (dns-error-messages condition more) (exit #f)) (lambda () - (let* ((ip-string (ip-string->in-addr name)) + (let* ((ip-string (if (address32? name) + (ip-string->in-addr (address32->ip-string name)) + (ip-string->in-addr name))) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (signal 'not-a-hostname) (make-octet-query-message (random 256) name 'a 'in))) @@ -1038,10 +1099,11 @@ (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a))) (rr-data-a:ip (rr:data (car answers))))))))) +(define dns-lookup-name (make-lookup-function dns-simple-lookup-name)) ;; looks up an ip, returns a hostname ;; (dns-inverse-lookup [nameserver]) -(define (dns-inverse-lookup ip . args) +(define (dns-simple-lookup-ip ip . args) (call-with-current-continuation (lambda (exit) (with-handler @@ -1049,7 +1111,9 @@ (dns-error-messages condition more) (exit #f)) (lambda () - (let* ((ip-string (ip-string->in-addr ip)) + (let* ((ip-string (if (address32? ip) + (ip-string->in-addr (address32->ip-string ip)) + (ip-string->in-addr ip))) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (make-octet-query-message (random 256) ip-string 'ptr 'in) (signal 'not-a-ip))) @@ -1064,13 +1128,15 @@ (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr))) (rr-data-ptr:name (rr:data (car answers))))))))) -(define dns-lookup-ip dns-inverse-lookup) +(define dns-lookup-ip (make-lookup-function dns-simple-lookup-ip)) + +(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) +(define (dns-simple-lookup-nameserver name . args) (call-with-current-continuation (lambda (exit) (with-handler @@ -1078,7 +1144,9 @@ (dns-error-messages condition more) (exit #f)) (lambda () - (let* ((ip-string (ip-string->in-addr name)) + (let* ((ip-string (if (address32? name) + (ip-string->in-addr (address32->ip-string name)) + (ip-string->in-addr name))) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (signal 'not-a-hostname) (make-octet-query-message (random 256) name 'ns 'in))) @@ -1100,13 +1168,15 @@ (list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa))))) (map (lambda (elem) (rr-data-a:ip (rr:data elem))) add)))))))) +(define dns-lookup-nameserver (make-lookup-function dns-simple-lookup-nameserver)) + ;; 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) +(define (dns-simple-lookup-mail-exchanger name . args) (call-with-current-continuation (lambda (exit) (with-handler @@ -1114,7 +1184,9 @@ (dns-error-messages condition more) (exit #f)) (lambda () - (let* ((ip-string (ip-string->in-addr name)) + (let* ((ip-string (if (address32? name) + (ip-string->in-addr (address32->ip-string name)) + (ip-string->in-addr name))) (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address (signal 'not-a-hostname) (make-octet-query-message (random 256) name 'mx 'in))) @@ -1145,7 +1217,7 @@ (else (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx)))))))))) - +(define dns-lookup-mail-exchanger (make-lookup-function dns-simple-lookup-mail-exchanger)) ;;; pretty-prints a dns-msg diff --git a/scheme/packages.scm b/scheme/packages.scm index 1f1afb8..62d7cbe 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -182,19 +182,21 @@ net:daytime)) (define-interface dns-interface - (export dns-clear-cache - dns-lookup - dns-lookup-name - dns-inverse-lookup - dns-lookup-ip - dns-lookup-nameserver - dns-lookup-mail-exchanger - concurrent-lookup - show-dns-message - force-ip - force-ip-list - dns-find-nameserver - dns-find-nameserver-list)) + (export dns-clear-cache ; clears the cache + dns-lookup ; complex lookup function + dns-lookup-name ; simple lookup function + dns-inverse-lookup ; obsolete, use dns-lookup-ip + dns-lookup-ip ; simple lookup function + dns-lookup-nameserver ; simple lookup function + dns-lookup-mail-exchanger ; simple lookpu function + dns-concurrent-lookup ; the concurrent lookup variable + show-dns-message ; prints a human readable dns-msg + force-ip ; reruns a lookup until a ip is resolved + force-ip-list ; reruns a lookup until a list of ips is resolved + address32->ip-string ; converts a address32 in an ip-string + ip-string->address32 ; converts a ip-string in an address32 + dns-find-nameserver ; returns a nameserver + dns-find-nameserver-list)) ; returns a list of nameservers (define-interface cgi-script-interface (export cgi-form-query))