(* (aref packet (+ pos 1)) #x10000)
(* (aref packet (+ pos 2)) #x100)
(aref packet (+ pos 3)))
- (incf pos 2))))
+ (incf pos 4))))
(defun decode-domain-name (buf)
(declare (type dns-decode-state buf))
- (let* ((orig-off (dns-decode-state-pos buf))
- (decoded (block decoded
- (let ((l '()))
- (loop (let ((len (decode-uint-8 buf)))
- (case (ldb (byte 2 6) len)
- ((0)
- (when (zerop len)
- (return-from decoded l))
- (with-slots (packet pos) buf
- (setf l (append l (list (handler-bind
- ((charcode:coding-error
- (lambda (c)
- (declare (ignore c))
- (simple-dns-decode-error buf "DNS label was not ASCII."))))
- (charcode:decode-string (subseq packet
- pos (+ pos len))
- :ascii)))))
- (incf pos len)))
- ((3) (return-from decoded
- (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
- (decode-uint-8 buf)))
- (prev (assoc offset (dns-decode-state-prev-names buf))))
- (unless prev
- (simple-dns-decode-error buf "Domain name label pointed to non-label position"))
- (append l (cdr prev)))))
- (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))))))
- (push (cons orig-off decoded)
- (slot-value buf 'prev-names))))
+ (labels ((decode-label ()
+ (let* ((orig-off (dns-decode-state-pos buf))
+ (len (decode-uint-8 buf)))
+ (case (ldb (byte 2 6) len)
+ ((0)
+ (if (zerop len)
+ '()
+ (with-slots (packet pos) buf
+ (let* ((label (prog1
+ (handler-bind
+ ((charcode:coding-error
+ (lambda (c)
+ (declare (ignore c))
+ (simple-dns-decode-error buf "DNS label was not ASCII."))))
+ (charcode:decode-string (subseq packet
+ pos (+ pos len))
+ :ascii))
+ (incf pos len)))
+ (decoded (append (list label) (decode-label))))
+ (push (cons orig-off decoded) (slot-value buf 'prev-names))
+ decoded))))
+ ((3) (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
+ (decode-uint-8 buf)))
+ (prev (assoc offset (dns-decode-state-prev-names buf))))
+ (unless prev
+ (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
+ (cdr prev)))
+ (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
+ (decode-label)))
(defun decode-dns-query (buf)
(declare (type dns-decode-state buf))
(let ((buf (make-dns-encode-state)))
(encode-dns-packet buf packet)
(slot-value buf 'packet-buf)))
+
+;;; DN format
+
+(defun parse-domain-name (name)
+ (declare (type string name))
+ (let ((l '())
+ (p 0))
+ (loop (let ((p2 (position #\. name :start p)))
+ (if p2
+ (if (= p2 (1- (length name)))
+ (return (values l t))
+ (setf l (append l (list (subseq name p p2)))
+ p (1+ p2)))
+ (return (values (append l (list (subseq name p))) nil)))))))
+
+(defun unparse-domain-name (name)
+ (declare (type list name))
+ (let ((buf nil))
+ (dolist (label name buf)
+ (setf buf (if buf
+ (concatenate 'string buf "." label)
+ label)))))
+
+;;; Misc.
+
+(defmethod print-object ((q resource-query) stream)
+ (with-slots (name type) q
+ (if *print-readably*
+ (format stream "~A: ~A" type (unparse-domain-name name))
+ (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
+