source: project/release/3/dns/dns.scm @ 11398

;;;
;;; dns.scm - domain name service lookups
;;; written by elf@ephemeral.net
;;; dialect:  r6rs with chicken sockets
;;; srfis:    1, 6, 13, 23
;;;

;;; a simple dns resolver interface.
;;;
;;; meta functions:
;;; 
;;; (dns:supported-types)
;;; (dns:supported-types-verbose)
;;; list of supported query types.  supported-types-verbose returns pairs
;;; of (type . description).
;;;
;;; (dns:name->label <name>)
;;; encodes <name> (string) into dns label format.
;;;
;;;
;;; resolution:
;;;
;;; (dns:resolve <server> <domain> [recurse?] [verbose?] [type-list])
;;; resolves <domain> (domain name string) by querying <server> (string).
;;; recurse? is an optional boolean for whether recursive queries are desired.
;;; verbose? is an optional boolean - if #t, return all RRs, not just answer.
;;; type=list is an optional list of query types (see dns:supported-types).
;;; default query type is A.
;;;
;;; (dns:resolve-ip4 <server> <ip> [recurse?] [verbose?] [zone] [type-list])
;;; resolves <ip> (ipv4 string) by querying <server> (string).
;;; recurse? is an optional boolean for whether recursive queries are desired.
;;; verbose? is an optional boolean - if #t, return all RRs, not just answer.
;;; zone is a label (see dns:name->label) to append to the reversed ip.
;;; type-list is an optional list of query types (see dns:supported-types).
;;; default query type is PTR.
;;; default zone is in-addr.arpa.
;;;
;;; (dns:resolve-ip6 <server> <ip> [recurse?] [verbose?] [zone] [type-list])
;;; resolves <ip> (ipv6 string) by querying <server> (string).
;;; recurse? is an optional boolean for whether recursive queries are desired.
;;; verbose? is an optional boolean - if #t, return all RRs, not just answer.
;;; zone is a label (see dns:name->label) to append to the reversed ip.
;;; type-list is an optional list of query types (see dns:supported-types).
;;; default query type is PTR.
;;; default zone is ip6.arpa.
;;;



(use syntax-case)  ; chicken define-syntax
(use srfi-1)       ; list library
(use srfi-6)       ; string ports
(use srfi-13)      ; string library
(use srfi-16)      ; case-lambda
(use srfi-23)      ; error reporting
(use sockets)      ; socket handling



(eval-when (compile)
    (declare
        ;(unit dns)
        (import "sockets")
        (uses library eval extras srfi-1 srfi-13)
        (bound-to-procedure dns:supported-types
                            dns:supported-types-verbose
                            dns:name->label
                            dns:resolve
                            dns:resolve-ip4
                            dns:resolve-ip6
                            dns:parse-a
                            dns:parse-label
                            dns:parse-soa
                            dns:parse-null
                            dns:parse-mx
                            dns:parse-txt
                            dns:parse-aaaa
                            num->bstr16
                            bstr16->num
                            num->bstr32
                            bstr32->num
                            bstr32->ipv4
                            bstr128->ipv6
                            dns:label->name
                            dns:ipv4->label
                            dns:ipv6->label
                            dns:send-udp
                            dns:send-tcp
                            dns:parse-response
                            dns:parse-data
                            dns:parse-qrr
                            dns:parse-rr
                            dns:create-header
                            dns:create-query
                            dns:handle-resolver
                            )
        (always-bound dns:parse-a
                      dns:parse-label
                      dns:parse-soa
                      dns:parse-null
                      dns:parse-mx
                      dns:parse-txt
                      dns:parse-aaaa
                      )
        (export dns:supported-types
                dns:supported-types-verbose
                dns:name->label
                dns:resolve
                dns:resolve-ip4
                dns:resolve-ip6)
        (run-time-macros)
        (inline)
        (fixnum-arithmetic)
        (no-bound-checks)
        (no-procedure-checks)
        (standard-bindings)
        (extended-bindings)
        (usual-integrations)))



;; constants

