First stab at DNS client, based on the code from PLT.
Note it does at least one thing wrong (besides what's noted in PLT's documentation): > (dns-get-address "macon" "ftp.uni-tuebingen.de") "8.115.111.102" (The original version also does this. I assume it has something to do with recursive queries.)
This commit is contained in:
sperber
parent
49de023eb7
commit
ebbbe7192f
|
|
@ -0,0 +1,349 @@
|
||||||
|
;; open string-table big-util(?) ascii format signals random
|
||||||
|
|
||||||
|
(define *nul* (ascii->char 0))
|
||||||
|
(define *on* (ascii->char 1))
|
||||||
|
|
||||||
|
(define types
|
||||||
|
'((a 1)
|
||||||
|
(ns 2)
|
||||||
|
(md 3)
|
||||||
|
(mf 4)
|
||||||
|
(cname 5)
|
||||||
|
(soa 6)
|
||||||
|
(mb 7)
|
||||||
|
(mg 8)
|
||||||
|
(mr 9)
|
||||||
|
(null 10)
|
||||||
|
(wks 11)
|
||||||
|
(ptr 12)
|
||||||
|
(hinfo 13)
|
||||||
|
(minfo 14)
|
||||||
|
(mx 15)
|
||||||
|
(txt 16)))
|
||||||
|
|
||||||
|
(define classes
|
||||||
|
'((in 1)
|
||||||
|
(cs 2)
|
||||||
|
(ch 3)
|
||||||
|
(hs 4)))
|
||||||
|
|
||||||
|
(define (cossa i l)
|
||||||
|
(cond
|
||||||
|
((null? l) #f)
|
||||||
|
((equal? (cadar l) i)
|
||||||
|
(car l))
|
||||||
|
(else (cossa i (cdr l)))))
|
||||||
|
|
||||||
|
(define (number->octet-pair n)
|
||||||
|
(list (ascii->char (arithmetic-shift n -8))
|
||||||
|
(ascii->char (modulo n 256))))
|
||||||
|
|
||||||
|
(define (octet-pair->number a b)
|
||||||
|
(+ (arithmetic-shift (char->ascii a) 8)
|
||||||
|
(char->ascii b)))
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
|
||||||
|
(define (name->octets s)
|
||||||
|
(define (encode-portion s)
|
||||||
|
(cons
|
||||||
|
(ascii->char (string-length s))
|
||||||
|
(string->list s)))
|
||||||
|
|
||||||
|
(let loop ((s s))
|
||||||
|
(cond
|
||||||
|
((string-match "^([^.]*)\\.(.*)" s)
|
||||||
|
=> (lambda (match)
|
||||||
|
(append
|
||||||
|
(encode-portion (match:substring match 1))
|
||||||
|
(loop (match:substring match 2)))))
|
||||||
|
(else
|
||||||
|
(append
|
||||||
|
(encode-portion s)
|
||||||
|
(list *nul*))))))
|
||||||
|
|
||||||
|
(define (make-std-query-header id question-count)
|
||||||
|
(append
|
||||||
|
(number->octet-pair id)
|
||||||
|
(list *on* *nul*) ; Opcode & flags (recusive flag set)
|
||||||
|
(number->octet-pair question-count)
|
||||||
|
(number->octet-pair 0)
|
||||||
|
(number->octet-pair 0)
|
||||||
|
(number->octet-pair 0)))
|
||||||
|
|
||||||
|
(define (make-query id name type class)
|
||||||
|
(append
|
||||||
|
(make-std-query-header id 1)
|
||||||
|
(name->octets name)
|
||||||
|
(number->octet-pair (cadr (assoc type types)))
|
||||||
|
(number->octet-pair (cadr (assoc class classes)))))
|
||||||
|
|
||||||
|
(define (add-size-tag m)
|
||||||
|
(append (number->octet-pair (length m)) m))
|
||||||
|
|
||||||
|
(define (rr-data rr)
|
||||||
|
(cadddr (cdr rr)))
|
||||||
|
|
||||||
|
(define (rr-type rr)
|
||||||
|
(cadr rr))
|
||||||
|
|
||||||
|
(define (rr-name rr)
|
||||||
|
(car rr))
|
||||||
|
|
||||||
|
(define (parse-name start reply)
|
||||||
|
(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 reply))
|
||||||
|
(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 reply offset) reply))
|
||||||
|
(lambda (s ignore-start)
|
||||||
|
(values s (cddr start)))))))))
|
||||||
|
|
||||||
|
(define (parse-rr start reply)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-name start reply))
|
||||||
|
(lambda (name start)
|
||||||
|
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
|
||||||
|
(start (cddr start)))
|
||||||
|
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
|
||||||
|
(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 for data:
|
||||||
|
(let loop ((len len)
|
||||||
|
(start start)
|
||||||
|
(accum '()))
|
||||||
|
(if (zero? len)
|
||||||
|
(values (list name type class ttl (reverse! accum))
|
||||||
|
start)
|
||||||
|
(loop (- len 1)
|
||||||
|
(cdr start)
|
||||||
|
(cons (car start) accum)))))))))))
|
||||||
|
|
||||||
|
(define (parse-ques start reply)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-name start reply))
|
||||||
|
(lambda (name start)
|
||||||
|
(let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
|
||||||
|
(start (cddr start)))
|
||||||
|
(let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
|
||||||
|
(start (cddr start)))
|
||||||
|
(values (list name type class) start))))))
|
||||||
|
|
||||||
|
(define (parse-n parse start reply n)
|
||||||
|
(let loop ((n n) (start start) (accum '()))
|
||||||
|
(if (zero? n)
|
||||||
|
(values (reverse! accum) start)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse start reply))
|
||||||
|
(lambda (rr start)
|
||||||
|
(loop (- n 1) start (cons rr accum)))))))
|
||||||
|
|
||||||
|
(define random
|
||||||
|
(let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
|
||||||
|
(lambda (limit)
|
||||||
|
(quotient (* (modulo (crank) 314159265)
|
||||||
|
limit)
|
||||||
|
314159265))))
|
||||||
|
|
||||||
|
(define (dns-query nameserver addr type class)
|
||||||
|
(if (not (assoc type types))
|
||||||
|
(error "dns-query: invalid DNS query type ~a" type))
|
||||||
|
(if (not (assoc class classes))
|
||||||
|
(error "dns-query: invalid DNS query class ~a" class))
|
||||||
|
|
||||||
|
(let* ((query (make-query (random 256) addr type class))
|
||||||
|
(reply
|
||||||
|
(let ((socket (socket-connect protocol-family/internet
|
||||||
|
socket-type/stream
|
||||||
|
nameserver 53)))
|
||||||
|
(let ((r (socket:inport socket))
|
||||||
|
(w (socket:outport socket)))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda ()
|
||||||
|
'fick-dich-ins-knie)
|
||||||
|
(lambda ()
|
||||||
|
(display (list->string (add-size-tag query)) w)
|
||||||
|
(force-output w)
|
||||||
|
|
||||||
|
(let ((a (read-char r))
|
||||||
|
(b (read-char r)))
|
||||||
|
(let ((len (octet-pair->number a b)))
|
||||||
|
(let ((s (read-string len r)))
|
||||||
|
(if (not (= len (string-length s)))
|
||||||
|
(error "dns-query: unexpected EOF from server"))
|
||||||
|
(string->list s)))))
|
||||||
|
(lambda ()
|
||||||
|
(close-socket socket)))))))
|
||||||
|
|
||||||
|
;; First two bytes must match sent message id:
|
||||||
|
(if (not (and (char=? (car reply) (car query))
|
||||||
|
(char=? (cadr reply) (cadr query))))
|
||||||
|
(error "dns-query: bad reply id from server"))
|
||||||
|
|
||||||
|
(let ((v0 (caddr reply))
|
||||||
|
(v1 (cadddr reply)))
|
||||||
|
;; Check for error code:
|
||||||
|
(let ((rcode (bitwise-and #xf (char->ascii v1))))
|
||||||
|
(if (not (zero? rcode))
|
||||||
|
(error "dns-query: error from server: ~a"
|
||||||
|
(case rcode
|
||||||
|
((1) "format error")
|
||||||
|
((2) "server failure")
|
||||||
|
((3) "name error")
|
||||||
|
((4) "not implemented")
|
||||||
|
((5) "refused")))))
|
||||||
|
|
||||||
|
(let ((qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5)))
|
||||||
|
(an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7)))
|
||||||
|
(ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9)))
|
||||||
|
(ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))))
|
||||||
|
|
||||||
|
(let ((start (list-tail reply 12)))
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-n parse-ques start reply qd-count))
|
||||||
|
(lambda (qds start)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-n parse-rr start reply an-count))
|
||||||
|
(lambda (ans start)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-n parse-rr start reply ns-count))
|
||||||
|
(lambda (nss start)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-n parse-rr start reply ar-count))
|
||||||
|
(lambda (ars start)
|
||||||
|
(if (not (null? start))
|
||||||
|
(error "dns-query: error parsing server reply"))
|
||||||
|
(values (positive? (bitwise-and #x4 (char->ascii v0)))
|
||||||
|
qds ans nss ars reply))))))))))))))
|
||||||
|
|
||||||
|
(define cache (make-string-table))
|
||||||
|
(define (dns-query/cache nameserver addr type class)
|
||||||
|
(let ((key (format #f "~a;~a;~a;~a" nameserver addr type class)))
|
||||||
|
(cond
|
||||||
|
((table-ref cache key)
|
||||||
|
=> (lambda (v)
|
||||||
|
(apply values v)))
|
||||||
|
(else
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (dns-query nameserver addr type class))
|
||||||
|
(lambda (auth? qds ans nss ars reply)
|
||||||
|
(table-set! cache key (list auth? qds ans nss ars reply))
|
||||||
|
(values auth? qds ans nss ars reply)))))))
|
||||||
|
|
||||||
|
(define (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 (try-forwarding k nameserver)
|
||||||
|
(let loop ((nameserver nameserver)
|
||||||
|
(tried (list nameserver)))
|
||||||
|
;; Normally the recursion is done for us, but it's technically optional
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (k nameserver))
|
||||||
|
(lambda (v ars auth?)
|
||||||
|
(or v
|
||||||
|
(and (not auth?)
|
||||||
|
(let* ((ns (any
|
||||||
|
(lambda (ar)
|
||||||
|
(and (eq? (rr-type ar) 'a)
|
||||||
|
(ip->string (rr-data ar))))
|
||||||
|
ars)))
|
||||||
|
(and ns
|
||||||
|
(not (member ns tried))
|
||||||
|
(loop ns (cons ns tried))))))))))
|
||||||
|
|
||||||
|
(define (dns-get-address nameserver addr)
|
||||||
|
(or (try-forwarding
|
||||||
|
(lambda (nameserver)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (dns-query/cache nameserver addr 'a 'in))
|
||||||
|
(lambda (auth? qds ans nss ars reply)
|
||||||
|
(values (and (positive? (length ans))
|
||||||
|
(let ((s (rr-data (car ans))))
|
||||||
|
(ip->string s)))
|
||||||
|
ars auth?))))
|
||||||
|
nameserver)
|
||||||
|
(error "dns-get-address: bad address ~a" addr)))
|
||||||
|
|
||||||
|
(define (dns-get-mail-exchanger nameserver addr)
|
||||||
|
(or (try-forwarding
|
||||||
|
(lambda (nameserver)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (dns-query/cache nameserver addr 'mx 'in))
|
||||||
|
(lambda (auth? qds ans nss ars reply)
|
||||||
|
(values (let loop ((ans ans)
|
||||||
|
(best-pref 99999) ; this is enough
|
||||||
|
(exchanger #f))
|
||||||
|
(cond
|
||||||
|
((null? ans)
|
||||||
|
(or exchanger
|
||||||
|
;; Does 'soa mean that the input address is fine?
|
||||||
|
(and (any? (lambda (ns)
|
||||||
|
(eq? (rr-type ns) 'soa))
|
||||||
|
nss)
|
||||||
|
addr)))
|
||||||
|
(else
|
||||||
|
(let ((d (rr-data (car ans))))
|
||||||
|
(let ((pref (octet-pair->number (car d) (cadr d))))
|
||||||
|
(if (< pref best-pref)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (parse-name (cddr d) reply))
|
||||||
|
(lambda (name start)
|
||||||
|
(loop (cdr ans) pref name)))
|
||||||
|
(loop (cdr ans) best-pref exchanger)))))))
|
||||||
|
ars auth?))))
|
||||||
|
nameserver)
|
||||||
|
(error "dns-get-mail-exchanger: bad address")))
|
||||||
|
|
||||||
|
(define (dns-find-nameserver)
|
||||||
|
(with-input-from-file "/etc/resolv.conf"
|
||||||
|
(lambda ()
|
||||||
|
(let loop ()
|
||||||
|
(let ((l (read-line)))
|
||||||
|
(cond
|
||||||
|
((eof-object? l)
|
||||||
|
#f)
|
||||||
|
((string-match "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)"
|
||||||
|
l)
|
||||||
|
=> (lambda (match)
|
||||||
|
(match:substring match 1)))
|
||||||
|
(else
|
||||||
|
(loop))))))))
|
||||||
|
|
||||||
|
|
||||||
15
modules.scm
15
modules.scm
|
|
@ -699,3 +699,18 @@
|
||||||
(define (eval-safely exp)
|
(define (eval-safely exp)
|
||||||
(ignore-errors (lambda () (eval exp (new-safe-package)))))))
|
(ignore-errors (lambda () (eval exp (new-safe-package)))))))
|
||||||
|
|
||||||
|
(define-interface dns-interface
|
||||||
|
(export dns-get-address
|
||||||
|
dns-get-mail-exchanger
|
||||||
|
dns-find-nameserver))
|
||||||
|
|
||||||
|
(define-structure dns dns-interface
|
||||||
|
(open scheme
|
||||||
|
scsh
|
||||||
|
big-util
|
||||||
|
tables
|
||||||
|
ascii
|
||||||
|
formats
|
||||||
|
signals
|
||||||
|
random)
|
||||||
|
(files dns))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue