X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/804882ca1c12315b7943c6f71f7bb43866a7a301..HEAD:/net.lisp

diff --git a/net.lisp b/net.lisp
index e1adf62..13f390c 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.
 
@@ -214,8 +269,10 @@
   (:documentation "Transform the address IP into a numeric textual form."))
 
 (defmethod print-object ((addr ipaddr) stream)
-  (print-unreadable-object (addr stream :type t)
-    (write-string (ipaddr-string addr) stream)))
+  (if *print-escape*
+      (print-unreadable-object (addr stream :type t)
+	(write-string (ipaddr-string addr) stream))
+      (write-string (ipaddr-string addr) stream)))
 
 (export 'ipaddrp)
 (defun ipaddrp (ip)
@@ -244,8 +301,8 @@
   "Given an integer I, return an N-bit netmask with its I top bits set."
   (- (ash 1 n) (ash 1 (- n i))))
 
-(export 'ipmask-cidl-slash)
-(defun ipmask-cidl-slash (width mask)
+(export 'ipmask-cidr-slash)
+(defun ipmask-cidr-slash (width mask)
   "Given a netmask MASK, try to compute a prefix length.
 
    Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if
@@ -329,12 +386,14 @@
   (with-ipnet (net nil mask) ipn
     (format nil "~A/~A"
 	    (ipaddr-string net)
-	    (or (ipmask-cidl-slash (ipnet-width ipn) mask)
+	    (or (ipmask-cidr-slash (ipnet-width ipn) mask)
 		(ipaddr-string (make-instance (class-of net) :addr mask))))))
 
 (defmethod print-object ((ipn ipnet) stream)
-  (print-unreadable-object (ipn stream :type t)
-    (write-string (ipnet-string ipn) stream)))
+  (if *print-escape*
+      (print-unreadable-object (ipn stream :type t)
+	(write-string (ipnet-string ipn) stream))
+      (write-string (ipnet-string ipn) stream)))
 
 (defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t))
   "Parse a subnet description from (a substring of) STR.
@@ -425,7 +484,7 @@
   (let* ((addr-class (extract-class-name (ipnet-net ipn)))
 	 (width (ipaddr-width addr-class))
 	 (max (- width
-		 (or (ipmask-cidl-slash width (ipnet-mask ipn))
+		 (or (ipmask-cidr-slash width (ipnet-mask ipn))
 		     (error "Base network has complex netmask")))))
     (multiple-value-bind (addr mask)
 	(parse-subnet addr-class width max (stringify str)
@@ -631,6 +690,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 +931,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 +954,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)))))
 
 ;;;--------------------------------------------------------------------------
@@ -889,7 +1166,9 @@
 				 (cons ipn ipns)))
 			   ipns
 			   :initial-value nil)))
-      (or merged (error "No matching addresses.")))))
+      (or merged
+	  (error "No addresses match ~S~:[ in family ~S~;~*~]."
+		 form (eq family t) family)))))
 
 (export 'net-host)
 (defun net-host (net-form host &optional (family t))
@@ -1006,7 +1285,8 @@
 						   :initial-value nil))
 		     (car list))))
       (unless (host-addrs host)
-	(error "No matching addresses."))
+	(error "No addresses match ~S~:[ in family ~S~;~*~]."
+	       addr (eq family t) family))
       host)))
 
 (export 'host-create)