;; this is necessary so that dns-types will load correctly
(define-syntax wrap
    (syntax-rules ()
        ((_ f)
            (lambda (data offset rdata) (f data offset rdata)))))


;; dns-types
;; (type-symbol description type-num parser)
(define dns-types
    (list (list 'A      "ipv4 address"              1    (wrap dns:parse-a))
          (list 'NS     "name server"               2    (wrap dns:parse-label))
          (list 'CNAME  "canonical name for alias"  5    (wrap dns:parse-label))
          (list 'SOA    "start of authority"        6    (wrap dns:parse-soa))
          (list 'NULL   "null (anything)"           10   (wrap dns:parse-null))
          (list 'PTR    "domain name pointer"       12   (wrap dns:parse-label))
          (list 'MX     "mail exchanger"            15   (wrap dns:parse-mx))
          (list 'TXT    "text strings"              16   (wrap dns:parse-txt))
          (list 'AAAA   "ipv6 address"              28   (wrap dns:parse-aaaa))
          (list 'SPF    "SPF records"               99   (wrap dns:parse-txt))
          (list 'ANY    "all matching records"      255  #f)))

(define dns-qtypes
    (map
        (lambda (x)
            (cons (caddr x) (car x)))
        dns-types))


;; default strings
(define default-null    "\x00")
(define default-ipv4    "\x07in-addr\x04arpa\x00")
(define default-ipv6    "\x03ip6\x04arpa\x00")



;; utility functions

;; (dnserr func-name str ...)
;; throws an error, whose message is composed by appending str ...
(define-syntax dnserr
    (syntax-rules ()
        ((_ func str ...)
            (error 'func (conc str ...)))))


;; (dns:supported-types)
;; get the list of supported query types
(define (dns:supported-types)
    (map car dns-types))


;; (dns:supported-types-verbose)
;; get the list of supported query types with descriptions
(define (dns:supported-types-verbose)
    (map
        (lambda (x)
            (cons (car x) (cdar x)))
        dns-types))


;; (num->bstr16 n)
;; converts an integer to a 2 octet string
(define (num->bstr16 n)
    (string (integer->char (fxshr (fxand n (fxshl 255 8)) 8))
            (integer->char (fxand n 255))))


;; (bstr16->num str offset)
;; converts a 2 octet string (at offset) to an integer
(define (bstr16->num str offset)
    (+ (fxshl (char->integer (string-ref str offset)) 8)
       (char->integer (string-ref str (+ 1 offset)))))


;; (num->bstr32 n)
;; converts an integer to a 4 octet string
(define (num->bstr32 n)
    (string (integer->char (fxshr (fxand n (fxshl 255 24)) 24))
            (integer->char (fxshr (fxand n (fxshl 255 16)) 16))
            (integer->char (fxshr (fxand n (fxshl 255 8)) 8))
            (integer->char (fxand n 255))))


;; (bstr32->num str offset)
;; converts a 4 octet string (at offset) to an integer
(define (bstr32->num str offset)
    (+ (fxshl (char->integer (string-ref str offset)) 24)
       (fxshl (char->integer (string-ref str (+ 1 offset))) 16)
       (fxshl (char->integer (string-ref str (+ 2 offset))) 8)
       (char->integer (string-ref str (+ 3 offset)))))


;; (bstr32->ipv4 str)
;; converts a 4 octet string to an ipv4 address
(define (bstr32->ipv4 str)
    (string-append (number->string (char->integer (string-ref str 0))) "."
                   (number->string (char->integer (string-ref str 1))) "."
                   (number->string (char->integer (string-ref str 2))) "."
                   (number->string (char->integer (string-ref str 3)))))


;; (bstr128->ipv6 str)
;; converts a 16 octet string to an ipv6 address
(define (bstr128->ipv6 str)
    (string-join
        (map
            (lambda (x)
                (let ((n   (number->string (char->integer x) 16)))
                    (if (= 1 (string-length n))
                        (string-append "0" n)
                        n)))
            (string->list str))
        ":"))


;; (dns:name->label name)
;; encodes name as a dns label
(define (dns:name->label name)
    (let loop ((hnl   (map
                          (lambda (x)
                              (cons (integer->char (string-length x)) x))
                          (string-split name "." #t)))
               (zer   #f)
               (ret   '()))
        (cond ((null? hnl)
                  (apply conc (reverse (cons default-null ret))))
              (zer
                  (dnserr dns:name->label "consecutive dots in name - " name))
              ((eq? #\nul (caar hnl))
                  (loop (cdr hnl) #t ret))
              ((char<? (caar hnl) #\@)
                  (loop (cdr hnl) zer (cons (cdar hnl) (cons (caar hnl) ret))))
              (else
                  (dnserr dns:name->label "segment too long - " (cdar hnl))))))


;; (dns:label->name data offset)
;; returns a pair - (name . offset)
;; where name is the label translated into a name, 
;;       offset is the position after the label
;; (this handles compression properly)
(define (dns:label->name data offset)
    (let loop ((off   offset)
               (len   (char->integer (string-ref data offset)))
               (ret   ""))
        (cond ((> len 63)
                  (cons (string-append
                            ret
                            (car (dns:label->name
                                     data
                                     (fxand 16383 (bstr16->num data off)))))
                        (+ off 2)))
              ((= len 0)
                  (cons ret (+ 1 off)))
              (else
                  (let ((t   (+ 1 off len)))
                      (loop t
                            (char->integer (string-ref data t))
                            (string-append ret
                                           (substring data (+ 1 off) t)
                                           ".")))))))


;; (dns:ipv4->label addr zone)
;; creates an ipv4 reverse lookup label
(define (dns:ipv4->label addr zone)
    (let loop ((adl   (map
                          (lambda (x)
                              (cons (string-length x) x))
                          (string-split addr "." #t)))
               (len   0)
               (ret   '()))
        (cond ((null? adl)
                  (if (> len 4)
                      (dnserr dns:ipv4->label "too many octets - " addr)
                      (string-append (apply conc ret) zone)))
              ((<= 1 (caar adl) 3)
                  (loop (cdr adl) (+ 1 len) 
                        (cons (integer->char (caar adl))
                              (cons (cdar adl) ret))))
              (else
                  (dnserr dns:ipv4->label
                          "invalid ipv4 segment - " (cdar adl))))))


;; (dns:ipv6->label addr zone)
;; creates an ipv6 reverse lookup label
(define (dns:ipv6->label addr zone)
    (let loop ((adl   (map
                          (lambda (x)
                              (cons (string-length x) x))
                          (string-split addr ":" #t)))
               (len   0)
               (pre   "")
               (pce   #t)  ; #t for ret, #f for pre
               (ret   zone))
        (cond ((null? adl)
                  (if (> len 32)
                      (dnserr dns:ipv6->label "too many nibbles - " addr)
                      (string-append pre
                                     (string-join (map
                                                      (lambda (x)
                                                          "\x010")
                                                      (iota (- 32 len)))
                                                  "")
                                     ret)))
              ((= 0 (caar adl))
                  (if pce
                      (loop (cdr adl) len pre #f ret)
                      (dnserr dns:ipv6->label "too many :: - " addr)))
              ((= 1 (caar adl))
                  (if pce
                      (loop (cdr adl) (+ 2 len) pre pce
                            (conc "\x01" (cdar adl) "\x010" ret))
                      (loop (cdr adl) (+ 2 len)
                            (conc "\x01" (cdar adl) "\x010" pre) pce ret)))
              (else 
                  (let ((l   (string-join
                                 (map
                                     (lambda (x)
                                         (string-append "\x01" (string x)))
                                     (reverse (string->list (cdar adl))))
                                 "")))
                      (if pce
                          (loop (cdr adl) (+ (caar adl) len) pre pce
                                (string-append l ret))
                          (loop (cdr adl) (+ (caar adl) len)
                                (string-append l pre) pce ret)))))))



;; socket functions

;; (dns:send-udp server query verbose?)
;; sends the query via udp
(define (dns:send-udp server query verbose?)
    (let ((sock   (socket-open* 'udp)))
        (socket-connect! sock server 53)
        (socket-send sock query)
        (if (= 0 (socket-select sock 1))
            (begin
                (socket-close sock)
                (dns:send-udp server query verbose?))
            (receive (len data)
                     (socket-recv sock 32768)
                     (socket-close sock)
                     (dns:parse-response server query data verbose?)))))


;; (dns:send-tcp server query verbose?)
;; sends the query via tcp
(define (dns:send-tcp server query verbose?)
    (let ((sock   (socket-open 'tcp)))
        (socket-connect! sock server 53)
        (socket-send sock (num->bstr16 (string-length query)))
        (socket-send sock query)
        (receive (len1 plen)
                 (socket-recv sock 2)
                 (receive (len2 data)
                          (socket-recv sock (bstr16->num plen 0))
                          (socket-close sock)
                          (dns:parse-response server query data verbose?)))))



;; query creation functions


;; (dns:create-header recurse?)
;; creates a new header for a dns query
(define (dns:create-header recurse?)
    (string-append (num->bstr16 (random 65536))
                   (if recurse? "\x01" "\x00")
                   "\x00\x00\x01\x00\x00\x00\x00\x00\x00"))


;; (dns:create-query name type recurse?)
;; creates a new query packet
(define (dns:create-query name type recurse?)
    (let ((qtype   (assoc type dns-types)))
        (if qtype
            (string-append (dns:create-header recurse?)
                           name
                           (num->bstr16 (caddr qtype))
                           "\x00\x01")
            (dnserr dns:create-query "invalid query type - " type))))



;; response parser functions

;; (dns:parse-response server query data verbose?)
;; parses the response header and dispatch
(define (dns:parse-response server query data verbose?)
    (if (= 2 (fxand 2 (char->integer (string-ref data 2)))) ; truncated
        (dns:send-tcp server query verbose?)
        (let ((rcode   (fxand 15 (char->integer (string-ref data 3))))
              (qd      (bstr16->num data 4))
              (an      (bstr16->num data 6))
              (ns      (bstr16->num data 8))
              (ar      (bstr16->num data 10)))
            (case rcode
                  ((0)     (dns:parse-data qd an ns ar data verbose?))
                  ((1)     (list (cons 'ERR "FORMERR")))
                  ((2)     (list (cons 'ERR "SERVFAIL")))
                  ((3)     (list (cons 'ERR "NXDOMAIN")))
                  ((4)     (list (cons 'ERR "NOTIMPL")))
                  ((5)     (list (cons 'ERR "REFUSED")))
                  ((6)     (list (cons 'ERR "YXDOMAIN")))
                  ((7)     (list (cons 'ERR "YXRRSET")))
                  ((8)     (list (cons 'ERR "NXRRSET")))
                  ((9)     (list (cons 'ERR "NOTAUTH")))
                  ((10)    (list (cons 'ERR "NOTZONE")))
                  (else    (list (cons 'ERR "UNKNOWN")))))))


;; (dns:parse-data qdcnt ancnt nscnt arcnt data verbose?)
;; parse the response data into RRs and dispatch
(define (dns:parse-data qdcnt ancnt nscnt arcnt data verbose?)
    (let ((qdr   (dns:parse-qrr data qdcnt)))
        (if verbose?
            (let loop1 ((off   (cdr qdr))
                        (n     ancnt)
                        (qdr   (car qdr))
                        (anr   '()))
                (if (= 0 n)
                    (let loop2 ((off   off)
                                (n     nscnt)
                                (nsr   '()))
                        (if (= 0 n)
                            (let loop3 ((off   off)
                                        (n     arcnt)
                                        (arr   '()))
                                (if (= 0 n)
                                    (list (cons 'QUESTION (reverse qdr))
                                          (cons 'ANSWER (reverse anr))
                                          (cons 'AUTHORITY (reverse nsr))
                                          (cons 'ADDITIONAL (reverse arr)))
                                    (let ((a   (dns:parse-rr data off)))
                                        (loop3 (cdr a) (- n 1)
                                               (cons (car a) arr)))))
                            (let ((a   (dns:parse-rr data off)))
                                (loop2 (cdr a) (- n 1) (cons (car a) nsr)))))
                    (let ((a   (dns:parse-rr data off)))
                        (loop1 (cdr a) (- n 1) qdr (cons (car a) anr)))))
            (let loop ((off   (cdr qdr))
                       (n     ancnt)
                       (ret   '()))
                (if (= 0 n)
                    (reverse ret)
                    (let ((a   (dns:parse-rr data off)))
                        (loop (cdr a) (- n 1) (cons (car a) ret))))))))


;; (dns:parse-qrr data qdcnt)
;; parses the question section of a response
(define (dns:parse-qrr data qdcnt)
    (let loop ((off   12)
               (n     qdcnt)
               (ret   '()))
        (if (= 0 n)
            (cons ret off)
            (let ((l   (dns:label->name data off)))
                (loop (+ 4 (cdr l)) (- n 1)
                      (cons (list (car l)
                                   (cdr (assoc (bstr16->num data (cdr l))
                                               dns-qtypes))) ret))))))


;; (dns:parse-rr data offset)
;; parses the answer/authority/additional sections of a response
(define (dns:parse-rr data offset)
    (let* ((name    (dns:label->name data offset))
           (type    (bstr16->num data (cdr name)))
           (class   (bstr16->num data (+ 2 (cdr name))))
           (ttl     (bstr16->num data (+ 4 (cdr name))))
           (len     (bstr16->num data (+ 8 (cdr name))))
           (rdata   (substring data (+ 10 (cdr name)) (+ 10 len (cdr name))))
           (off     (+ 10 len (cdr name)))
           (typen   (assoc type dns-qtypes)))
        (if typen
            (cons (list (car name)
                        (cdr typen)
                        ((cadddr (assoc (cdr typen) dns-types))
                            data (+ 10 (cdr name)) rdata))
                  off)
            (cons (list (car name) type rdata) off))))


;; (dns:parse-a data offset rdata)
;; parses RRs returning ipv4 addresses
(define (dns:parse-a data offset rdata)
    (bstr32->ipv4 rdata))


;; (dns:parse-label data offset rdata)
;; parses RRs returning labels (domain names, etc)
(define (dns:parse-label data offset rdata)
    (car (dns:label->name data offset)))


;; (dns:parse-txt data offset rdata)
;; parses RRs returning character strings
(define (dns:parse-txt data offset rdata)
    (let loop ((off   0)
               (len   (string-length rdata))
               (ret   '()))
        (if (>= off len)
            (reverse ret)
            (let ((l   (char->integer (string-ref data off))))
                (loop (+ 1 len off) len
                      (cons (substring data (+ 1 off) (+ off len)) ret))))))


;; (dns:parse-aaaa data offset rdata)
;; parses RRs returning ipv6 addresses
(define (dns:parse-aaaa data offset rdata)
    (bstr128->ipv6 rdata))


;; (dns:parse-null data offset rdata)
;; parses NULL RRs
(define (dns:parse-null data offset rdata)
    rdata)


;; (dns:parse-mx data offset rdata)
;; parses MX RRs
(define (dns:parse-mx data offset rdata)
    (cons (bstr16->num rdata 0)
          (car (dns:label->name data (+ 2 offset)))))


;; (dns:parse-soa data offset rdata)
;; parses SOA RRs
(define (dns:parse-soa data offset rdata)
    (let* ((mn   (dns:label->name data offset))
           (rn   (dns:label->name data (cdr mn))))
        (list (car mn)
              (car rn)
              (bstr32->num data (cdr rn))
              (bstr32->num data (+ 4 (cdr rn)))
              (bstr32->num data (+ 8 (cdr rn)))
              (bstr32->num data (+ 12 (cdr rn)))
              (bstr32->num data (+ 16 (cdr rn))))))



;; resolver functions

;; (dns:resolve server domain #!optional recurse? verbose? type-list)
;; resolves a name
(define dns:resolve
    (case-lambda
        ((server domain)
            (dns:resolve server domain #f #f '(A)))
        ((server domain recurse?)
            (dns:resolve server domain recurse? #f '(A)))
        ((server domain recurse? verbose?)
            (dns:resolve server domain recurse? verbose? '(A)))
        ((server domain recurse? verbose? typelist)
            (dns:handle-resolver server
                                 (dns:name->label domain)
                                 recurse? verbose? typelist))
        (args
            (dnserr dns:resolve "invalid args list - " args))))


;; (dns:resolve-ip4 server ip #!optional recurse? verbose? zone type-list)
;; resolves an ipv4 address
(define dns:resolve-ip4
    (case-lambda
        ((server ip)
            (dns:resolve-ip4 server ip #f #f default-ipv4 '(PTR)))
        ((server ip recurse?)
            (dns:resolve-ip4 server ip recurse? #f default-ipv4 '(PTR)))
        ((server ip recurse? verbose?)
            (dns:resolve-ip4 server ip recurse? verbose? default-ipv4 '(PTR)))
        ((server ip recurse? verbose? zone)
            (dns:resolve-ip4 server ip recurse? verbose? zone '(PTR)))
        ((server ip recurse? verbose? zone typelist)
            (dns:handle-resolver server
                                 (dns:ipv4->label ip zone)
                                 recurse? verbose? typelist))
        (args
            (dnserr dns:resolve-ip4 "invalid args list - " args))))


;; (dns:resolve-ip6 server ip #!optional recurse? verbose? zone type-list)
;; resolves an ipv6 address
(define dns:resolve-ip6
    (case-lambda
        ((server ip)
            (dns:resolve-ip6 server ip #f #f default-ipv6 '(PTR)))
        ((server ip recurse?)
            (dns:resolve-ip6 server ip recurse? #f default-ipv6 '(PTR)))
        ((server ip recurse? verbose?)
            (dns:resolve-ip6 server ip recurse? verbose? default-ipv6 '(PTR)))
        ((server ip recurse? verbose? zone)
            (dns:resolve-ip6 server ip recurse? verbose? zone '(PTR)))
        ((server ip recurse? verbose? zone typelist)
            (dns:handle-resolver server
                                 (dns:ipv6->label ip zone)
                                 recurse? verbose? typelist))
        (args
            (dnserr dns:resolve-ip6 "invalid args list - " args))))


;; (dns:handle-resolver server qlabel recurse? verbose? typelist)
;; creates and sends the queries
(define (dns:handle-resolver server qlabel recurse? verbose? typelist)
    (let ((ret   (map
                     (lambda (x)
                         (let ((q   (dns:create-query qlabel x recurse?)))
                             (if (< (string-length q) 512)
                                 (dns:send-udp server q verbose?)
                                 (dns:send-tcp server q verbose?))))
                     typelist)))
        (if verbose?
            (let loop ((l    ret)
                       (er   '())
                       (qd   '())
                       (an   '())
                       (ns   '())
                       (ar   '()))
               (cond ((null? l)
                         (if (null? er)
                             (list (delete-duplicates qd equal?)
                                   (delete-duplicates an equal?)
                                   (delete-duplicates ns equal?)
                                   (delete-duplicates ar equal?))
                             (list (cons 'ERROR er)
                                   (delete-duplicates qd equal?)
                                   (delete-duplicates an equal?)
                                   (delete-duplicates ns equal?)
                                   (delete-duplicates ar equal?))))
                     ((= 1 (length (car l)))
                         (loop (cdr l) (append er (car l)) qd an ns ar))
                     (else
                         (loop (cdr l)
                               er
                               (append qd (list-ref (car l) 0))
                               (append an (list-ref (car l) 1))
                               (append ns (list-ref (car l) 2))
                               (append ar (list-ref (car l) 3))))))
            (apply append ret))))