chiark / gitweb /
Handle domain names properly, including RFC1035 quoting.
authorMark Wooding <mdw@distorted.org.uk>
Wed, 21 May 2014 16:02:43 +0000 (17:02 +0100)
committerMark Wooding <mdw@distorted.org.uk>
Thu, 22 May 2014 09:05:50 +0000 (10:05 +0100)
It's all rather invasive, but the result is a definite improvement.

addr-family-ipv4.lisp
addr-family-ipv6.lisp
net.lisp
zone.lisp

index f1846c8..d6a084e 100644 (file)
@@ -80,6 +80,7 @@ (defmethod ipnet-broadcast ((ipn ip4net))
 
 (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 --------------------------------------------------
index 5ed014e..ae886c2 100644 (file)
@@ -206,6 +206,7 @@ (defmethod ipnet-broadcast ((ipn ip6net)) nil)
 
 (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 --------------------------------------------------
index e1adf62..d245e91 100644 (file)
--- a/net.lisp
+++ b/net.lisp
@@ -83,6 +83,61 @@ (defclass savable-object ()
 (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 @@ (defun ipnet-changeable-bits (width mask)
     (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 @@ (defgeneric reverse-domain-fragment (ipaddr start end &key partialp)
    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 @@ (defgeneric reverse-domain (ipaddr-or-ipn &optional prefix-len)
 
    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)))))
 
 ;;;--------------------------------------------------------------------------
index e686322..602f1f2 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -111,94 +111,6 @@ (defun iso-date (&optional time &key datep timep (sep #\ ))
       (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 @@ (defstruct (soa (:predicate soap))
   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 @@ (defmacro preferred-subnet-case (&body clauses)
              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 @@ (defun zone-process-records (rec ttl func)
                                   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 @@ (defun zone-process-records (rec ttl func)
             (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 @@ (defun zone-parse-head (head)
    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 @@ (defmacro defzoneparse (types (name data list
 
    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 @@ (defmacro defzoneparse (types (name data list
           (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 @@ (defun zone-parse-records (zname ttl records)
             (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 @@ (defun zone-parse (zf)
 
 (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 @@ (defmacro defrevzone (head &body zf)
     (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 @@ (defun rec-string (s &key (start 0) end (max 255))
     (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 @@ (defzoneparse :srv (name data rec :zname zname)
        (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 @@ (defzoneparse (:rev :reverse) (name data rec)
                       (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 @@ (defzoneparse :multi (name data rec :zname zname :ttl ttl)
 
    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 @@ (defvar *bind-last-record-name* nil
 
 (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)