From db43369d61d700b1d0100998a2d9ecefe28ff8d4 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 21 May 2014 17:02:43 +0100
Subject: [PATCH] Handle domain names properly, including RFC1035 quoting.

It's all rather invasive, but the result is a definite improvement.
---
 addr-family-ipv4.lisp |   3 +-
 addr-family-ipv6.lisp |   3 +-
 net.lisp              | 315 ++++++++++++++++++++++++++++++++++++++++++++++----
 zone.lisp             | 307 ++++++++++++++++++------------------------------
 4 files changed, 410 insertions(+), 218 deletions(-)

diff --git a/addr-family-ipv4.lisp b/addr-family-ipv4.lisp
index f1846c8..d6a084e 100644
--- a/addr-family-ipv4.lisp
+++ b/addr-family-ipv4.lisp
@@ -80,6 +80,7 @@
 
 (defmethod reverse-domain-component-width ((ipaddr ip4addr)) 8)
 (defmethod reverse-domain-radix ((ipaddr ip4addr)) 10)
-(defmethod reverse-domain-suffix ((ipaddr ip4addr)) "in-addr.arpa")
+(defmethod reverse-domain-suffix ((ipaddr ip4addr))
+  (make-domain-name :labels (list "arpa" "in-addr") :absolutep t))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/addr-family-ipv6.lisp b/addr-family-ipv6.lisp
index 5ed014e..ae886c2 100644
--- a/addr-family-ipv6.lisp
+++ b/addr-family-ipv6.lisp
@@ -206,6 +206,7 @@
 
 (defmethod reverse-domain-component-width ((ipaddr ip6addr)) 4)
 (defmethod reverse-domain-radix ((ipaddr ip6addr)) 16)
-(defmethod reverse-domain-suffix ((ipaddr ip6addr)) "ip6.arpa")
+(defmethod reverse-domain-suffix ((ipaddr ip6addr))
+  (make-domain-name :labels (list "arpa" "ip6") :absolutep t))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/net.lisp b/net.lisp
index e1adf62..d245e91 100644
--- a/net.lisp
+++ b/net.lisp
@@ -83,6 +83,61 @@
 (defmethod make-load-form ((object savable-object) &optional environment)
   (make-load-form-saving-slots object :environment environment))
 
+(defun natural-string< (string1 string2
+			&key (start1 0) (end1 nil)
+			(start2 0) (end2 nil))
+  "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
+
+   In particular, digit sequences are handled in a moderately sensible way.
+   Split the strings into maximally long alternating sequences of non-numeric
+   and numeric characters, such that the non-numeric sequences are
+   non-empty.  Compare these lexicographically; numeric sequences order
+   according to their integer values, non-numeric sequences in the usual
+   lexicographic ordering.
+
+   Returns two values: whether STRING1 strictly precedes STRING2, and whether
+   STRING1 strictly follows STRING2."
+
+  (let ((end1 (or end1 (length string1)))
+	(end2 (or end2 (length string2))))
+    (loop
+      (cond ((>= start1 end1)
+	     (let ((eqp (>= start2 end2)))
+	       (return (values (not eqp) nil))))
+	    ((>= start2 end2)
+	     (return (values nil t)))
+	    ((and (digit-char-p (char string1 start1))
+		  (digit-char-p (char string2 start2)))
+	     (let* ((lim1 (or (position-if-not #'digit-char-p string1
+					       :start start1 :end end1)
+			      end1))
+		    (n1 (parse-integer string1 :start start1 :end lim1))
+		    (lim2 (or (position-if-not #'digit-char-p string2
+					       :start start2 :end end2)
+			      end2))
+		    (n2 (parse-integer string2 :start start2 :end lim2)))
+	       (cond ((< n1 n2) (return (values t nil)))
+		     ((> n1 n2) (return (values nil t))))
+	       (setf start1 lim1
+		     start2 lim2)))
+	    (t
+	     (let ((lim1 (or (position-if #'digit-char-p string1
+					  :start start1 :end end1)
+			     end1))
+		   (lim2 (or (position-if #'digit-char-p string2
+					  :start start2 :end end2)
+			     end2)))
+	       (cond ((string< string1 string2
+			       :start1 start1 :end1 lim1
+			       :start2 start2 :end2 lim2)
+		      (return (values t nil)))
+		     ((string> string1 string2
+			       :start1 start1 :end1 lim1
+			       :start2 start2 :end2 lim2)
+		      (return (values nil t))))
+	       (setf start1 lim1
+		     start2 lim2)))))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Parsing primitives for addresses.
 
@@ -631,6 +686,224 @@
     (recurse width mask 0)))
 
 ;;;--------------------------------------------------------------------------
