+;;; 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.")
+
+;;;--------------------------------------------------------------------------
~mdw / zone / commitdiff