changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/net/proto/dns.lisp

changeset 698: 96958d3eb5b0
parent: a2fe095379f9
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; lib/net/proto/dns.lisp --- Domain Name Services
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :net/proto/dns)
     7 
     8 (define-condition dns-error (dns-condition protocol-error) ())
     9 
    10 (define-condition dns-servers-exhausted (dns-error)
    11   ()
    12   (:report (lambda (c s) (declare (ignore c)) (format s "All DNS servers failed to provide an answer for the query."))))
    13 
    14 (defconstant +dns-port+ 53)
    15 (defconstant +dns-buffer-length+ 4096)
    16 
    17 (defvar *cloudflare-servers*
    18   '("1.1.1.1" "1.0.0.1"))
    19 (defvar *dnswatch-servers*
    20   '("84.200.69.80" "84.200.70.40"))
    21 (defvar *google-servers*
    22   '("8.8.8.8" "8.8.4.4"))
    23 (defvar *opendns-servers*
    24   '("208.67.222.123" "208.67.220.123"))
    25 (defvar *quad9-servers*
    26   '("9.9.9.9" "149.112.112.112"))
    27 
    28 (defvar *dns-servers*
    29   (cons "127.0.0.1"
    30         (append *dnswatch-servers* *quad9-servers*
    31                 *cloudflare-servers* *opendns-servers*
    32                 *google-servers*)))
    33 
    34 (defun try-server (server send send-length recv recv-length &key (attempts 1) (timeout 1))
    35   (handler-case
    36       (let ((socket (sb-bsd-sockets:socket-connect
    37                      (make-instance 'inet-socket
    38                        :type :datagram :protocol :udp)
    39                      (make-inet-address server) +dns-port+)))
    40         (unwind-protect
    41              (loop repeat attempts
    42                    do (sb-bsd-sockets:socket-send socket send send-length)
    43                       (sb-ext:with-timeout timeout
    44                         (let ((received (nth-value 1 (socket-receive socket recv recv-length))))
    45                           (when (and received (< 0 received))
    46                             (return received)))))
    47           (socket-close socket)))
    48     (socket-error (e)
    49       (values nil e))))
    50 
    51 (defmacro with-query-buffer ((send pos hostname type &rest header-args) &body body)
    52   `(let* ((,send (make-array 512 :element-type '(unsigned-byte 8) :initial-element 0))
    53           (,pos (encode-header ,send 0 :id 42 :recursion-desired T :question-count 1 ,@header-args))
    54           (,pos (encode-query ,send ,pos ,hostname :type ,type :class 1)))
    55      (declare (dynamic-extent ,send))
    56      ,@body))
    57 
    58 (defun dns-query (hostname &key (type T) (dns-servers *dns-servers*) (attempts 1) (timeout 1))
    59   (with-simple-restart (abort "Abort the DNS query.")
    60     (let ((recv (make-array +dns-buffer-length+ :element-type '(unsigned-byte 8) :initial-element 0)))
    61       (declare (dynamic-extent recv))
    62       (with-query-buffer (send send-length hostname type)
    63         (loop for server in dns-servers
    64               for recv-length = (try-server server send send-length recv +dns-buffer-length+ :attempts attempts :timeout timeout)
    65               do (when recv-length
    66                    (with-simple-restart (continue "Skip this DNS server.")
    67                      (return (decode-response server recv 0 recv-length))))
    68               finally (with-simple-restart (continue "Return NIL instead.")
    69                         (error 'dns-servers-exhausted)))))))
    70 
    71 (defun query-data (hostname &rest args &key type dns-servers attempts timeout)
    72   (declare (ignore dns-servers attempts timeout))
    73   (loop for record in (getf (apply #'dns-query hostname args) :answers)
    74         when (eql type (getf record :type))
    75         collect (getf record :data)))
    76 
    77 (defun resolve (hostname &rest args &key type dns-servers attempts timeout)
    78   (declare (ignore dns-servers attempts timeout))
    79   (handler-case
    80       (handler-bind ((dns-server-failure #'continue))
    81         (let ((list (if type
    82                         (apply #'query-data hostname args)
    83                         (append (apply #'query-data hostname :type :A args)
    84                                 (apply #'query-data hostname :type :AAAA args)))))
    85           (values (first list) list T)))
    86     (dns-servers-exhausted ()
    87       (values NIL NIL NIL))))
    88 
    89 (defun hostname (ip &rest args &key type dns-servers attempts timeout)
    90   (declare (ignore type dns-servers attempts timeout))
    91   (handler-case
    92       (handler-bind ((dns-server-failure #'continue))
    93         (let* ((ipv6-p (find #\: ip))
    94                (parts (if ipv6-p
    95                           (loop for byte across (usocket:ipv6-host-to-vector ip)
    96                                 collect (format NIL "~x" (ldb (byte 4 4) byte))
    97                                 collect (format NIL "~x" (ldb (byte 4 0) byte)))
    98                           (ssplit #\. ip)))
    99                (list (apply #'query-data (format NIL "~{~a.~}~:[in-addr~;ip6~].arpa" (nreverse parts) ipv6-p) :type :PTR args)))
   100           (values (first list) list T)))
   101     (dns-condition ()
   102       (values NIL NIL NIL))))