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

380
scheme/lib/dns.scm
View File

@ -6,6 +6,7 @@
;;; 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.
@ -187,7 +188,7 @@
message-type?
the-message-types
message-type-name
message-type-index
message-type-number
(unknown ; types, which are not yet implemented
a ; a host address
ns ; an authoritative name server
@ -211,7 +212,7 @@
message-class?
the-message-classes
message-class-name
message-class-index
message-class-number
(placeholder ; this starts at 0...
in ; the Internet
cs ; (obsolete)
@ -411,27 +412,30 @@
;;; -- message constructors: encode to octet-messages
;; 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))
(header-flags (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 z 4)
rcode))))
(header-qdcount (number->octet-pair qdcount))
(header-ancount (number->octet-pair ancount))
(header-nscount (number->octet-pair nscount))
(header-arcount (number->octet-pair arcount)))
(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-qdcount
header-ancount
header-nscount
header-arcount)))
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
@ -442,14 +446,16 @@
(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)
(z 0) ; future use
(rcode 0) ; response code: error conditions (in answers only)
(qdcount question-count)
(ancount 0) ; answer count (in answers only)
(nscount 0) ; name server resources (in answers only)
(arcount 0)) ; additional records (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 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)
@ -460,8 +466,8 @@
(dns-error 'invalid-class))
(let* ((qname (name->octets name))
(qtype (number->octet-pair (message-type-index type)))
(qclass (number->octet-pair (message-class-index class))))
(qtype (number->octet-pair (message-type-number type)))
(qclass (number->octet-pair (message-class-number class))))
(append qname qtype qclass)))
@ -475,8 +481,8 @@
;; 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-index type)))
(class (number->octet-pair (message-class-index class)))
(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))
@ -509,28 +515,49 @@
;; 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?
(id header-id)
(flags header-flags)
(qdc header-qdc)
(anc header-anc)
(nsc header-nsc)
(arc header-arc))
(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 auth trunc recursiondesired recursionavailable
z rcode)
(make-flags querytype opcode authoritative? truncated? recursion-desired?
recursion-available? zero response-code)
flags?
(querytype flags-querytype)
(opcode flags-opcode)
(auth flags-auth)
(trunc flags-trunc)
(recursiondesired flags-recursiondesired)
(recursionavailable flags-recursionavailable)
(z flags-z)
(rcode flags-rcode))
(querytype flags-querytype)
(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
@ -599,9 +626,11 @@
(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))))
(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))))
(let ((class (vector-ref the-message-classes
(octet-pair->number (car start) (cadr start))))
(start (cddr start)))
(values (make-question name type class) start))))))
@ -610,9 +639,11 @@
(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))))
(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))))
(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)))
@ -760,26 +791,26 @@
(let ((v0 (list-ref message 2))
(v1 (list-ref message 3)))
;; Check for error code:
(let ((rcode (bitwise-and #xf (char->ascii v1)))
(z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
(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 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.
(define (parse-header message)
(let ((id (octet-pair->number (list-ref message 0) (list-ref message 1)))
(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)))
(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 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.
@ -787,16 +818,16 @@
(let* ((header (parse-header message))
(start (list-tail message 12)))
(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)
(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)
(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)
(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)
(if (not (null? start))
(dns-error 'parse-error))
@ -811,22 +842,16 @@
;; 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 ((rcode (flags-rcode (parse-flags reply))))
(if (not (zero? rcode))
(case rcode
((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"))))))
(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)
(let ((trunc (flags-trunc (parse-flags reply))))
(= trunc 1)))
(flags-truncated? (parse-flags reply)))
;; connects to nameserver and sends and receives messages. returns the reply.
;; here: via TCP
@ -922,7 +947,7 @@
(define cache (make-string-table))
;; resets the cache
(define (dns-clear-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.
@ -1028,11 +1053,9 @@
(dns-query/cache question use-cache? protocol nss tried)
(if (check-answer dns-msg)
dns-msg
(let ((auth? (not
(zero?
(flags-auth (header-flags
(message-header
(dns-message-reply 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,
@ -1365,106 +1388,111 @@
(map (lambda (elem) (rr-data-mx-exchanger (rr-data elem))) (sort-by-preference mx))))))
;;; pretty-prints a dns-msg
(define (show-dns-message dns-msg)
(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)))))
(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-qdc dns-msg))
(d 4 "answer-count " (header-anc dns-msg))
(d 4 "nameserver-count " (header-nsc dns-msg))
(d 4 "additional-count " (header-arc dns-msg))))
((flags? dns-msg)
(begin
(d 5 "querytype" (flags-querytype dns-msg))
(d 5 "opcode" (flags-opcode dns-msg))
(d 5 "auth" (flags-auth dns-msg))
(d 5 "trunc" (flags-trunc dns-msg))
(d 5 "recursiondesired" (flags-recursiondesired dns-msg))
(d 5 "recursionavailable" (flags-recursionavailable dns-msg))
(d 5 "z" (flags-z dns-msg))
(d 5 "rcode" (flags-rcode 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)))
)))
(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* '())