+;;; Domain names.
+
+(export '(domain-name make-domain-name domain-name-p
+	  domain-name-labels domain-name-absolutep))
+(defstruct domain-name
+  "A domain name, which is a list of labels.
+
+   The most significant (top-level) label is first, so they're in
+   right-to-left order.."
+  (labels nil :type list)
+  (absolutep nil :type boolean))
+
+(export 'quotify-label)
+(defun quotify-label (string)
+  "Quote an individual label STRING, using the RFC1035 rules.
+
+   A string which contains only printable characters other than `.', `@',
+   `\"', `\\', `;', `(' and `)' is returned as is.  Other strings are
+   surrounded with quotes, and special characters (now only `\\', `\"' and
+   unprintable things) are escaped -- printable characters are preceded by
+   backslashes, and non-printable characters are represented as \\DDD decimal
+   codes."
+
+  (if (every (lambda (ch)
+	       (and (<= 33 (char-code ch) 126)
+		    (not (member ch '(#\. #\@ #\" #\\ #\; #\( #\))))))
+	     string)
+      string
+      (with-output-to-string (out)
+	(write-char #\" out)
+	(dotimes (i (length string))
+	  (let ((ch (char string i)))
+	    (cond ((or (eql ch #\") (eql ch #\\))
+		   (write-char #\\ out)
+		   (write-char ch out))
+		  ((<= 32 (char-code ch) 126)
+		   (write-char ch out))
+		  (t
+		   (format out "\\~3,'0D" (char-code ch))))))
+	(write-char #\" out))))
+
+(defun unquotify-label (string &key (start 0) (end nil))
+  "Parse and unquote a label from the STRING.
+
+   Returns the parsed label, and the position of the next label."
+
+  (let* ((end (or end (length string)))
+	 (i start)
+	 (label (with-output-to-string (out)
+		  (labels
+		      ((numeric-escape-char ()
+			 ;; We've just seen a `\', and the next character is
+			 ;; a digit.  Read the three-digit sequence, and
+			 ;; return the appropriate character, or nil if the
+			 ;; sequence was invalid.
+
+			 (let* ((e (+ i 3))
+				(code
+				 (and (<= e end)
+				      (do ((j i (1+ j))
+					   (a 0
+					      (let ((d (digit-char-p
+							(char string j))))
+						(and a d (+ (* 10 a) d)))))
+					  ((>= j e) a)))))
+			   (unless (<= 0 code 255)
+			     (error "Escape code out of range."))
+			   (setf i e)
+			   (and code (code-char code))))
+
+		       (hack-backslash ()
+			 ;; We've just seen a `\'.  Read the next character
+			 ;; and write it to the output stream.
+
+			 (let ((ch (cond ((>= i end) nil)
+					 ((not (digit-char-p
+						(char string i)))
+					  (prog1 (char string i)
+					    (incf i)))
+					 (t (numeric-escape-char)))))
+			   (unless ch
+			     (error "Invalid escape in label."))
+			   (write-char ch out)))
+
+		       (munch (delim)
+			 ;; Read characters until we reach an unescaped copy
+			 ;; of DELIM, writing the unescaped versions to the
+			 ;; output stream.  Return nil if we hit the end, or
+			 ;; the delimiter character.
+
+			 (loop
+			   (when (>= i end) (return nil))
+			   (let ((ch (char string i)))
+			     (incf i)
+			     (cond ((char= ch #\\)
+				    (hack-backslash))
+				   ((char= ch delim)
+				    (return ch))
+				   (t
+				    (write-char ch out)))))))
+
+		    ;; If the label starts with a `"' then continue until we
+		    ;; get to the next `"', which must either end the string,
+		    ;; or be followed by a `.'.  If the label isn't quoted,
+		    ;; then munch until the `.'.
+		    (cond
+		      ((and (< i end) (char= (char string i) #\"))
+		       (incf i)
+		       (let ((delim (munch #\")))
+			 (unless (and delim
+				      (or (= i end)
+					  (char= (prog1 (char string i)
+						   (incf i))
+						 #\.)))
+			   (error "Invalid quoting in label."))))
+		      (t
+		       (munch #\.)))))))
+
+    ;; We're done.  Phew!
+    (when (string= label "")
+      (error "Empty labels aren't allowed."))
+    (values label i)))
+
+(export 'parse-domain-name)
+(defun parse-domain-name (string &key (start 0) (end nil) absolutep)
+  "Parse (a substring of) STRING as a possibly-relative domain name.
+
+   If STRING doesn't end in an unquoted `.', then it's relative (to some
+   unspecified parent domain).  The input may be the special symbol `@' to
+   refer to the parent itself, `.' to mean the root, or a sequence of labels
+   separated by `.'.  The final name is returned as a `domain-name' object."
+
+  (let ((end (or end (length string)))
+	(i start))
+    (flet ((parse ()
+	     ;; Parse a sequence of labels.
+
+	     (let ((labels nil))
+	       (loop
+		 (unless (< i end) (return))
+		 (multiple-value-bind (label j)
+		     (unquotify-label string :start i :end end)
+		   (push label labels)
+		   (setf i j)))
+	       (unless labels
+		 (error "Empty domain names have special notations."))
+	       (make-domain-name :labels labels :absolutep absolutep))))
+
+      (cond ((= (1+ i) end)
+	     ;; A single-character name.  Check for the magic things;
+	     ;; otherwise I guess it must just be short.
+
+	     (case (char string i)
+	       (#\@ (make-domain-name :labels nil :absolutep nil))
+	       (#\. (make-domain-name :labels nil :absolutep t))
+	       (t (parse))))
+
+	    (t
+	     ;; Something more complicated.  If the name ends with `.', but
+	     ;; not `\\.', then it must be absolute.
+	     (when (and (< i end)
+			(char= (char string (- end 1)) #\.)
+			(char/= (char string (- end 2)) #\\))
+	       (decf end)
+	       (setf absolutep t))
+	     (parse))))))
+
+(defmethod print-object ((name domain-name) stream)
+  "Print a domain NAME to a STREAM, using RFC1035 quoting rules."
+  (let ((labels (mapcar #'quotify-label
+			(reverse (domain-name-labels name)))))
+    (cond (*print-escape*
+	   (print-unreadable-object (name stream :type t)
+	     (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~@[.~]~]"
+		     labels (domain-name-absolutep name))))
+	  (t
+	   (format stream "~:[~:[@~;.~]~;~@*~{~A~^.~}~]"
+		   labels (domain-name-absolutep name))))))
+
+(export 'domain-name-concat)
+(defun domain-name-concat (left right)
+  "Concatenate the LEFT and RIGHT names."
+  (if (domain-name-absolutep left)
+      left
+      (make-domain-name :labels (append (domain-name-labels right)
+					(domain-name-labels left))
+			:absolutep (domain-name-absolutep right))))
+
+(export 'domain-name<)
+(defun domain-name< (name-a name-b)
+  "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
+
+   Split the names into labels, and then lexicographically compare the
+   sequences of labels, right to left, using `natural-string<'.
+
+   Returns two values: whether NAME-A strictly precedes NAME-B, and whether
+   NAME-A strictly follows NAME-B.
+
+   This doesn't give useful answers on relative domains unless you know what
+   you're doing."
+
+  (let ((labels-a (domain-name-labels name-a))
+	(labels-b (domain-name-labels name-b)))
+    (loop (cond ((null labels-a)
+		 (return (values (not (null labels-b)) (null labels-b))))
+		((null labels-b)
+		 (return (values nil t)))
+		(t
+		 (multiple-value-bind (precp follp)
+		     (natural-string< (pop labels-a) (pop labels-b))
+		   (cond (precp (return (values t nil)))
+			 (follp (return (values nil t))))))))))
+
+(export 'root-domain)
+(defparameter root-domain (make-domain-name :labels nil :absolutep t)
+  "The root domain, as a convenient object.")
+
+;;;--------------------------------------------------------------------------
 ;;; Reverse lookups.
 
 (export 'reverse-domain-component-width)
@@ -654,22 +927,22 @@
    IPADDR between bits START (inclusive) and END (exclusive).  Address
    components which are only partially within the given bounds are included
    unless PARTIALP is nil.")
+
   (:method ((ipaddr ipaddr) start end &key (partialp t))
 
     (let ((addr (ipaddr-addr ipaddr))
 	  (comp-width (reverse-domain-component-width ipaddr))
 	  (radix (reverse-domain-radix ipaddr)))
 
-      (with-output-to-string (out)
-	(do ((i (funcall (if partialp #'round-down #'round-up)
-			 start comp-width)
-		(+ i comp-width))
-	     (limit (funcall (if partialp #'round-up #'round-down)
-			     end comp-width))
-	     (sep nil t))
-	    ((>= i limit))
-	  (format out "~:[~;.~]~(~vR~)"
-		  sep radix (ldb (byte comp-width i) addr)))))))
+      (do ((i (funcall (if partialp #'round-down #'round-up)
+		       start comp-width)
+	      (+ i comp-width))
+	   (limit (funcall (if partialp #'round-up #'round-down)
+			  end comp-width))
+	   (comps nil (cons (format nil "~(~vR~)" radix
+				    (ldb (byte comp-width i) addr))
+			    comps)))
+	  ((>= i limit) (make-domain-name :labels comps))))))
 
 (export 'reverse-domain)
 (defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
@@ -677,23 +950,23 @@
 
    If PREFIX-LEN is nil then it defaults to the length of the network's fixed
    prefix.")
+
   (:method ((ipn ipnet) &optional prefix-len)
     (let* ((addr (ipnet-net ipn))
 	   (mask (ipnet-mask ipn))
 	   (width (ipaddr-width addr)))
-      (concatenate 'string
-		   (reverse-domain-fragment
-		    addr
-		    (if prefix-len
-			(- width prefix-len)
-			(ipnet-changeable-bits width mask))
-		    width
-		    :partialp nil)
-		   "."
-		   (reverse-domain-suffix addr))))
+      (domain-name-concat (reverse-domain-fragment
+			   addr
+			   (if prefix-len
+			       (- width prefix-len)
+			       (ipnet-changeable-bits width mask))
+			   width
+			   :partialp nil)
+			  (reverse-domain-suffix addr))))
+
   (:method ((addr ipaddr) &optional prefix-len)
     (let* ((width (ipaddr-width addr)))
-      (reverse-domain (make-ipnet addr (mask width))
+      (reverse-domain (make-ipnet addr width)
 		      (or prefix-len width)))))
 
 ;;;--------------------------------------------------------------------------
diff --git a/zone.lisp b/zone.lisp
index e686322..602f1f2 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -111,94 +111,6 @@
       (when timep
 	(format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 
-(defun natural-string< (string1 string2
-			&key (start1 0) (end1 nil)
-			(start2 0) (end2 nil))
-  "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
-
-   In particular, digit sequences are handled in a moderately sensible way.
-   Split the strings into maximally long alternating sequences of non-numeric
-   and numeric characters, such that the non-numeric sequences are
-   non-empty.  Compare these lexicographically; numeric sequences order
-   according to their integer values, non-numeric sequences in the usual
-   lexicographic ordering.
-
-   Returns two values: whether STRING1 strictly precedes STRING2, and whether
-   STRING1 strictly follows STRING2."
-
-  (let ((end1 (or end1 (length string1)))
-	(end2 (or end2 (length string2))))
-    (loop
-      (cond ((>= start1 end1)
-	     (let ((eqp (>= start2 end2)))
-	       (return (values (not eqp) nil))))
-	    ((>= start2 end2)
-	     (return (values nil t)))
-	    ((and (digit-char-p (char string1 start1))
-		  (digit-char-p (char string2 start2)))
-	     (let* ((lim1 (or (position-if-not #'digit-char-p string1
-					       :start start1 :end end1)
-			      end1))
-		    (n1 (parse-integer string1 :start start1 :end lim1))
-		    (lim2 (or (position-if-not #'digit-char-p string2
-					       :start start2 :end end2)
-			      end2))
-		    (n2 (parse-integer string2 :start start2 :end lim2)))
-	       (cond ((< n1 n2) (return (values t nil)))
-		     ((> n1 n2) (return (values nil t))))
-	       (setf start1 lim1
-		     start2 lim2)))
-	    (t
-	     (let ((lim1 (or (position-if #'digit-char-p string1
-					  :start start1 :end end1)
-			     end1))
-		   (lim2 (or (position-if #'digit-char-p string2
-					  :start start2 :end end2)
-			     end2)))
-	       (cond ((string< string1 string2
-			       :start1 start1 :end1 lim1
-			       :start2 start2 :end2 lim2)
-		      (return (values t nil)))
-		     ((string> string1 string2
-			       :start1 start1 :end1 lim1
-			       :start2 start2 :end2 lim2)
-		      (return (values nil t))))
-	       (setf start1 lim1
-		     start2 lim2)))))))
-
-(defun domain-name< (name-a name-b)
-  "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
-
-   Split the names into labels at the dots, and then lexicographically
-   compare the sequences of labels, right to left, using `natural-string<'.
-
-   Returns two values: whether NAME-A strictly precedes NAME-B, and whether
-   NAME-A strictly follows NAME-B."
-  (let ((pos-a (length name-a))
-	(pos-b (length name-b)))
-    (loop (let ((dot-a (or (position #\. name-a
-				     :from-end t :end pos-a)
-			   -1))
-		(dot-b (or (position #\. name-b
-				     :from-end t :end pos-b)
-			   -1)))
-	    (multiple-value-bind (precp follp)
-		(natural-string< name-a name-b
-				 :start1 (1+ dot-a) :end1 pos-a
-				 :start2 (1+ dot-b) :end2 pos-b)
-	      (cond (precp
-		     (return (values t nil)))
-		    (follp
-		     (return (values nil t)))
-		    ((= dot-a -1)
-		     (let ((eqp (= dot-b -1)))
-		       (return (values (not eqp) nil))))
-		    ((= dot-b -1)
-		     (return (values nil t)))
-		    (t
-		     (setf pos-a dot-a
-			   pos-b dot-b))))))))
-
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 
@@ -213,6 +125,10 @@
   min-ttl
   serial)
 
+(export 'zone-text-name)
+(defun zone-text-name (zone)
+  (princ-to-string (zone-name zone)))
+
 (export 'mx)
 (defstruct (mx (:predicate mxp))
   "Mail-exchange record information."
@@ -347,32 +263,20 @@
 	      clauses)))
 
 (export 'zone-parse-host)
-(defun zone-parse-host (f zname)
-  "Parse a host name F.
-
-   If F ends in a dot then it's considered absolute; otherwise it's relative
-   to ZNAME."
-  (setf f (stringify f))
-  (cond ((string= f "@") (stringify zname))
-	((and (plusp (length f))
-	      (char= (char f (1- (length f))) #\.))
-	 (string-downcase (subseq f 0 (1- (length f)))))
-	(t (string-downcase (concatenate 'string f "."
-					 (stringify zname))))))
-
-(export 'zone-make-name)
-(defun zone-make-name (prefix zone-name)
-  "Compute a full domain name from a PREFIX and a ZONE-NAME.
-
-   If the PREFIX ends with `.' then it's absolute already; otherwise, append
-   the ZONE-NAME, separated with a `.'.  If PREFIX is nil, or `@', then
-   return the ZONE-NAME only."
-  (if (or (not prefix) (string= prefix "@"))
-      zone-name
-      (let ((len (length prefix)))
-	(if (or (zerop len) (char/= (char prefix (1- len)) #\.))
-	    (join-strings #\. (list prefix zone-name))
-	    prefix))))
+(defun zone-parse-host (form &optional tail)
+  "Parse a host name FORM from a value in a zone form.
+
+   The underlying parsing is done using `parse-domain-name'.  Here, we
+   interpret various kinds of Lisp object specially.  In particular: `nil'
+   refers to the TAIL zone (just like a plain `@'); and a symbol is downcased
+   before use."
+  (let ((name (etypecase form
+		(null (make-domain-name :labels nil :absolutep nil))
+		(domain-name form)
+		(symbol (parse-domain-name (string-downcase form)))
+		(string (parse-domain-name form)))))
+    (if (null tail) name
+	(domain-name-concat name tail))))
 
 (export 'zone-records-sorted)
 (defun zone-records-sorted (zone)
@@ -476,9 +380,9 @@
 				   top))
 			 ((listp r)
 			  (dolist (name (listify (car r)))
-			    (collect (make-zone-subdomain :name name
-							  :ttl ttl
-							  :records (cdr r))
+			    (collect (make-zone-subdomain
+				      :name (zone-parse-host name)
+				      :ttl ttl :records (cdr r))
 				     sub)))
 			 (t
 			  (error "Unexpected record form ~A" (car r))))))))
@@ -492,24 +396,25 @@
 	     (multiple-value-bind (top sub) (sift rec ttl)
 	       (if (and dom (null top) sub)
 		   (let ((preferred
-			  (or (find-if (lambda (s)
-					 (some #'zone-preferred-subnet-p
-					       (listify (zs-name s))))
-				       sub)
+			  (or (find-if
+			       (lambda (s)
+				 (let ((ll (domain-name-labels (zs-name s))))
+				   (and (consp ll) (null (cdr ll))
+					(zone-preferred-subnet-p (car ll)))))
+			       sub)
 			      (car sub))))
 		     (when preferred
 		       (process (zs-records preferred)
 				dom
 				(zs-ttl preferred))))
-		   (let ((name (and dom
-				    (string-downcase
-				     (join-strings #\. (reverse dom))))))
+		   (let ((name dom))
 		     (dolist (zr top)
 		       (setf (zr-name zr) name)
 		       (funcall func zr))))
 	       (dolist (s sub)
 		 (process (zs-records s)
-			  (cons (zs-name s) dom)
+			  (if (null dom) (zs-name s)
+			      (domain-name-concat dom (zs-name s)))
 			  (zs-ttl s))))))
 
     ;; Process the records we're given with no prefix.
@@ -526,19 +431,21 @@
    though a singleton NAME needn't be a list.  Returns the default TTL and an
    soa structure representing the zone head."
   (destructuring-bind
-      (zname
+      (raw-zname
        &key
        (source *default-zone-source*)
        (admin (or *default-zone-admin*
-		  (format nil "hostmaster@~A" zname)))
+		  (format nil "hostmaster@~A" raw-zname)))
        (refresh *default-zone-refresh*)
        (retry *default-zone-retry*)
        (expire *default-zone-expire*)
        (min-ttl *default-zone-min-ttl*)
        (ttl min-ttl)
-       (serial (make-zone-serial zname)))
+       (serial (make-zone-serial raw-zname))
+       &aux
+       (zname (zone-parse-host raw-zname root-domain)))
       (listify head)
-    (values (string-downcase zname)
+    (values zname
 	    (timespec-seconds ttl)
 	    (make-soa :admin admin
 		      :source (zone-parse-host source zname)
@@ -583,6 +490,7 @@
 
    These (except MAKE-PTR-P, which defaults to nil) default to the above
    arguments (even if you didn't accept the arguments)."
+
   (setf types (listify types))
   (let* ((type (car types))
 	 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
@@ -594,7 +502,8 @@
 	   (defun ,func (,prefix ,zname ,data ,ttl ,col)
 	     ,@doc
 	     ,@decls
-	     (let ((,name (zone-make-name ,prefix ,zname)))
+	     (let ((,name (if (null ,prefix) ,zname
+			      (domain-name-concat ,prefix ,zname))))
 	       (flet ((,list (&key ((:name ,tname) ,name)
 				   ((:type ,ttype) ,type)
 				   ((:data ,tdata) ,data)
@@ -621,7 +530,7 @@
 	     (let ((func (or (get (zr-type zr) 'zone-parse)
 			     (error "No parser for record ~A."
 				    (zr-type zr))))
-		   (name (and (zr-name zr) (stringify (zr-name zr)))))
+		   (name (and (zr-name zr) (zr-name zr))))
 	       (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
       (zone-process-records records ttl #'parse-record))))
 
@@ -645,10 +554,11 @@
 
 (export 'zone-create)
 (defun zone-create (zf)
-  "Zone construction function.  Given a zone form ZF, construct the zone and
-   add it to the table."
+  "Zone construction function.
+
+   Given a zone form ZF, construct the zone and add it to the table."
   (let* ((zone (zone-parse zf))
-	 (name (zone-name zone)))
+	 (name (zone-text-name zone)))
     (setf (zone-find name) zone)
     name))
 
@@ -672,7 +582,8 @@
     (with-gensyms (ipn)
       `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
 	 (let ((*address-family* (ipnet-family ,ipn)))
-	   (zone-create `((,(reverse-domain ,ipn ,prefix-bits)
+	   (zone-create `((,(format nil "~A." (reverse-domain ,ipn
+							      ,prefix-bits))
 			    ,@',(loop for (k v) on args by #'cddr
 				      unless (member k
 						     '(:family :prefix-bits))
@@ -763,19 +674,13 @@
     (rec-raw-string s :start start :end end)))
 
 (export 'rec-name)
-(defun rec-name (s)
-  "Append a domain name S.
+(defun rec-name (name)
+  "Append a domain NAME.
 
    No attempt is made to perform compression of the name."
-  (let ((i 0) (n (length s)))
-    (loop (let* ((dot (position #\. s :start i))
-		 (lim (or dot n)))
-	    (rec-string s :start i :end lim :max 63)
-	    (if dot
-		(setf i (1+ dot))
-		(return))))
-    (when (< i n)
-      (rec-u8 0))))
+  (dolist (label (reverse (domain-name-labels name)))
+    (rec-string label :max 63))
+  (rec-u8 0))
 
 (export 'build-record)
 (defmacro build-record (&body body)
@@ -995,7 +900,12 @@
 	(unless default-port
 	  (let ((serv (serv-by-name service protocol)))
 	    (setf default-port (and serv (serv-port serv)))))
-	(let ((rname (format nil "~(_~A._~A~).~A" service protocol name)))
+	(let ((rname (flet ((prepend (tag tail)
+			      (domain-name-concat
+			       (make-domain-name
+				:labels (list (format nil "_~(~A~)" tag)))
+			       tail)))
+		       (prepend service (prepend protocol name)))))
 	  (dolist (prov providers)
 	    (destructuring-bind
 		(srvname
@@ -1054,11 +964,12 @@
 		       (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
 	      (let* ((frag (reverse-domain-fragment (zr-data zr)
 						    0 frag-len))
-		     (name (concatenate 'string frag "." name)))
-		(unless (gethash name seen)
+		     (name (domain-name-concat frag name))
+		     (name-string (princ-to-string name)))
+		(unless (gethash name-string seen)
 		  (rec :name name :type :ptr
 		       :ttl (zr-ttl zr) :data (zr-name zr))
-		  (setf (gethash name seen) t))))))))))
+		  (setf (gethash name-string seen) t))))))))))
 
 (defzoneparse :multi (name data rec :zname zname :ttl ttl)
   ":multi (((NET*) &key :start :end :family :suffix) . REC)
@@ -1084,42 +995,45 @@
 
    Obviously, nested `:multi' records won't work well."
 
-  (destructuring-bind (nets &key start end (family *address-family*) suffix)
+  (destructuring-bind (nets
+		       &key start end ((:suffix raw-suffix))
+		       (family *address-family*))
       (listify (car data))
-    (dolist (net (listify nets))
-      (dolist (ipn (net-parse-to-ipnets net family))
-	(let* ((addr (ipnet-net ipn))
-	       (width (ipaddr-width addr))
-	       (comp-width (reverse-domain-component-width addr))
-	       (end (round-up (or end
-				  (ipnet-changeable-bits width
-							 (ipnet-mask ipn)))
-			      comp-width))
-	       (start (round-down (or start (- end comp-width))
-				  comp-width))
-	       (map (ipnet-host-map ipn)))
-	  (multiple-value-bind (host-step host-limit)
-	      (ipnet-index-bounds map start end)
-	    (do ((index 0 (+ index host-step)))
-		((> index host-limit))
-	      (let* ((addr (ipnet-index-host map index))
-		     (frag (reverse-domain-fragment addr start end))
-		     (target (concatenate 'string
-					  (zone-make-name
-					   (if (not suffix) frag
-					       (concatenate 'string
-							    frag "." suffix))
-					   zname)
-					  ".")))
-		(dolist (zr (zone-parse-records (zone-make-name frag zname)
-						ttl
-						(subst target '*
-						       (cdr data))))
-		  (rec :name (zr-name zr)
-		       :type (zr-type zr)
-		       :data (zr-data zr)
-		       :ttl (zr-ttl zr)
-		       :make-ptr-p (zr-make-ptr-p zr)))))))))))
+    (let ((suffix (if (not raw-suffix)
+		      (make-domain-name :labels nil :absolutep nil)
+		      (zone-parse-host raw-suffix))))
+      (dolist (net (listify nets))
+	(dolist (ipn (net-parse-to-ipnets net family))
+	  (let* ((addr (ipnet-net ipn))
+		 (width (ipaddr-width addr))
+		 (comp-width (reverse-domain-component-width addr))
+		 (end (round-up (or end
+				    (ipnet-changeable-bits width
+							   (ipnet-mask ipn)))
+				comp-width))
+		 (start (round-down (or start (- end comp-width))
+				    comp-width))
+		 (map (ipnet-host-map ipn)))
+	    (multiple-value-bind (host-step host-limit)
+		(ipnet-index-bounds map start end)
+	      (do ((index 0 (+ index host-step)))
+		  ((> index host-limit))
+		(let* ((addr (ipnet-index-host map index))
+		       (frag (reverse-domain-fragment addr start end))
+		       (target (reduce #'domain-name-concat
+				       (list frag suffix zname)
+				       :from-end t
+				       :initial-value root-domain)))
+		  (dolist (zr (zone-parse-records (domain-name-concat frag
+								      zname)
+						  ttl
+						  (subst target '*
+							 (cdr data))))
+		    (rec :name (zr-name zr)
+			 :type (zr-type zr)
+			 :data (zr-data zr)
+			 :ttl (zr-ttl zr)
+			 :make-ptr-p (zr-make-ptr-p zr))))))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone file output.
@@ -1213,16 +1127,19 @@
 
 (export 'bind-hostname)
 (defun bind-hostname (hostname)
-  (let* ((h (string-downcase (stringify hostname)))
-	 (hl (length h))
-	 (r (string-downcase (zone-name *writing-zone*)))
-	 (rl (length r)))
-    (cond ((string= r h) "@")
-	  ((and (> hl rl)
-		(char= (char h (- hl rl 1)) #\.)
-		(string= h r :start1 (- hl rl)))
-	   (subseq h 0 (- hl rl 1)))
-	  (t (concatenate 'string h ".")))))
+  (let ((zone (domain-name-labels (zone-name *writing-zone*)))
+	(name (domain-name-labels hostname)))
+    (loop
+      (unless (and zone name (string= (car zone) (car name)))
+	(return))
+      (pop zone) (pop name))
+    (flet ((stitch (labels absolutep)
+	     (format nil "~{~A~^.~}~@[.~]"
+		     (reverse (mapcar #'quotify-label labels))
+		     absolutep)))
+      (cond (zone (stitch (domain-name-labels hostname) t))
+	    (name (stitch name nil))
+	    (t "@")))))
 
 (export 'bind-output-hostname)
 (defun bind-output-hostname (hostname)
-- 
2.11.0