suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Start to add internal documentation

Browse Source 
original commit: 621fc2b256
This commit is contained in:
Asumu Takikawa 2013-03-02 00:04:37 -05:00
parent e9b40d3e69
commit 77a70d3e52
1 changed files with 48 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/net/dns.rkt
View File

@ -18,9 +18,16 @@
(module+ test (require rackunit)) (module+ test (require rackunit))
;; Contract utilities ;; UDP retry timeout:
(define INIT-TIMEOUT 50)
;; String -> Boolean ;; Contract utilities and Data Definitions
;;
;; An LB is a (Listof Bytes)
;;
;; An IPAddressString passes the following predicate
;;
;; Any -> Boolean
;; check if the input string represents an IPv4 address ;; check if the input string represents an IPv4 address
;; TODO: IPv6, alternative address formats ;; TODO: IPv6, alternative address formats
(define (ip-address-string? val) (define (ip-address-string? val)
@ -54,9 +61,7 @@
(check-false (ip-address-string? "potatoes")) (check-false (ip-address-string? "potatoes"))
(check-false (ip-address-string? "127.0.0"))) (check-false (ip-address-string? "127.0.0")))
;; UDP retry timeout: ;; A Type is one of the following
(define INIT-TIMEOUT 50)
(define types (define types
'((a 1) '((a 1)
(ns 2) (ns 2)
@ -75,12 +80,15 @@
(mx 15) (mx 15)
(txt 16))) (txt 16)))
;; A Class is one of the following
(define classes (define classes
'((in 1) '((in 1)
(cs 2) (cs 2)
(ch 3) (ch 3)
(hs 4))) (hs 4)))
;;;
(define (cossa i l) (define (cossa i l)
(cond [(null? l) #f] (cond [(null? l) #f]
[(equal? (cadar l) i) (car l)] [(equal? (cadar l) i) (car l)]
@ -99,27 +107,42 @@
(arithmetic-shift c 8) (arithmetic-shift c 8)
d)) d))
;; Bytes -> LB
;; Convert the domain name into a sequence of labels, where each
;; label is a length octet and then that many octets
(define (name->octets s) (define (name->octets s)
(let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))]) (let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))])
(let loop ([s s]) (let loop ([s s])
(let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
(if m (if m
(append (do-one (cadr m)) (loop (caddr m))) (append (do-one (cadr m)) (loop (caddr m)))
(append (do-one s) (list 0))))))) ;; terminate with zero length octet
(append (do-one s) (list 0)))))))
;; The query header. See RFC1035 4.1.1 for details
;;
;; The opcode & flags are set as:
;; QR | OPCODE | AA | TC | RD | RA | Z | RCODE |
;; 0 | 0 0 0 0 | 0 | 0 | 1 | 0 | 0 0 0 | 0 0 0 0 |
;;
(define (make-std-query-header id question-count) (define (make-std-query-header id question-count)
(append (number->octet-pair id) (append (number->octet-pair id) ; 16-bit random identifier
(list 1 0) ; Opcode & flags (recusive flag set) (list 1 0) ; Opcode & flags
(number->octet-pair question-count) (number->octet-pair question-count) ; QDCOUNT
(number->octet-pair 0) (number->octet-pair 0) ; ANCOUNT
(number->octet-pair 0) (number->octet-pair 0) ; NSCOUNT
(number->octet-pair 0))) (number->octet-pair 0))) ; ARCOUNT
;; Int16 Bytes Type Class -> LB
;; Construct a DNS query message
(define (make-query id name type class) (define (make-query id name type class)
(append (make-std-query-header id 1) (append (make-std-query-header id 1)
(name->octets name) ;; Question section. See RF1035 4.1.2
(number->octet-pair (cadr (assoc type types))) (name->octets name) ; QNAME
(number->octet-pair (cadr (assoc class classes))))) (number->octet-pair ; QTYPE
(cadr (assoc type types)))
(number->octet-pair ; QCLASS
(cadr (assoc class classes)))))
(define (add-size-tag m) (define (add-size-tag m)
(append (number->octet-pair (length m)) m)) (append (number->octet-pair (length m)) m))
@ -197,6 +220,7 @@
(let-values ([(rr start) (parse start reply)]) (let-values ([(rr start) (parse start reply)])
(loop (sub1 n) start (cons rr accum)))))) (loop (sub1 n) start (cons rr accum))))))
;; NameServer String Type Class -> (Values Boolean LB LB LB LB LB)
(define (dns-query nameserver addr type class) (define (dns-query nameserver addr type class)
(unless (assoc type types) (unless (assoc type types)
(raise-type-error 'dns-query "DNS query type" type)) (raise-type-error 'dns-query "DNS query type" type))
@ -255,7 +279,12 @@
(values (positive? (bitwise-and #x4 v0)) (values (positive? (bitwise-and #x4 v0))
qds ans nss ars reply))))))) qds ans nss ars reply)))))))
;; A cache for DNS query data
;; Stores a (List Boolean LB LB LB LB LB)
(define cache (make-hasheq)) (define cache (make-hasheq))
;; NameServer Address Type Class -> (Values Boolean LB LB LB LB LB)
;; Execute a DNS query and cache it
(define (dns-query/cache nameserver addr type class) (define (dns-query/cache nameserver addr type class)
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
(let ([v (hash-ref cache key (lambda () #f))]) (let ([v (hash-ref cache key (lambda () #f))])
@ -270,8 +299,10 @@
(format "~a.~a.~a.~a" (format "~a.~a.~a.~a"
(list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3))) (list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
;; (NameServer -> (Values Any LB Boolean)) NameServer -> Any
;; Run the given query function, trying until an answer is found
(define (try-forwarding k nameserver) (define (try-forwarding k nameserver)
(let loop ([nameserver nameserver][tried (list nameserver)]) (let loop ([nameserver nameserver] [tried (list nameserver)])
;; Normally the recusion is done for us, but it's technically optional ;; Normally the recusion is done for us, but it's technically optional
(let-values ([(v ars auth?) (k nameserver)]) (let-values ([(v ars auth?) (k nameserver)])
(or v (or v