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

+ Expand lots of acronyms. 

+ Some renamings
This commit is contained in:
mainzelm 2003-01-17 18:29:47 +00:00
parent 104802b3ae
commit 48290e2f83
1 changed files with 204 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

196
scheme/lib/dns.scm
View File

@ -6,6 +6,7 @@
;;; This file is part of the Scheme Untergrund Networking package. ;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Marcus Crestani. ;;; Copyright (c) 2002 by Marcus Crestani.
;;; Copyright (c) 2002-2003 by Martin Gasbichler
;;; For copyright information, see the file COPYING which comes with ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
@ -187,7 +188,7 @@
message-type? message-type?
the-message-types the-message-types
message-type-name message-type-name
message-type-index message-type-number
(unknown ; types, which are not yet implemented (unknown ; types, which are not yet implemented
a ; a host address a ; a host address
ns ; an authoritative name server ns ; an authoritative name server
@ -211,7 +212,7 @@
message-class? message-class?
the-message-classes the-message-classes
message-class-name message-class-name
message-class-index message-class-number
(placeholder ; this starts at 0... (placeholder ; this starts at 0...
in ; the Internet in ; the Internet
cs ; (obsolete) cs ; (obsolete)
@ -411,27 +412,30 @@
;;; -- message constructors: encode to octet-messages ;;; -- message constructors: encode to octet-messages
;; 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 header-flags question-count answer-count
nameserver-count additional-count)
(let* ((header-id (number->octet-pair id)) (let* ((header-id (number->octet-pair id))
(header-flags (list (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) (ascii->char (+ (arithmetic-shift qr 7)
(arithmetic-shift opcode 3) (arithmetic-shift opcode 3)
(arithmetic-shift aa 2) (arithmetic-shift aa 2)
(arithmetic-shift tc 1) (arithmetic-shift tc 1)
rd)) rd))
(ascii->char (+ (arithmetic-shift ra 7) (ascii->char (+ (arithmetic-shift ra 7)
(arithmetic-shift z 4) (arithmetic-shift zero 4)
rcode)))) response-code))))
(header-qdcount (number->octet-pair qdcount))
(header-ancount (number->octet-pair ancount))
(header-nscount (number->octet-pair nscount))
(header-arcount (number->octet-pair arcount)))
(append header-id
header-flags
header-qdcount
header-ancount
header-nscount
header-arcount)))
;; a standard query header, usefull for most queries ;; a standard query header, usefull for most queries
@ -442,14 +446,16 @@
(tc 0) ; truncation (size matters only with UDP) (tc 0) ; truncation (size matters only with UDP)
(rd 1) ; recursion desired: nameserver pursues the query recursivly (optional) (rd 1) ; recursion desired: nameserver pursues the query recursivly (optional)
(ra 0) ; recursion available (in answers only) (ra 0) ; recursion available (in answers only)
(z 0) ; future use (zero 0) ; future use
(rcode 0) ; response code: error conditions (in answers only) (response-code 0) ; response code: error conditions (in answers only)
(qdcount question-count) (question-count question-count)
(ancount 0) ; answer count (in answers only) (answer-count 0) ; answer count (in answers only)
(nscount 0) ; name server resources (in answers only) (nameserver-count 0) ; name server resources (in answers only)
(arcount 0)) ; additional records (in answers only) (additional-count 0)) ; additional records (in answers only)
(make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount))) (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) ;; makes a question (name, type, class)
@ -460,8 +466,8 @@
(dns-error 'invalid-class)) (dns-error 'invalid-class))
(let* ((qname (name->octets name)) (let* ((qname (name->octets name))
(qtype (number->octet-pair (message-type-index type))) (qtype (number->octet-pair (message-type-number type)))
(qclass (number->octet-pair (message-class-index class)))) (qclass (number->octet-pair (message-class-number class))))
(append qname qtype qclass))) (append qname qtype qclass)))
@ -475,8 +481,8 @@
;; 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)
(let* ((name (name->octets name)) (let* ((name (name->octets name))
(type (number->octet-pair (message-type-index type))) (type (number->octet-pair (message-type-number type)))
(class (number->octet-pair (message-class-index class))) (class (number->octet-pair (message-class-number class)))
(ttl (number->octet-quad ttl)) (ttl (number->octet-quad ttl))
(rdlength (number->octet-pair (length rdata))) (rdlength (number->octet-pair (length rdata)))
(rdata rdata)) (rdata rdata))
@ -509,28 +515,49 @@
;; header ;; header
(define-record-type header :header (define-record-type header :header
(make-header id flags qdc anc nsc arc) (make-header id flags question-count answer-count nameserver-count
additional-count)
header? header?
(id header-id) (id header-id)
(flags header-flags) (flags header-flags)
(qdc header-qdc) (question-count header-question-count)
(anc header-anc) (answer-count header-answer-count)
(nsc header-nsc) (nameserver-count header-nameserver-count)
(arc header-arc)) (additional-count header-additional-count))
;; flags ;; flags
(define-record-type flags :flags (define-record-type flags :flags
(make-flags querytype opcode auth trunc recursiondesired recursionavailable (make-flags querytype opcode authoritative? truncated? recursion-desired?
z rcode) recursion-available? zero response-code)
flags? flags?
(querytype flags-querytype) (querytype flags-querytype)
(opcode flags-opcode) (opcode flags-opcode)
(auth flags-auth) (authoritative? flags-authoritative?)
(trunc flags-trunc) (truncated? flags-truncated?)
(recursiondesired flags-recursiondesired) (recursion-desired? flags-recursion-desired?)
(recursionavailable flags-recursionavailable) (recursion-available? flags-recursion-available?)
(z flags-z) (zero flags-zero)
(rcode flags-rcode)) (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 ;; question
(define-record-type question :question (define-record-type question :question
@ -599,9 +626,11 @@
(call-with-values (call-with-values
(lambda () (parse-name start message)) (lambda () (parse-name start message))
(lambda (name start) (lambda (name start)
(let ((type (vector-ref the-message-types (octet-pair->number (car start) (cadr start)))) (let ((type (vector-ref the-message-types
(octet-pair->number (car start) (cadr start))))
(start (cddr start))) (start (cddr start)))
(let ((class (vector-ref the-message-classes (octet-pair->number (car start) (cadr start)))) (let ((class (vector-ref the-message-classes
(octet-pair->number (car start) (cadr start))))
(start (cddr start))) (start (cddr start)))
(values (make-question name type class) start)))))) (values (make-question name type class) start))))))
@ -610,9 +639,11 @@
(call-with-values (call-with-values
(lambda () (parse-name start message)) (lambda () (parse-name start message))
(lambda (name start) (lambda (name start)
(let ((type (vector-ref the-message-types (octet-pair->number (car start) (cadr start)))) (let ((type (vector-ref the-message-types
(octet-pair->number (car start) (cadr start))))
(start (cddr start))) (start (cddr start)))
(let ((class (vector-ref the-message-classes (octet-pair->number (car start) (cadr start)))) (let ((class (vector-ref the-message-classes
(octet-pair->number (car start) (cadr start))))
(start (cddr start))) (start (cddr start)))
(let ((ttl (octet-quad->number (car start) (cadr start) (let ((ttl (octet-quad->number (car start) (cadr start)
(caddr start) (cadddr start))) (caddr start) (cadddr start)))
@ -760,26 +791,26 @@
(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:
(let ((rcode (bitwise-and #xf (char->ascii v1))) (let ((response-code (bitwise-and #xf (char->ascii v1)))
(z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4)) (zero (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
(ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7)) (ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7))
(rd (bitwise-and 1 (char->ascii v0))) (rd (bitwise-and 1 (char->ascii v0)))
(tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1)) (tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1))
(aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2)) (aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2))
(opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3)) (opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3))
(qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7))) (qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7)))
(make-flags qr opcode aa tc rd ra z rcode)))) (make-flags-from-numbers qr opcode aa tc rd ra zero response-code))))
;; parses a message-header. returns the header. ;; parses a message-header. returns the header.
(define (parse-header message) (define (parse-header message)
(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))) (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))) (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))) (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)))) (ar-count (octet-pair->number (list-ref message 10) (list-ref message 11))))
(make-header id flags qd-count an-count ns-count ar-count))) (make-header id flags question-count an-count ns-count ar-count)))
;; parses a message. returns the parsed message. ;; parses a message. returns the parsed message.
@ -787,16 +818,16 @@
(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
(lambda () (parse-n parse-question start message (header-qdc header))) (lambda () (parse-n parse-question start message (header-question-count header)))
(lambda (qds start) (lambda (qds start)
(call-with-values (call-with-values
(lambda () (parse-n parse-rr start message (header-anc header))) (lambda () (parse-n parse-rr start message (header-answer-count header)))
(lambda (ans start) (lambda (ans start)
(call-with-values (call-with-values
(lambda () (parse-n parse-rr start message (header-nsc header))) (lambda () (parse-n parse-rr start message (header-nameserver-count header)))
(lambda (nss start) (lambda (nss start)
(call-with-values (call-with-values
(lambda () (parse-n parse-rr start message (header-arc header))) (lambda () (parse-n parse-rr start message (header-additional-count header)))
(lambda (ars start) (lambda (ars start)
(if (not (null? start)) (if (not (null? start))
(dns-error 'parse-error)) (dns-error 'parse-error))
@ -811,22 +842,16 @@
;; 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))))
;; TODO replace display
(display "send-receive-message: bad reply id from server")) (display "send-receive-message: bad reply id from server"))
;; Check for error code: ;; Check for error code:
(let ((rcode (flags-rcode (parse-flags reply)))) (let ((response-code (flags-response-code (parse-flags reply))))
(if (not (zero? rcode)) (if (not (eq? response-code 'dns-no-error))
(case rcode (dns-error response-code))))
((1) (dns-error 'dns-format-error))
((2) (dns-error 'dns-server-failure))
((3) (dns-error 'dns-name-error))
((4) (dns-error 'dns-not-implemented))
((5) (dns-error 'dns-refused))
(else (error "this must not happend"))))))
;; #t if message is truncated (could happen via UDP) ;; #t if message is truncated (could happen via UDP)
(define (truncated? reply) (define (truncated? reply)
(let ((trunc (flags-trunc (parse-flags reply)))) (flags-truncated? (parse-flags reply)))
(= trunc 1)))
;; connects to nameserver and sends and receives messages. returns the reply. ;; connects to nameserver and sends and receives messages. returns the reply.
;; here: via TCP ;; here: via TCP
@ -922,7 +947,7 @@
(define cache (make-string-table)) (define cache (make-string-table))
;; resets the cache ;; resets the cache
(define (dns-clear-cache) (define (dns-clear-cache!)
(set! cache (make-string-table))) (set! cache (make-string-table)))
;; 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.
@ -1028,11 +1053,9 @@
(dns-query/cache question use-cache? protocol nss tried) (dns-query/cache question use-cache? protocol nss tried)
(if (check-answer dns-msg) (if (check-answer dns-msg)
dns-msg dns-msg
(let ((auth? (not (let ((auth? (flags-authoritative? (header-flags
(zero?
(flags-auth (header-flags
(message-header (message-header
(dns-message-reply dns-msg)))))))) (dns-message-reply dns-msg))))))
(if auth? (if auth?
(dns-error 'bad-address) (dns-error 'bad-address)
;; other nameservers names are found in the nameserver-part, ;; other nameservers names are found in the nameserver-part,
@ -1365,8 +1388,8 @@
(map (lambda (elem) (rr-data-mx-exchanger (rr-data elem))) (sort-by-preference mx)))))) (map (lambda (elem) (rr-data-mx-exchanger (rr-data elem))) (sort-by-preference mx))))))
;;; pretty-prints a dns-msg ;;; pretty-prints a dns-msg
(define (show-dns-message dns-msg) (define (pretty-print-dns-message dns-msg . maybe-port)
(let* ((d (let ((d
(lambda (n s1 s2) (lambda (n s1 s2)
(letrec ((loop (lambda (n) (letrec ((loop (lambda (n)
(if (zero? n) (if (zero? n)
@ -1377,7 +1400,12 @@
(display ": ") (display ": ")
(display s2) (display s2)
(newline))))) (newline)))))
(with-current-output-port
(if (null? maybe-port)
(current-output-port)
(car maybe-port))
(lambda ()
(define (show-dns-message dns-msg)
(cond (cond
((dns-message? dns-msg) ((dns-message? dns-msg)
(begin (begin
@ -1410,20 +1438,20 @@
(begin (begin
(d 4 "id" (header-id dns-msg)) (d 4 "id" (header-id dns-msg))
(d 4 "Flags" "")(show-dns-message (header-flags dns-msg)) (d 4 "Flags" "")(show-dns-message (header-flags dns-msg))
(d 4 "question-count " (header-qdc dns-msg)) (d 4 "question-count " (header-question-count dns-msg))
(d 4 "answer-count " (header-anc dns-msg)) (d 4 "answer-count " (header-answer-count dns-msg))
(d 4 "nameserver-count " (header-nsc dns-msg)) (d 4 "nameserver-count " (header-nameserver-count dns-msg))
(d 4 "additional-count " (header-arc dns-msg)))) (d 4 "additional-count " (header-additional-count dns-msg))))
((flags? dns-msg) ((flags? dns-msg)
(begin (begin
(d 5 "querytype" (flags-querytype dns-msg)) (d 5 "querytype" (flags-querytype dns-msg))
(d 5 "opcode" (flags-opcode dns-msg)) (d 5 "opcode" (flags-opcode dns-msg))
(d 5 "auth" (flags-auth dns-msg)) (d 5 "authoritative?" (flags-authoritative? dns-msg))
(d 5 "trunc" (flags-trunc dns-msg)) (d 5 "truncated?" (flags-truncated? dns-msg))
(d 5 "recursiondesired" (flags-recursiondesired dns-msg)) (d 5 "recursion-desired?" (flags-recursion-desired? dns-msg))
(d 5 "recursionavailable" (flags-recursionavailable dns-msg)) (d 5 "recursion-available?" (flags-recursion-available? dns-msg))
(d 5 "z" (flags-z dns-msg)) (d 5 "zero" (flags-zero dns-msg))
(d 5 "rcode" (flags-rcode dns-msg)))) (d 5 "response-code" (flags-response-code dns-msg))))
((question? dns-msg) ((question? dns-msg)
(begin (begin
(d 4 "name " (question-name dns-msg)) (d 4 "name " (question-name dns-msg))
@ -1463,8 +1491,8 @@
(d 5 "text " (rr-data-txt-text dns-msg))) (d 5 "text " (rr-data-txt-text dns-msg)))
((rr-data-wks? dns-msg) ((rr-data-wks? dns-msg)
(d 5 "data " (rr-data-wks-data dns-msg))) (d 5 "data " (rr-data-wks-data dns-msg)))
))
))) (show-dns-message dns-msg)))))
(define *fqdn-lock* (make-lock)) (define *fqdn-lock* (make-lock))
(define *fqdn-cache* '()) (define *fqdn-cache* '())