| 1 | ;;;; DNS implementation for COMMON-NET |
| 2 | |
| 3 | (in-package :common-net) |
| 4 | |
| 5 | (defstruct dns-packet |
| 6 | (txid (random 65536) :type (unsigned-byte 16)) |
| 7 | (is-response nil) |
| 8 | (opcode :query :type (member :query :iquery :status)) |
| 9 | (authoritative nil) |
| 10 | (truncated nil) |
| 11 | (recurse nil) |
| 12 | (will-recurse nil) |
| 13 | (resp-code :success :type (member :success :format-error :server-failure :name-error :not-implemented :refused)) |
| 14 | (queries '() :type list) |
| 15 | (answers '() :type list) |
| 16 | (authority '() :type list) |
| 17 | (additional '() :type list)) |
| 18 | |
| 19 | (defclass resource-query () |
| 20 | ((name :initarg :name) |
| 21 | (type :initarg :type))) |
| 22 | |
| 23 | (defclass resource-record () |
| 24 | ((name :initarg :name) |
| 25 | (ttl :initarg :ttl))) |
| 26 | |
| 27 | (defvar *rr-coding-types* '()) |
| 28 | |
| 29 | (defmacro define-rr-type (name class type slots) |
| 30 | (let ((format (mapcar #'(lambda (slot) |
| 31 | (list* (if (listp (car slot)) |
| 32 | (caar slot) |
| 33 | (car slot)) |
| 34 | (cdr slot))) |
| 35 | slots)) |
| 36 | (slot-desc (mapcar #'car slots))) |
| 37 | `(progn |
| 38 | (defclass ,name (resource-record) ,slot-desc) |
| 39 | (setf *rr-coding-types* (cons '(,name (,class ,type) ,format) |
| 40 | (remove ',name *rr-coding-types* :key #'car)))))) |
| 41 | |
| 42 | (define-rr-type a-record #x1 #x1 |
| 43 | ((address ipv4-address))) |
| 44 | (define-rr-type ns-record #x1 #x2 |
| 45 | ((ns-name domain-name))) |
| 46 | (define-rr-type cname-record #x1 #x5 |
| 47 | ((cname domain-name))) |
| 48 | (define-rr-type soa-record #x1 #x6 |
| 49 | ((mname domain-name) |
| 50 | (rname domain-name) |
| 51 | (serial uint-32) |
| 52 | (refresh uint-32) |
| 53 | (retry uint-32) |
| 54 | (expire uint-32))) |
| 55 | (define-rr-type ptr-record #x1 #xc |
| 56 | ((pointed domain-name))) |
| 57 | (define-rr-type mx-record #x1 #xf |
| 58 | ((prio uint-16) |
| 59 | (mail-host domain-name))) |
| 60 | (define-rr-type txt-record #x1 #x10 |
| 61 | ((text text))) |
| 62 | (define-rr-type aaaa-record #x1 #x1c |
| 63 | ((address ipv6-address))) |
| 64 | (define-rr-type srv-record #x1 #x21 |
| 65 | ((prio uint-16) |
| 66 | (weigth uint-16) |
| 67 | (port uint-16) |
| 68 | (host-name domain-name))) |
| 69 | |
| 70 | ;;; Packet decoding logic |
| 71 | |
| 72 | (defstruct dns-decode-state |
| 73 | (packet nil :type (array (unsigned-byte 8))) |
| 74 | (pos 0 :type (mod 65536)) |
| 75 | (prev-names '() :type list)) |
| 76 | |
| 77 | (define-condition dns-error (error) ()) |
| 78 | (define-condition dns-decode-error (dns-error) |
| 79 | ((packet :initarg :packet))) |
| 80 | (define-condition simple-dns-decode-error (dns-decode-error simple-error) ()) |
| 81 | |
| 82 | (defun simple-dns-decode-error (packet format &rest args) |
| 83 | (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args)) |
| 84 | |
| 85 | (defun decode-uint-8 (buf) |
| 86 | (declare (type dns-decode-state buf)) |
| 87 | (with-slots (packet pos) buf |
| 88 | (when (< (- (length packet) pos) 1) |
| 89 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number).")) |
| 90 | (prog1 (aref packet pos) |
| 91 | (incf pos)))) |
| 92 | |
| 93 | (defun decode-uint-16 (buf) |
| 94 | (declare (type dns-decode-state buf)) |
| 95 | (with-slots (packet pos) buf |
| 96 | (when (< (- (length packet) pos) 2) |
| 97 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number).")) |
| 98 | (prog1 |
| 99 | (+ (* (aref packet pos) 256) |
| 100 | (aref packet (1+ pos))) |
| 101 | (incf pos 2)))) |
| 102 | |
| 103 | (defun decode-uint-32 (buf) |
| 104 | (declare (type dns-decode-state buf)) |
| 105 | (with-slots (packet pos) buf |
| 106 | (when (< (- (length packet) pos) 4) |
| 107 | (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number).")) |
| 108 | (prog1 |
| 109 | (+ (* (aref packet pos) #x1000000) |
| 110 | (* (aref packet (+ pos 1)) #x10000) |
| 111 | (* (aref packet (+ pos 2)) #x100) |
| 112 | (aref packet (+ pos 3))) |
| 113 | (incf pos 4)))) |
| 114 | |
| 115 | (defun decode-domain-name (buf) |
| 116 | (declare (type dns-decode-state buf)) |
| 117 | (labels ((decode-label () |
| 118 | (let* ((orig-off (dns-decode-state-pos buf)) |
| 119 | (len (decode-uint-8 buf))) |
| 120 | (case (ldb (byte 2 6) len) |
| 121 | ((0) |
| 122 | (if (zerop len) |
| 123 | '() |
| 124 | (with-slots (packet pos) buf |
| 125 | (let* ((label (prog1 |
| 126 | (handler-bind |
| 127 | ((charcode:coding-error |
| 128 | (lambda (c) |
| 129 | (declare (ignore c)) |
| 130 | (simple-dns-decode-error buf "DNS label was not ASCII.")))) |
| 131 | (charcode:decode-string (subseq packet |
| 132 | pos (+ pos len)) |
| 133 | :ascii)) |
| 134 | (incf pos len))) |
| 135 | (decoded (append (list label) (decode-label)))) |
| 136 | (push (cons orig-off decoded) (slot-value buf 'prev-names)) |
| 137 | decoded)))) |
| 138 | ((3) (let* ((offset (+ (* 256 (ldb (byte 0 6) len)) |
| 139 | (decode-uint-8 buf))) |
| 140 | (prev (assoc offset (dns-decode-state-prev-names buf)))) |
| 141 | (unless prev |
| 142 | (simple-dns-decode-error buf "Domain name label pointed to non-label position.")) |
| 143 | (cdr prev))) |
| 144 | (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))) |
| 145 | (decode-label))) |
| 146 | |
| 147 | (defun decode-dns-query (buf) |
| 148 | (declare (type dns-decode-state buf)) |
| 149 | (let* ((name (decode-domain-name buf)) |
| 150 | (type (decode-uint-16 buf)) |
| 151 | (class (decode-uint-16 buf)) |
| 152 | (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal))) |
| 153 | (if desc |
| 154 | (make-instance 'resource-query :name name :type (first desc)) |
| 155 | (progn (warn "Unknown DNS RR type: ~D, ~D" class type) |
| 156 | nil)))) |
| 157 | |
| 158 | (defun decode-dns-record (buf) |
| 159 | (declare (type dns-decode-state buf)) |
| 160 | (let* ((name (decode-domain-name buf)) |
| 161 | (type (decode-uint-16 buf)) |
| 162 | (class (decode-uint-16 buf)) |
| 163 | (ttl (decode-uint-32 buf)) |
| 164 | (dlen (decode-uint-16 buf)) |
| 165 | (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal))) |
| 166 | (when (< (length (dns-decode-state-packet buf)) |
| 167 | (+ (dns-decode-state-pos buf) dlen)) |
| 168 | (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length.")) |
| 169 | (if desc |
| 170 | (let ((orig-off (dns-decode-state-pos buf)) |
| 171 | (rr (make-instance (first desc) |
| 172 | :name name |
| 173 | :ttl ttl))) |
| 174 | (dolist (slot-desc (third desc)) |
| 175 | (destructuring-bind (slot-name type) slot-desc |
| 176 | (setf (slot-value rr slot-name) |
| 177 | (with-slots (packet pos) buf |
| 178 | (ecase type |
| 179 | ((uint-16) (decode-uint-16 buf)) |
| 180 | ((uint-32) (decode-uint-32 buf)) |
| 181 | ((domain-name) (decode-domain-name buf)) |
| 182 | ((text) |
| 183 | (let ((len (decode-uint-8 buf))) |
| 184 | (prog1 (subseq packet pos (+ pos len)) |
| 185 | (incf pos len)))) |
| 186 | ((ipv4-address) |
| 187 | (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4))) |
| 188 | (incf pos 4))) |
| 189 | ((ipv6-address) |
| 190 | (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16))) |
| 191 | (incf pos 16)))))))) |
| 192 | (unless (= (dns-decode-state-pos buf) (+ orig-off dlen)) |
| 193 | (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data.")) |
| 194 | rr) |
| 195 | (progn (warn "Unknown DNS RR type: ~D, ~D" class type) |
| 196 | (incf (dns-decode-state-pos buf) dlen) |
| 197 | nil)))) |
| 198 | |
| 199 | (defun decode-dns-packet (buf) |
| 200 | (declare (type dns-decode-state buf)) |
| 201 | (let* ((txid (decode-uint-16 buf)) |
| 202 | (flags (decode-uint-16 buf)) |
| 203 | (qnum (decode-uint-16 buf)) |
| 204 | (ansnum (decode-uint-16 buf)) |
| 205 | (autnum (decode-uint-16 buf)) |
| 206 | (auxnum (decode-uint-16 buf)) |
| 207 | (packet (make-dns-packet :txid txid |
| 208 | :is-response (ldb-test (byte 1 15) flags) |
| 209 | :opcode (case (ldb (byte 4 11) flags) |
| 210 | ((0) :query) |
| 211 | ((1) :iquery) |
| 212 | ((2) :status) |
| 213 | (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags)))) |
| 214 | :authoritative (ldb-test (byte 1 10) flags) |
| 215 | :truncated (ldb-test (byte 1 9) flags) |
| 216 | :recurse (ldb-test (byte 1 8) flags) |
| 217 | :will-recurse (ldb-test (byte 1 7) flags) |
| 218 | :resp-code (case (ldb (byte 4 0) flags) |
| 219 | ((0) :success) |
| 220 | ((1) :format-error) |
| 221 | ((2) :server-failure) |
| 222 | ((3) :name-error) |
| 223 | ((4) :not-implemented) |
| 224 | ((5) :refused) |
| 225 | (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags))))))) |
| 226 | (with-slots (queries answers authority additional) packet |
| 227 | (dotimes (i qnum) |
| 228 | (setf queries (append queries (list (decode-dns-query buf))))) |
| 229 | (dotimes (i ansnum) |
| 230 | (setf answers (append answers (list (decode-dns-record buf))))) |
| 231 | (dotimes (i autnum) |
| 232 | (setf authority (append authority (list (decode-dns-record buf))))) |
| 233 | (dotimes (i auxnum) |
| 234 | (setf additional (append additional (list (decode-dns-record buf)))))) |
| 235 | packet)) |
| 236 | |
| 237 | (defun dns-decode (packet) |
| 238 | (decode-dns-packet (make-dns-decode-state :packet packet))) |
| 239 | |
| 240 | ;;; Packet encoding logic |
| 241 | |
| 242 | (defstruct dns-encode-state |
| 243 | (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8))) |
| 244 | (prev-names '() :type list)) |
| 245 | |
| 246 | (defun encode-uint-8 (buf num) |
| 247 | (declare (type dns-encode-state buf) |
| 248 | (type (unsigned-byte 8) num)) |
| 249 | (with-slots (packet-buf) buf |
| 250 | (vector-push-extend num packet-buf))) |
| 251 | |
| 252 | (defun encode-uint-16 (buf num) |
| 253 | (declare (type dns-encode-state buf) |
| 254 | (type (unsigned-byte 16) num)) |
| 255 | (with-slots (packet-buf) buf |
| 256 | (vector-push-extend (ldb (byte 8 8) num) packet-buf) |
| 257 | (vector-push-extend (ldb (byte 8 0) num) packet-buf))) |
| 258 | |
| 259 | (defun encode-uint-32 (buf num) |
| 260 | (declare (type dns-encode-state buf) |
| 261 | (type (unsigned-byte 32) num)) |
| 262 | (with-slots (packet-buf) buf |
| 263 | (vector-push-extend (ldb (byte 8 24) num) packet-buf) |
| 264 | (vector-push-extend (ldb (byte 8 16) num) packet-buf) |
| 265 | (vector-push-extend (ldb (byte 8 8) num) packet-buf) |
| 266 | (vector-push-extend (ldb (byte 8 0) num) packet-buf))) |
| 267 | |
| 268 | (defun encode-bytes (buf bytes) |
| 269 | (declare (type dns-encode-state buf) |
| 270 | (type (array (unsigned-byte 8)) bytes)) |
| 271 | (with-slots (packet-buf) buf |
| 272 | (dotimes (i (length bytes) (values)) |
| 273 | (vector-push-extend (elt bytes i) packet-buf)))) |
| 274 | |
| 275 | (defun encode-domain-name (buf name) |
| 276 | (declare (type dns-encode-state buf) |
| 277 | (type list name)) |
| 278 | (with-slots (packet-buf prev-names) buf |
| 279 | (labels ((encode-label (name) |
| 280 | (let ((prev (find name prev-names :key 'first :test 'equal))) |
| 281 | (cond ((null name) |
| 282 | (encode-uint-8 buf 0)) |
| 283 | (prev |
| 284 | (encode-uint-16 buf (+ #xc000 (cdr prev)))) |
| 285 | (t |
| 286 | (when (< (length packet-buf) 16384) |
| 287 | (push (cons name (length packet-buf)) prev-names)) |
| 288 | (let ((encoded (charcode:encode-string (car name) :ascii))) |
| 289 | (unless (< (length encoded) 64) |
| 290 | (error "DNS labels cannot exceed 63 octets in length: ~S" (car name))) |
| 291 | (encode-uint-8 buf (length encoded)) |
| 292 | (encode-bytes buf encoded)) |
| 293 | (encode-label (cdr name))))))) |
| 294 | (encode-label name)))) |
| 295 | |
| 296 | (defun encode-dns-query (buf query) |
| 297 | (declare (type dns-encode-state buf) |
| 298 | (type resource-query query)) |
| 299 | (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first))) |
| 300 | (encode-domain-name buf (slot-value query 'name)) |
| 301 | (encode-uint-16 buf (second (second desc))) |
| 302 | (encode-uint-16 buf (first (second desc))))) |
| 303 | |
| 304 | (defun encode-dns-record (buf record) |
| 305 | (declare (type dns-encode-state buf) |
| 306 | (type resource-record record)) |
| 307 | (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first))) |
| 308 | (encode-domain-name buf (slot-value record 'name)) |
| 309 | (encode-uint-16 buf (second (second desc))) |
| 310 | (encode-uint-16 buf (first (second desc))) |
| 311 | (encode-uint-32 buf (slot-value record 'ttl)) |
| 312 | (with-slots (packet-buf) buf |
| 313 | (let ((orig-off (length packet-buf))) |
| 314 | (encode-uint-16 buf 0) |
| 315 | (dolist (slot-desc (third desc)) |
| 316 | (destructuring-bind (slot-name type) slot-desc |
| 317 | (let ((val (slot-value record slot-name))) |
| 318 | (ecase type |
| 319 | ((uint-16) (encode-uint-16 buf val)) |
| 320 | ((uint-32) (encode-uint-32 buf val)) |
| 321 | ((domain-name) (encode-domain-name buf val)) |
| 322 | ((text) (let ((data (etypecase val |
| 323 | (string (charcode:encode-string val :ascii)) |
| 324 | ((array (unsigned-byte 8)) val)))) |
| 325 | (unless (< (length data) 256) |
| 326 | (error "DNS text data length cannot exceed 255 octets.")) |
| 327 | (encode-uint-8 buf (length data)) |
| 328 | (encode-bytes buf data))) |
| 329 | ((ipv4-address) |
| 330 | (check-type val ipv4-host-address) |
| 331 | (encode-bytes buf (slot-value val 'host-bytes))) |
| 332 | ((ipv6-address) |
| 333 | (check-type val ipv6-host-address) |
| 334 | (encode-bytes buf (slot-value val 'host-bytes))))))) |
| 335 | (let ((dlen (- (length packet-buf) orig-off))) |
| 336 | (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen) |
| 337 | (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen))))))) |
| 338 | |
| 339 | (defun encode-dns-packet (buf packet) |
| 340 | (declare (type dns-encode-state buf) |
| 341 | (type dns-packet packet)) |
| 342 | (with-slots (txid is-response opcode authoritative truncated |
| 343 | recurse will-recurse resp-code |
| 344 | queries answers authority additional) packet |
| 345 | (encode-uint-16 buf txid) |
| 346 | (let ((flags 0)) |
| 347 | (setf (ldb (byte 1 15) flags) (if is-response 1 0) |
| 348 | (ldb (byte 4 11) flags) (ecase opcode |
| 349 | ((:query) 0) |
| 350 | ((:iquery) 1) |
| 351 | ((:status) 2)) |
| 352 | (ldb (byte 1 10) flags) (if authoritative 1 0) |
| 353 | (ldb (byte 1 9) flags) (if truncated 1 0) |
| 354 | (ldb (byte 1 8) flags) (if recurse 1 0) |
| 355 | (ldb (byte 1 7) flags) (if will-recurse 1 0) |
| 356 | (ldb (byte 4 0) flags) (ecase resp-code |
| 357 | ((:success) 0) |
| 358 | ((:format-error) 1) |
| 359 | ((:server-failure) 2) |
| 360 | ((:name-error) 3) |
| 361 | ((:not-implemented) 4) |
| 362 | ((:refused) 5))) |
| 363 | (encode-uint-16 buf flags)) |
| 364 | (encode-uint-16 buf (length queries)) |
| 365 | (encode-uint-16 buf (length answers)) |
| 366 | (encode-uint-16 buf (length authority)) |
| 367 | (encode-uint-16 buf (length additional)) |
| 368 | (dolist (query queries) |
| 369 | (encode-dns-query buf query)) |
| 370 | (dolist (rr answers) |
| 371 | (encode-dns-record buf rr)) |
| 372 | (dolist (rr authority) |
| 373 | (encode-dns-record buf rr)) |
| 374 | (dolist (rr additional) |
| 375 | (encode-dns-record buf rr))) |
| 376 | (values)) |
| 377 | |
| 378 | (defun dns-encode (packet) |
| 379 | (check-type packet dns-packet) |
| 380 | (let ((buf (make-dns-encode-state))) |
| 381 | (encode-dns-packet buf packet) |
| 382 | (slot-value buf 'packet-buf))) |
| 383 | |
| 384 | ;;; DN format |
| 385 | |
| 386 | (defun parse-domain-name (name) |
| 387 | (declare (type string name)) |
| 388 | (let ((l '()) |
| 389 | (p 0)) |
| 390 | (loop (let ((p2 (position #\. name :start p))) |
| 391 | (if p2 |
| 392 | (if (= p2 (1- (length name))) |
| 393 | (return (values l t)) |
| 394 | (setf l (append l (list (subseq name p p2))) |
| 395 | p (1+ p2))) |
| 396 | (return (values (append l (list (subseq name p))) nil))))))) |
| 397 | |
| 398 | (defun unparse-domain-name (name) |
| 399 | (declare (type list name)) |
| 400 | (let ((buf nil)) |
| 401 | (dolist (label name buf) |
| 402 | (setf buf (if buf |
| 403 | (concatenate 'string buf "." label) |
| 404 | label))))) |
| 405 | |
| 406 | ;;; Basic communication |
| 407 | |
| 408 | (defun dns-do-request (server packet) |
| 409 | (declare (type address server) |
| 410 | (type dns-packet packet)) |
| 411 | (with-connection (sk server) |
| 412 | (socket-send sk (dns-encode packet)) |
| 413 | (loop |
| 414 | (let ((resp (dns-decode (socket-recv sk)))) |
| 415 | (when (= (dns-packet-txid resp) |
| 416 | (dns-packet-txid packet)) |
| 417 | (return resp)))))) |
| 418 | |
| 419 | (defun dns-std-request (queries &key (txid (random 65536)) (recurse t)) |
| 420 | (let ((qlist (map 'list #'(lambda (o) |
| 421 | (let ((name (first o)) |
| 422 | (type (second o))) |
| 423 | (make-instance 'resource-query |
| 424 | :name (etypecase name |
| 425 | (string (parse-domain-name name)) |
| 426 | (list name)) |
| 427 | :type type))) |
| 428 | queries))) |
| 429 | (make-dns-packet :txid txid |
| 430 | :recurse recurse |
| 431 | :queries qlist))) |
| 432 | |
| 433 | ;;; Misc. |
| 434 | |
| 435 | (defmethod print-object ((q resource-query) stream) |
| 436 | (with-slots (name type) q |
| 437 | (if *print-readably* |
| 438 | (format stream "~A: ~A" type (unparse-domain-name name)) |
| 439 | (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name))))) |
| 440 | |