mainzelm
parent
104802b3ae
commit
48290e2f83
|
|
@ -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
|
||||
(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)
|
||||
(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)))
|
||||
(append header-id
|
||||
header-flags
|
||||
header-qdcount
|
||||
header-ancount
|
||||
header-nscount
|
||||
header-arcount)))
|
||||
(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))
|
||||
(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
|
||||
(let ((auth? (flags-authoritative? (header-flags
|
||||
(message-header
|
||||
(dns-message-reply dns-msg))))))))
|
||||
(dns-message-reply dns-msg))))))
|
||||
(if auth?
|
||||
(dns-error 'bad-address)
|
||||
;; 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))))))
|
||||
|
||||
;;; pretty-prints a dns-msg
|
||||
(define (show-dns-message dns-msg)
|
||||
(let* ((d
|
||||
(define (pretty-print-dns-message dns-msg . maybe-port)
|
||||
(let ((d
|
||||
(lambda (n s1 s2)
|
||||
(letrec ((loop (lambda (n)
|
||||
(if (zero? n)
|
||||
|
|
@ -1377,7 +1400,12 @@
|
|||
(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
|
||||
|
|
@ -1410,20 +1438,20 @@
|
|||
(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))))
|
||||
(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 "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))))
|
||||
(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))
|
||||
|
|
@ -1463,8 +1491,8 @@
|
|||
(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* '())
|
||||
|
|
|
|||
Loading…
Reference in New Issue