Support reverse lookups with IPv6 addresses

collects/net/dns.rkt

@@ -34,16 +34,19 @@
 ;; An LB is a (Listof Bytes)
 ;;
 ;; An IPAddressString passes the following predicate
-;;
-;; Any -> Boolean
-;; check if the input string represents an IPv4 address
 (define (ip-address-string? val)
+  (and (string? val)
+       (or (ipv4-string? val)
+           (ipv6-string? val))))
+
+;; String -> Boolean
+;; Check if the input string represents an IPv4 address
+(define (ipv4-string? str)
   ;; String -> Boolean
   ;; check if the given string has leading zeroes
   (define (has-leading-zeroes? str)
     (and (> (string-length str) 1)
          (char=? (string-ref str 0) #\0)))
-  (define (ipv4-string? str)
   (define matches
     (regexp-match #px"^(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})\\.(\\d{1,3})$"
                   str))
@@ -53,8 +56,11 @@
        (andmap byte? (map string->number (cdr matches)))
        ;; leading zeroes lead to query errors
        (not (ormap has-leading-zeroes? matches))))
-  ;; TODO: support dotted quad notation
-  (define (ipv6-string? str)
+
+;; String -> Boolean
+;; Check if the input string represents an IPv6 address
+;; TODO: support dotted quad notation
+(define (ipv6-string? str)
   (define re-::/: #px"^([0-9a-fA-F]{1,4})(::|:)")
   (define re-:: #px"^()(::)")
   (define re-: #px"^([0-9a-fA-F]{1,4})(:)")
@@ -81,9 +87,6 @@
                     (implies (not ::?) (= (length octet-pairs) 7))
                     ;; this is the +1 octet pair
                     (regexp-match? re-end str))]))))
-  (and (string? val)
-       (or (ipv4-string? val)
-           (ipv6-string? val))))
 
 (module+ test
   (check-true (ip-address-string? "8.8.8.8"))
@@ -404,6 +407,14 @@
                       (not (member ns tried))
                       (loop ns (cons ns tried)))))))))
 
+;; String -> String
+;; Convert an IP address to a suitable format for a reverse lookup
+(define (ip->query-domain ip)
+  (if (ipv4-string? ip)
+      (ip->in-addr.arpa ip)
+      (ip->ip6.arpa ip)))
+
+;; Convert an IPv4 address for reverse lookup
 (define (ip->in-addr.arpa ip)
   (let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
                               ip)])
@@ -413,6 +424,45 @@
             (list-ref result 2)
             (list-ref result 1))))
 
+;; Convert an IPv6 address for reverse lookup
+(define (ip->ip6.arpa ip)
+  (define has-::? (regexp-match? #rx"::" ip))
+  (define octet-pair-strings
+    (cond [has-::?
+           (define without-:: (regexp-replace #rx"::" ip ":replace-me:"))
+           (define pieces (regexp-split #rx":" without-::))
+           (define num-pieces (sub1 (length pieces))) ; don't count replace-me
+           (flatten
+            ;; put in as many 0s needed to expand the ::
+            (for/list ([piece pieces])
+              (if (string=? piece "replace-me")
+                  (build-list (- 8 num-pieces) (λ _ "0"))
+                  piece)))]
+          [else (regexp-split #rx":" ip)]))
+  ;; convert to nibbles
+  (define nibbles
+    (for/fold ([nibbles '()])
+              ([two-octs octet-pair-strings])
+      (define n (string->number two-octs 16))
+      (define nib1 (arithmetic-shift (bitwise-and #xf000 n) -12))
+      (define nib2 (arithmetic-shift (bitwise-and #x0f00 n) -8))
+      (define nib3 (arithmetic-shift (bitwise-and #x00f0 n) -4))
+      (define nib4 (bitwise-and #x000f n))
+      (append (list nib4 nib3 nib2 nib1) nibbles)))
+  (string-append
+   (string-join
+    (for/list ([n nibbles]) (~r n #:base 16))
+    ".")
+   ".ip6.arpa"))
+
+(module+ test
+  (check-equal?
+   (ip->ip6.arpa "4321:0:1:2:3:4:567:89ab")
+   "b.a.9.8.7.6.5.0.4.0.0.0.3.0.0.0.2.0.0.0.1.0.0.0.0.0.0.0.1.2.3.4.ip6.arpa")
+  (check-equal?
+   (ip->ip6.arpa "2001:db8::567:89ab")
+   "b.a.9.8.7.6.5.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.8.b.d.0.1.0.0.2.ip6.arpa"))
+
 (define (get-ptr-list-from-ans ans)
   (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans))
 
@@ -420,7 +470,7 @@
   (or (try-forwarding
        (lambda (nameserver)
          (let-values ([(auth? qds ans nss ars reply)
-                       (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
+                       (dns-query/cache nameserver (ip->query-domain ip) 'ptr 'in)])
            (values (and (positive? (length (get-ptr-list-from-ans ans)))
                         (let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
                           (let-values ([(name null) (parse-name s reply)])

collects/tests/net/dns.rkt

@@ -22,7 +22,6 @@
         (dns-get-address nameserver *racket-host*) => *racket-ip*
         (dns-get-address nameserver *kame-url* #:ipv6? #t) => *kame-ip*
         (dns-get-name nameserver *racket-ip*) => *racket-host*
-        (dns-get-name nameserver *racket-ip*) => *racket-host*
         (dns-get-mail-exchanger nameserver *racket-url*) => *racket-mx*))
 
 (define (tests)