changelog shortlog graph tags branches changeset files revisions annotate raw help

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

changeset 698: 96958d3eb5b0
parent: bcf772e86fbc
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; lib/net/codec/dns.lisp --- DNS Record utils
     2 
     3 ;; from: https://github.com/Shinmera/dns-client
     4 
     5 ;;; Code:
     6 (in-package :net/codec/dns)
     7 
     8 ;;; Record Types
     9 
    10 (define-condition dns-condition ()
    11   ())
    12 
    13 (define-condition dns-server-failure (error dns-condition)
    14   ((dns-server :initarg :dns-server :reader dns-server)
    15    (response-code :initarg :response-code :reader response-code))
    16   (:report (lambda (c s) (format s "DNS server ~%  ~a~%responded with failure code ~d~@[~%  ~a~]"
    17                                  (dns-server c) (response-code c) (response-code-name (response-code c))))))
    18 
    19 (defun response-code-name (code)
    20   (case code
    21     (0 :success)
    22     (1 :format-error)
    23     (2 :server-failure)
    24     (3 :no-such-domain)
    25     (4 :not-implemented)
    26     (5 :query-refused)
    27     (6 :name-should-not-exist)
    28     (7 :set-should-not-exist)
    29     (8 :set-does-not-exist)
    30     (9 :not-authorized)
    31     (10 :not-in-zone)
    32     (11 :type-not-implemented)
    33     (16 :bad-version)
    34     (17 :key-not-recognised)
    35     (18 :bad-time)
    36     (19 :bad-mode)
    37     (20 :duplicate-key)
    38     (21 :bad-algorithm)
    39     (22 :bad-truncation)
    40     (23 :bad-cookie)))
    41 
    42 (defmacro with-dns-error-handling (&body body)
    43   `(handler-bind ((dns-server-failure
    44                     (lambda (e)
    45                       (unless (find (response-code e) '(1 3 6 7 8))
    46                         (continue e)))))
    47      ,@body))
    48 
    49 ;;; Note: we assume that we never cross byte boundaries when accessing bits.
    50 (defmacro with-decoding ((octets start &optional (pos (gensym "POS"))) &body body)
    51   `(let ((,pos ,start))
    52      (flet ((int1 ()
    53               (prog1 (logbitp (* 8 (rem ,pos 1)) (aref ,octets (floor ,pos)))
    54                 (incf ,pos 1/8)))
    55             (int4 ()
    56               (prog1 (ldb (byte 4 (* 8 (rem ,pos 1))) (aref ,octets (floor ,pos)))
    57                 (incf ,pos 4/8)))
    58             (int8 ()
    59               (prog1 (aref ,octets (floor ,pos))
    60                 (incf ,pos 1)))
    61             (int16 () ;; big-endian
    62               (prog1 (+ (ash (aref ,octets (+ 0 (floor ,pos))) 8)
    63                         (ash (aref ,octets (+ 1 (floor ,pos))) 0))
    64                 (incf ,pos 2)))
    65             (int32 ()
    66               (prog1 (+ (ash (aref ,octets (+ 0 (floor ,pos))) 24)
    67                         (ash (aref ,octets (+ 1 (floor ,pos))) 16)
    68                         (ash (aref ,octets (+ 2 (floor ,pos))) 8)
    69                         (ash (aref ,octets (+ 3 (floor ,pos))) 0))
    70                 (incf ,pos 4))))
    71        (declare (ignorable #'int1 #'int4 #'int8 #'int16 #'int32))
    72        ,@body)))
    73 
    74 (defmacro with-encoding ((octets start &optional (pos (gensym "POS"))) &body body)
    75   `(let ((,pos ,start))
    76      (flet ((int1 (value)
    77               (let ((octet (aref ,octets (floor ,pos))))
    78                 (setf (ldb (byte 1 (* 8 (rem ,pos 1))) octet)
    79                       (ecase value
    80                         ((0 1) value)
    81                         ((T) 1)
    82                         ((NIL) 0)))
    83                 (setf (aref ,octets (floor ,pos)) octet)
    84                 (incf ,pos 1/8)))
    85             (int4 (value)
    86               (let ((octet (aref ,octets (floor ,pos))))
    87                 (setf (ldb (byte 4 (* 8 (rem ,pos 1))) octet) value)
    88                 (setf (aref ,octets (floor ,pos)) octet)
    89                 (incf ,pos 4/8)))
    90             (int8 (value)
    91               (setf (aref ,octets (floor ,pos)) value)
    92               (incf ,pos 1))
    93             (int16 (value) ;; big-endian
    94               (setf (aref ,octets (+ 0 ,pos)) (ldb (byte 8 8) value))
    95               (setf (aref ,octets (+ 1 ,pos)) (ldb (byte 8 0) value))
    96               (incf ,pos 2))
    97             (int32 (value) ;; big-endian
    98               (setf (aref ,octets (+ 0 ,pos)) (ldb (byte 8 24) value))
    99               (setf (aref ,octets (+ 1 ,pos)) (ldb (byte 8 16) value))
   100               (setf (aref ,octets (+ 2 ,pos)) (ldb (byte 8 8) value))
   101               (setf (aref ,octets (+ 3 ,pos)) (ldb (byte 8 0) value))
   102               (incf ,pos 4)))
   103        (declare (ignorable #'int1 #'int4 #'int8 #'int16 #'int32))
   104        ,@body)))
   105 
   106 (defmacro maybe-set ((octets offset) &body calls)
   107   `(with-encoding (,octets ,offset pos)
   108      ,@(loop for (func value) in calls
   109              collect `(if ,value
   110                           (,func ,value)
   111                           (incf pos ,(ecase func
   112                                        (int1 1/8)
   113                                        (int4 4/8)
   114                                        (int8 1)
   115                                        (int16 2)
   116                                        (int32 4)))))
   117      pos))
   118 
   119 (defparameter *record-type-table*
   120   '((:A 1)
   121     (:AAAA 28)
   122     (:AFSDB 18)
   123     (:APL 42)
   124     (:CAA 257)
   125     (:CDNSKEY 60)
   126     (:CDS 59)
   127     (:CERT 37)
   128     (:CNAME 5)
   129     (:CSYNC 62)
   130     (:DHCID 49)
   131     (:DLV 32769)
   132     (:DNAME 39)
   133     (:DNSKEY 48)
   134     (:DS 43)
   135     (:HINFO 13)
   136     (:HIP 55)
   137     (:IPSECKEY 45)
   138     (:KEY 25)
   139     (:KX 36)
   140     (:LOC 29)
   141     (:MX 15)
   142     (:NAPTR 35)
   143     (:NS 2)
   144     (:NSEC 47)
   145     (:NSEC3 50)
   146     (:NSEC3PARAM 51)
   147     (:OPENPGPKEY 61)
   148     (:PTR 12)
   149     (:RRSIG 46)
   150     (:RP 17)
   151     (:SIG 24)
   152     (:SMIMEA 53)
   153     (:SOA 6)
   154     (:SRV 33)
   155     (:SSHFP 44)
   156     (:TA 32768)
   157     (:TKEY 249)
   158     (:TLSA 52)
   159     (:TSIG 250)
   160     (:TXT 16)
   161     (:URI 256)
   162     (:ZONEMD 63)
   163     ;; Pseudo records
   164     (T 255)
   165     (* 255)
   166     (:* 255)
   167     (:AXFR 252)
   168     (:IXFR 251)
   169     (:OPT 41)
   170     ;; Obsolete
   171     (:MD 3)
   172     (:MF 4)
   173     (:MAILA 254)
   174     (:MB 7)
   175     (:MG 8)
   176     (:MR 9)
   177     (:MINFO 14)
   178     (:MAILB 253)
   179     (:WKS 11)
   180     (:NB 32)
   181     (:NBSTAT 33)
   182     (:NULL 10)
   183     (:A6 38)
   184     (:NXT 30)
   185     (:KEY 25)
   186     (:SIG 24)
   187     (:HINFO 13)
   188     (:RP 17)
   189     (:X25 19)
   190     (:ISDN 20)
   191     (:RT 21)
   192     (:NSAP 22)
   193     (:NSAP-PTR 23)
   194     (:PX 26)
   195     (:EID 31)
   196     (:NIMLOC 32)
   197     (:ATMA 34)
   198     (:APL 42)
   199     (:SINK 40)
   200     (:GPOS 27)
   201     (:UINFO 100)
   202     (:UID 101)
   203     (:GID 102)
   204     (:UNSPEC 103)
   205     (:SPF 99)
   206     (:NINFO 56)
   207     (:RKEY 57)
   208     (:TALINK 58)
   209     (:NID 104)
   210     (:L32 105)
   211     (:L64 106)
   212     (:LP 107)
   213     (:EUI48 108)
   214     (:EUI64 109)
   215     (:DOA 259)))
   216 
   217 (defun record-type-id (record-type &optional (error T))
   218   (or (second (find record-type *record-type-table* :key #'first :test #'string-equal))
   219       (when error "No such record type ~s" record-type)))
   220 
   221 (defun id-record-type (id)
   222   (or (first (find id *record-type-table* :key #'second :test #'=))
   223       id))
   224 
   225 (defun encode-host (name octets offset)
   226   (let ((start 0)
   227         (name (encode-domain name)))
   228     (flet ((finish (end)
   229              (setf (aref octets (+ offset start)) (- end start))
   230              (loop for i from (1+ start) to end
   231                    do (setf (aref octets (+ offset i)) (char-code (char-downcase (char name (1- i))))))
   232              (setf start (1+ end))))
   233       (loop for i from 0 below (length name)
   234             do (when (char= #\. (char name i))
   235                  (finish i))
   236             finally (finish (length name)))
   237       (setf (aref octets (+ offset start)) 0)
   238       (+ offset start 1))))
   239 
   240 (defun decode-host* (string)
   241   (loop with i = 0
   242         while (< i (length string))
   243         do (let ((jump (char-code (char string i))))
   244              (setf (char string i) #\.)
   245              (incf i (1+ jump))))
   246   (decode-domain
   247    (if (string/= "" string)
   248        (subseq string 1)
   249        string)))
   250 
   251 (defun decode-host (octets offset start)
   252   (loop with i = offset
   253         with pos = offset
   254         with jumped = NIL
   255         with stream = (make-string-output-stream)
   256         until (= 0 (aref octets i))
   257         ;; Handle label compression jump
   258         do (cond ((<= 192 (aref octets i))
   259                   (setf i (+ start
   260                              (- (+ (* 256 (aref octets i)) (aref octets (1+ i)))
   261                                 #b1100000000000001)))
   262                   (setf jumped T)
   263                   (incf pos 1))
   264                  (T
   265                   (write-char (code-char (aref octets i)) stream)))
   266            (incf i)
   267            (unless jumped
   268              (incf pos))
   269         finally (return (values (decode-host* (get-output-stream-string stream)) (1+ pos)))))
   270 
   271 (defun decode-header (octets offset)
   272   (with-decoding (octets offset pos)
   273     (values (list :id (int16)
   274                   :recursion-desired (int1)
   275                   :truncated-message (int1)
   276                   :authorative-answer (int1)
   277                   :operation (int4)
   278                   :reply-p (int1)
   279                   :response-code (int4)
   280                   :checking-disabled (int1)
   281                   :authenticated-data (int1)
   282                   :z-reserved (int1)
   283                   :recursion-available (int1)
   284                   :question-count (int16)
   285                   :answer-count (int16)
   286                   :authority-count (int16)
   287                   :additional-count (int16))
   288             pos)))
   289 
   290 (defun encode-header (octets offset &key id recursion-desired truncated-message authorative-answer operation reply-p response-code checking-disabled authenticated-data z-reserved recursion-available question-count answer-count authority-count additional-count)
   291   (maybe-set (octets offset)
   292     (int16 id)
   293     (int1 recursion-desired)
   294     (int1 truncated-message)
   295     (int1 authorative-answer)
   296     (int4 operation)
   297     (int1 reply-p)
   298     (int4 response-code)
   299     (int1 checking-disabled)
   300     (int1 authenticated-data)
   301     (int1 z-reserved)
   302     (int1 recursion-available)
   303     (int16 question-count)
   304     (int16 answer-count)
   305     (int16 authority-count)
   306     (int16 additional-count)))
   307 
   308 (defun encode-query (octets offset hostname &key type class)
   309   (let ((type (etypecase type
   310                 ((or string symbol) (record-type-id type))
   311                 ((unsigned-byte 16) type))))
   312     (setf offset (encode-host hostname octets offset))
   313     (maybe-set (octets offset)
   314       (int16 type)
   315       (int16 class))))
   316 
   317 (defun decode-query (octets offset)
   318   (with-decoding (octets offset pos)
   319     (values (list :type (id-record-type (int16))
   320                   :class (int16))
   321             pos)))
   322 
   323 (defun decode-data (octets offset)
   324   (with-decoding (octets offset pos)
   325     (values (list :type (id-record-type (int16))
   326                   :class (int16)
   327                   :ttl (int32)
   328                   :length (int16))
   329             pos)))
   330 
   331 (defgeneric decode-record-payload (type octets start end))
   332 
   333 (defmethod decode-record-payload (type octets start end)
   334   (subseq octets start end))
   335 
   336 (defmethod decode-record-payload ((type (eql :A)) octets start end)
   337   (format NIL "~d.~d.~d.~d"
   338           (aref octets (+ 0 start))
   339           (aref octets (+ 1 start))
   340           (aref octets (+ 2 start))
   341           (aref octets (+ 3 start))))
   342 
   343 (defmethod decode-record-payload ((type (eql :AAAA)) octets start end)
   344   (usocket:vector-to-ipv6-host octets))
   345 
   346 (defmethod decode-record-payload ((type (eql :TXT)) octets start end)
   347   (decode-host octets start 0))
   348 
   349 (defmethod decode-record-payload ((type (eql :URI)) octets start end)
   350   (decode-host octets start 0))
   351 
   352 (defmethod decode-record-payload ((type (eql :CNAME)) octets start end)
   353   (decode-host octets start 0))
   354 
   355 (defmethod decode-record-payload ((type (eql :PTR)) octets start end)
   356   (decode-host octets start 0))
   357 
   358 ;; TODO: decode more.
   359 
   360 (defmethod decode-record-payload ((type (eql :MX)) octets start end)
   361   (with-decoding (octets start pos)
   362     (list :priority (int16)
   363           :name (decode-host octets pos 0))))
   364 
   365 (defmethod decode-record-payload ((type (eql :SOA)) octets start end)
   366   (multiple-value-bind (mname pos) (decode-host octets start 0)
   367     (multiple-value-bind (rname pos) (decode-host octets pos 0)
   368       (with-decoding (octets pos)
   369         (list :mname mname
   370               :rname rname
   371               :serial (int32)
   372               :refresh (int32)
   373               :retry (int32)
   374               :expire (int32)
   375               :minimum (int32))))))
   376 
   377 (defun decode-record (octets offset)
   378   (multiple-value-bind (data pos) (decode-data octets offset)
   379     (setf (getf data :data) (decode-record-payload (getf data :type) octets pos (+ pos (getf data :length))))
   380     (values data (+ pos (getf data :length)))))
   381 
   382 (defun decode-response (server octets offset limit)
   383   (declare (ignorable limit))
   384   ;; FIXME: Implement buffer limiting.
   385   (multiple-value-bind (header pos) (decode-header octets offset)
   386     (when (< 0 (getf header :response-code))
   387       (error 'dns-server-failure :dns-server server :response-code (getf header :response-code)))
   388     (let ((record-offset pos))
   389       (flet ((decode (fun)
   390                (multiple-value-bind (name pos) (decode-host octets record-offset offset)
   391                  (multiple-value-bind (query pos) (funcall fun octets pos)
   392                    (setf record-offset pos)
   393                    (setf (getf query :name) name)
   394                    query))))
   395         (list* :questions
   396                (loop repeat (getf header :question-count)
   397                      collect (decode #'decode-query))
   398                :answers
   399                (loop repeat (getf header :answer-count)
   400                      collect (decode #'decode-record))
   401                :authorities
   402                (loop repeat (getf header :authority-count)
   403                      collect (decode #'decode-record))
   404                :additional
   405                (loop repeat (getf header :additional-count)
   406                      collect (decode #'decode-record))
   407                header)))))