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

+ Removed *debug* 

+ some renamings
+ explained nomenclature
This commit is contained in:
mainzelm 2002-11-29 17:08:14 +00:00
parent 4e859bc92a
commit 5f88c27382
1 changed files with 28 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
scheme/lib/dns.scm
View File

@ -84,11 +84,6 @@
;;; should debug-msgs be printed out?
(define *debug* #f)
;; --- error conditions ;; --- error conditions
;; supertype of all errors signaled by this library ;; supertype of all errors signaled by this library
@ -219,28 +214,34 @@
;; assoc the other way round ;; assoc the other way round
(define (cossa i l) (define (cossa i l)
(if *debug* (display "cossa\n"))
(cond (cond
((null? l) 'unknown) ((null? l) 'unknown)
((equal? (cadar l) i) ((equal? (cadar l) i)
(car l)) (car l))
(else (cossa i (cdr l))))) (else (cossa i (cdr l)))))
;; 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 ;; encodes numbers (16bit) to octets
(define (number->octet-pair n) (define (number->octet-pair n)
(if *debug* (display "number->octet-pair\n"))
(list (ascii->char (arithmetic-shift n -8)) (list (ascii->char (arithmetic-shift n -8))
(ascii->char (modulo n 256)))) (ascii->char (modulo n 256))))
;; decodes octets to numbers (16bit) ;; decodes octets to numbers (16bit)
(define (octet-pair->number a b) (define (octet-pair->number a b)
(if *debug* (display "octet-pair->number\n"))
(+ (arithmetic-shift (char->ascii a) 8) (+ (arithmetic-shift (char->ascii a) 8)
(char->ascii b))) (char->ascii b)))
;; encodes numbers (32bit) to octets, needed for ttl ;; encodes numbers (32bit) to octets, needed for ttl
(define (number->octet-quad n) (define (number->octet-quad n)
(if *debug* (display "number->octet-quad\n"))
(list (ascii->char (arithmetic-shift n -24)) (list (ascii->char (arithmetic-shift n -24))
(ascii->char (modulo (arithmetic-shift n -16) 256)) (ascii->char (modulo (arithmetic-shift n -16) 256))
(ascii->char (modulo (arithmetic-shift n -8) 256)) (ascii->char (modulo (arithmetic-shift n -8) 256))
@ -248,7 +249,6 @@
;; decodes octets to numbers, needed for 32bit ttl ;; decodes octets to numbers, needed for 32bit ttl
(define (octet-quad->number a b c d) (define (octet-quad->number a b c d)
(if *debug* (display "octet-quad->number\n"))
(+ (arithmetic-shift (char->ascii a) 24) (+ (arithmetic-shift (char->ascii a) 24)
(arithmetic-shift (char->ascii b) 16) (arithmetic-shift (char->ascii b) 16)
(arithmetic-shift (char->ascii c) 8) (arithmetic-shift (char->ascii c) 8)
@ -261,7 +261,6 @@
(ascii->char (string-length s)) (ascii->char (string-length s))
(string->list s))) (string->list s)))
(if *debug* (display "name->octets\n"))
(let loop ((s s)) (let loop ((s s))
(cond (cond
((regexp-search (rx (: bos (submatch (* (~ "."))) "." (submatch (* any)))) ((regexp-search (rx (: bos (submatch (* (~ "."))) "." (submatch (* any))))
@ -273,6 +272,7 @@
(else (else
(if (= 0 (string-length s)) (if (= 0 (string-length s))
(list *nul*) (list *nul*)
;;; TODO isn't this case an error?
(append (append
(encode-portion s) (encode-portion s)
(list *nul*))))))) (list *nul*)))))))
@ -280,12 +280,10 @@
;; for tcp: message has to be tagged with its length ;; for tcp: message has to be tagged with its length
(define (add-size-tag m) (define (add-size-tag m)
(if *debug* (display "add-size-tag\n"))
(append (number->octet-pair (length m)) m)) (append (number->octet-pair (length m)) m))
;; converts an octeted-ip to a 32bit integer internet-address ;; converts an octeted-ip to a 32bit integer internet-address
(define (octet-ip->address32 ip) (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 0)) 24)
(arithmetic-shift (char->ascii (list-ref ip 1)) 16) (arithmetic-shift (char->ascii (list-ref ip 1)) 16)
(arithmetic-shift (char->ascii (list-ref ip 2)) 8) (arithmetic-shift (char->ascii (list-ref ip 2)) 8)
@ -293,7 +291,6 @@
;; converts a 32 bit integer internet-address to an octeted-ip ;; converts a 32 bit integer internet-address to an octeted-ip
(define (address32->octet-ip ip) (define (address32->octet-ip ip)
(if *debug* (display "number->octet-quad\n"))
(list (arithmetic-shift ip -24) (list (arithmetic-shift ip -24)
(modulo (arithmetic-shift ip -16) 256) (modulo (arithmetic-shift ip -16) 256)
(modulo (arithmetic-shift ip -8) 256) (modulo (arithmetic-shift ip -8) 256)
@ -301,12 +298,10 @@
;; converts an ip-string to an 32bit integer internet-address ;; converts an ip-string to an 32bit integer internet-address
(define (ip-string->address32 ip) (define (ip-string->address32 ip)
(if *debug* (display "ip-string->address32\n")) (octet-ip->address32 (ip-string->octet-ip ip)))
(octet-ip->address32 (string->octet-ip ip)))
;; converts an ip-string to an 32bit integer internet-address ;; converts an ip-string to an 32bit integer internet-address
(define (address32->ip-string ip) (define (address32->ip-string ip)
; (if *debug* (display "address32->ip-string\n"))
(format #f (format #f
"~a.~a.~a.~a" "~a.~a.~a.~a"
(arithmetic-shift ip -24) (arithmetic-shift ip -24)
@ -315,8 +310,7 @@
(modulo ip 256))) (modulo ip 256)))
;; converts an octeted-ip to an human readable ip-string ;; converts an octeted-ip to an human readable ip-string
(define (octet-ip->string s) (define (octet-ip->ip-string s)
(if *debug* (display "octet-ip->string\n"))
(format #f (format #f
"~a.~a.~a.~a" "~a.~a.~a.~a"
(char->ascii (list-ref s 0)) (char->ascii (list-ref s 0))
@ -332,7 +326,7 @@
eos))) eos)))
;; converts an ip-string to octets ;; converts an ip-string to octets
(define (string->octet-ip s) (define (ip-string->octet-ip s)
(cond (cond
((regexp-search ip-string-regexp s) ((regexp-search ip-string-regexp s)
=> (lambda (match) => (lambda (match)
@ -345,6 +339,7 @@
(error "invalid ip-string" s)))) (error "invalid ip-string" s))))
;; calculates a "random" number, needed for message-ids ;; calculates a "random" number, needed for message-ids
;; TODO use SRFI-27
(define random (define random
(let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) (let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
(lambda (limit) (lambda (limit)
@ -375,7 +370,7 @@
(<= 0 v #xffffffff))) (<= 0 v #xffffffff)))
;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip) ;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip)
(define (ip-string->in-addr s) (define (ip-string->in-addr-arpa s)
(cond (cond
((regexp-search ip-string-regexp s) ((regexp-search ip-string-regexp s)
=> (lambda (match) => (lambda (match)
@ -389,7 +384,6 @@
;; filters types in a list of rrs ;; filters types in a list of rrs
(define (filter-type list type) (define (filter-type list type)
(if *debug* (display "ip-string->in-addr\n"))
(filter (lambda (rr) (filter (lambda (rr)
(eq? (rr:type rr) type)) (eq? (rr:type rr) type))
list)) list))
@ -417,7 +411,6 @@
;; makes an message header ;; makes an message header
(define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount) (define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount)
(if *debug* (display "make-octet-header\n"))
(let* ((header-id (number->octet-pair id)) (let* ((header-id (number->octet-pair id))
(header-flags (list (header-flags (list
(ascii->char (+ (arithmetic-shift qr 7) (ascii->char (+ (arithmetic-shift qr 7)
@ -442,7 +435,6 @@
;; a standard query header, usefull for most queries ;; a standard query header, usefull for most queries
(define (make-std-octet-query-header id question-count) (define (make-std-octet-query-header id question-count)
(if *debug* (display "make-std-octet-query-header\n"))
(let* ((qr 0) ; querytype: query 0, response 1 (let* ((qr 0) ; querytype: query 0, response 1
(opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2 (opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2
(aa 0) ; authorative answer (in answers only) (aa 0) ; authorative answer (in answers only)
@ -461,7 +453,6 @@
;; makes a question (name, type, class) ;; makes a question (name, type, class)
(define (make-octet-question name type class) (define (make-octet-question name type class)
(if *debug* (display "make-octet-question\n"))
(if (not (assoc type types)) (if (not (assoc type types))
(dns-error 'invalid-type)) (dns-error 'invalid-type))
(if (not (assoc class classes)) (if (not (assoc class classes))
@ -475,7 +466,6 @@
;; makes a query-message (header and question only) ;; makes a query-message (header and question only)
(define (make-octet-query-message id name type class) (define (make-octet-query-message id name type class)
(if *debug* (display "make-octet-query-message\n"))
(append (append
(make-std-octet-query-header id 1) (make-std-octet-query-header id 1)
(make-octet-question name type class))) (make-octet-question name type class)))
@ -483,7 +473,6 @@
;; makes a resource record for ans, nss, ars (name, type, class, ttl, data) ;; makes a resource record for ans, nss, ars (name, type, class, ttl, data)
(define (make-octet-rr name type class ttl rdata) (define (make-octet-rr name type class ttl rdata)
(if *debug* (display "make-octet-rr\n"))
(let* ((name (name->octets name)) (let* ((name (name->octets name))
(type (number->octet-pair (cadr (assoc type types)))) (type (number->octet-pair (cadr (assoc type types))))
(class (number->octet-pair (cadr (assoc class classes)))) (class (number->octet-pair (cadr (assoc class classes))))
@ -557,7 +546,6 @@
;; parses a domain-name in an message. returns the name and the rest of the message. ;; parses a domain-name in an message. returns the name and the rest of the message.
(define (parse-name start message) (define (parse-name start message)
(if *debug* (display "parse-name\n"))
(let ((v (char->ascii (car start)))) (let ((v (char->ascii (car start))))
(cond (cond
((zero? v) ((zero? v)
@ -592,7 +580,6 @@
;; parses a question in a message. returns the question and the rest of the message. ;; parses a question in a message. returns the question and the rest of the message.
(define (parse-question start message) (define (parse-question start message)
(if *debug* (display "parse-question\n"))
(call-with-values (call-with-values
(lambda () (parse-name start message)) (lambda () (parse-name start message))
(lambda (name start) (lambda (name start)
@ -604,7 +591,6 @@
;; parses a resourcerecord in a message. returns the rr and the rest of the message. ;; parses a resourcerecord in a message. returns the rr and the rest of the message.
(define (parse-rr start message) (define (parse-rr start message)
(if *debug* (display "parse-rr\n"))
(call-with-values (call-with-values
(lambda () (parse-name start message)) (lambda () (parse-name start message))
(lambda (name start) (lambda (name start)
@ -670,7 +656,6 @@
;; ;;
(define (parse-rr-data type class data message) (define (parse-rr-data type class data message)
(if *debug* (display "parse-rr-data\n"))
(cond (cond
((eq? type 'a) ((eq? type 'a)
(make-rr-data-a (octet-ip->address32 data))) (make-rr-data-a (octet-ip->address32 data)))
@ -728,7 +713,6 @@
;; parses n-times a message with parse. returns a list of parse-returns. ;; parses n-times a message with parse. returns a list of parse-returns.
(define (parse-n parse start message n) (define (parse-n parse start message n)
(if *debug* (display "parse-n\n"))
(let loop ((n n) (start start) (accum '())) (let loop ((n n) (start start) (accum '()))
(if (zero? n) (if (zero? n)
(values (reverse! accum) start) (values (reverse! accum) start)
@ -739,7 +723,6 @@
;; parses a message-headers flags. returns the flags. ;; parses a message-headers flags. returns the flags.
(define (parse-flags message) (define (parse-flags message)
(if *debug* (display "parse-flags\n"))
(let ((v0 (list-ref message 2)) (let ((v0 (list-ref message 2))
(v1 (list-ref message 3))) (v1 (list-ref message 3)))
;; Check for error code: ;; Check for error code:
@ -756,7 +739,6 @@
;; parses a message-header. returns the header. ;; parses a message-header. returns the header.
(define (parse-header message) (define (parse-header message)
(if *debug* (display "parse-header\n"))
(let ((id (octet-pair->number (list-ref message 0) (list-ref message 1))) (let ((id (octet-pair->number (list-ref message 0) (list-ref message 1)))
(flags (parse-flags message)) (flags (parse-flags message))
(qd-count (octet-pair->number (list-ref message 4) (list-ref message 5))) (qd-count (octet-pair->number (list-ref message 4) (list-ref message 5)))
@ -768,7 +750,6 @@
;; parses a message. returns the parsed message. ;; parses a message. returns the parsed message.
(define (parse message) (define (parse message)
(if *debug* (display "parse\n"))
(let* ((header (parse-header message)) (let* ((header (parse-header message))
(start (list-tail message 12))) (start (list-tail message 12)))
(call-with-values (call-with-values
@ -793,7 +774,6 @@
;; checks if the received reply is valid. returns #t or error-msg. ;; checks if the received reply is valid. returns #t or error-msg.
(define (reply-acceptable? reply query) (define (reply-acceptable? reply query)
(if *debug* (display "reply-acceptable?\n"))
;; Check correct id ;; Check correct id
(if (not (and (char=? (car reply) (car query)) (if (not (and (char=? (car reply) (car query))
(char=? (cadr reply) (cadr query)))) (char=? (cadr reply) (cadr query))))
@ -864,7 +844,6 @@
;; here: via UDP ;; here: via UDP
(define (send-receive-message-udp nameservers query) (define (send-receive-message-udp nameservers query)
(if *debug* (display "send-receive-message\n"))
(receive (reply hit-ns other-nss) (receive (reply hit-ns other-nss)
(let ((sockets (map (lambda (nameserver) (let ((sockets (map (lambda (nameserver)
(let ((sock (create-socket protocol-family/internet (let ((sock (create-socket protocol-family/internet
@ -918,7 +897,6 @@
;; searches in a dns-msg for the shortest ttl. this is needed for cache-management. ;; searches in a dns-msg for the shortest ttl. this is needed for cache-management.
(define (find-shortest-ttl dns-msg) (define (find-shortest-ttl dns-msg)
(if *debug* (display "find-shortest-ttl\n"))
(letrec ((minimum #f) (letrec ((minimum #f)
(find-shortest-ttl-1 (find-shortest-ttl-1
(lambda (dns-msg) (lambda (dns-msg)
@ -1079,8 +1057,8 @@
;; dns-lookup with more options than dns-lookup-* ;; dns-lookup with more options than dns-lookup-*
(define (dns-lookup name type . nameservers) (define (dns-lookup name type . nameservers)
(let* ((maybe-ip-string (if (address32? name) (let* ((maybe-ip-string (if (address32? name)
(ip-string->in-addr (address32->ip-string name)) (ip-string->in-addr-arpa (address32->ip-string name))
(ip-string->in-addr 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 (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 'in) (make-octet-query-message (random 256) maybe-ip-string type 'in)
(make-octet-query-message (random 256) name type 'in))) (make-octet-query-message (random 256) name type 'in)))
@ -1101,8 +1079,8 @@
;; (dns-lookup-name <name> nameservers) ;; (dns-lookup-name <name> nameservers)
(define (dns-lookup-name name . nameservers) (define (dns-lookup-name name . nameservers)
(let* ((maybe-ip-string (if (address32? name) (let* ((maybe-ip-string (if (address32? name)
(ip-string->in-addr (address32->ip-string name)) (ip-string->in-addr-arpa (address32->ip-string name))
(ip-string->in-addr 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 (question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname) (dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name 'a 'in))) (make-octet-query-message (random 256) name 'a 'in)))
@ -1121,8 +1099,8 @@
;; (dns-inverse-lookup <name> [nameserver]) ;; (dns-inverse-lookup <name> [nameserver])
(define (dns-lookup-ip ip . nameservers) (define (dns-lookup-ip ip . nameservers)
(let* ((maybe-ip-string (if (address32? ip) (let* ((maybe-ip-string (if (address32? ip)
(ip-string->in-addr (address32->ip-string ip)) (ip-string->in-addr-arpa (address32->ip-string ip))
(ip-string->in-addr 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 (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 'ptr 'in) (make-octet-query-message (random 256) maybe-ip-string 'ptr 'in)
(dns-error 'not-a-ip))) (dns-error 'not-a-ip)))
@ -1144,8 +1122,8 @@
;; (dns-lookup-nameserver <name> [nameserver]) ;; (dns-lookup-nameserver <name> [nameserver])
(define (dns-lookup-nameserver name . nameservers) (define (dns-lookup-nameserver name . nameservers)
(let* ((maybe-ip-string (if (address32? name) (let* ((maybe-ip-string (if (address32? name)
(ip-string->in-addr (address32->ip-string name)) (ip-string->in-addr-arpa (address32->ip-string name))
(ip-string->in-addr 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 (question (if maybe-ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname) (dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name 'ns 'in))) (make-octet-query-message (random 256) name 'ns 'in)))
@ -1174,8 +1152,8 @@
;; (dns-lookup-mail-exchanger <name> [nameserver]) ;; (dns-lookup-mail-exchanger <name> [nameserver])
(define (dns-lookup-mail-exchanger name . nameservers) (define (dns-lookup-mail-exchanger name . nameservers)
(let* ((ip-string (if (address32? name) (let* ((ip-string (if (address32? name)
(ip-string->in-addr (address32->ip-string name)) (ip-string->in-addr-arpa (address32->ip-string name))
(ip-string->in-addr 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 (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
(dns-error 'not-a-hostname) (dns-error 'not-a-hostname)
(make-octet-query-message (random 256) name 'mx 'in))) (make-octet-query-message (random 256) name 'mx 'in)))
@ -1337,6 +1315,7 @@
(define (host-fqdn name-or-socket-address) (define (host-fqdn name-or-socket-address)
(if (socket-address? name-or-socket-address) (if (socket-address? name-or-socket-address)
(socket-address->fqdn name-or-socket-address #f) (socket-address->fqdn name-or-socket-address #f)
;; TODO: try looking up with domain from "search" appended
(internet-address->fqdn (internet-address->fqdn
(car (car
(host-info:addresses (host-info:addresses
@ -1345,5 +1324,6 @@
;;; TODO THIS USES gethostbyname ;;; TODO THIS USES gethostbyname
(define (system-fqdn) (define (system-fqdn)
;; TODO: isn't this simply (host-fqdn (system-name))?
(internet-address->fqdn (car (host-info:addresses (host-info (system-name)))) (internet-address->fqdn (car (host-info:addresses (host-info (system-name))))
#t)) #t))