X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/88867b1a56e50b1a208b052dd75451143f92b7ae..HEAD:/net.lisp diff --git a/net.lisp b/net.lisp index 90e30aa..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. @@ -140,26 +195,46 @@ "Base class for IP addresses.")) (export 'ipaddr-family) -(defgeneric ipaddr-family (addr)) +(defgeneric ipaddr-family (addr) + (:documentation "Return the address family of ADDR, as a keyword.")) (export 'family-addrclass) (defgeneric family-addrclass (family) + (:documentation "Convert the keyword FAMILY into an `ipaddr' subclass.") (:method ((af symbol)) nil)) (export 'ipaddr-width) (defgeneric ipaddr-width (class) + (:documentation "Return the width, in bits, of addresses from CLASS. + + Alternatively, the CLASS may be given as an example object.") (:method ((object t)) (ipaddr-width (extract-class-name object)))) (export 'ipaddr-comparable-p) (defgeneric ipaddr-comparable-p (addr-a addr-b) + (:documentation "Is it meaningful to compare ADDR-A and ADDR-B?") (:method ((addr-a ipaddr) (addr-b ipaddr)) (eq (class-of addr-a) (class-of addr-b)))) (defun guess-address-class (str &key (start 0) (end nil)) + "Return a class name for the address in (the given substring of) STR. + + This ought to be an extension point for additional address families, but + it isn't at the moment." (cond ((position #\: str :start start :end end) 'ip6addr) (t 'ip4addr))) (defgeneric parse-partial-ipaddr (class str &key start end min max) + (:documentation + "Parse (a substring of) STR into a partial address of the given CLASS. + + Returns three values: the parsed address fragment, as an integer; and the + low and high bit positions covered by the response. + + The CLASS may instead be an example object of the required class. The MIN + and MAX arguments bound the number of bits acceptable in the response; the + result is shifted so that the most significant component of the returned + address is in the same component as bit position MAX.") (:method ((object t) str &rest keywords) (apply #'parse-partial-ipaddr (extract-class-name object) str keywords))) @@ -191,12 +266,13 @@ (export 'ipaddr-string) (defgeneric ipaddr-string (ip) - (:documentation - "Transform the address IP into a string in dotted-quad form.")) + (: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) @@ -225,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 @@ -263,6 +339,7 @@ (export 'ipnet-family) (defgeneric ipnet-family (ipn) + (:documentation "Return the address family of IPN, as a keyword.") (:method ((ipn ipnet)) (ipaddr-family (ipnet-net ipn)))) (export 'ipnet-addr) @@ -276,8 +353,9 @@ (export 'make-ipnet) (defun make-ipnet (net mask) - "Construct an IP-network object given the NET and MASK; these are - transformed as though by `ipaddr' and `ipmask'." + "Construct an IP-network object given the NET and MASK. + + These are transformed as though by `ipaddr' and `ipmask'." (let* ((net (ipaddr net)) (mask (ipmask net mask))) (ipaddr-ipnet (mask-ipaddr net mask) mask))) @@ -308,15 +386,33 @@ (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." + "Parse a subnet description from (a substring of) STR. + + Suppose we have a parent network, with a prefix length of MAX. The WIDTH + gives the overall length of addresses of the appropriate class, i.e., + (ipaddr-width WIDTH), but in fact callers have already computed this for + their own reasons. + + Parse (the designated substring of) STR to construct the base address of a + subnet. The string should have the form BASE/MASK, where the MASK is + either a literal bitmask (in the usual syntax for addresses) or an integer + prefix length. An explicit prefix length is expected to cover the entire + address including the parent prefix: an error is signalled if the prefix + isn't long enough to cover any of the subnet. A mask is parsed relative + to the end of the parent address, just as the subnet base address is. + + Returns the relative base address and mask as two integer values." + (setf-default end (length str)) (let ((sl (and slashp (position #\/ str :start start :end end)))) (multiple-value-bind (addr lo hi) @@ -360,7 +456,11 @@ (export 'string-ipnet) (defun string-ipnet (str &key (start 0) (end nil)) - "Parse an IP-network from the string STR." + "Parse an IP network description from the string STR. + + A network description has the form ADDRESS/MASK, where the ADDRESS is a + base address in numeric form, and the MASK is either a netmask in the same + form, or an integer prefix length." (setf str (stringify str)) (setf-default end (length str)) (let ((addr-class (guess-address-class str :start start :end end))) @@ -374,11 +474,17 @@ (defun parse-subipnet (ipn str &key (start 0) (end nil) (slashp t)) "Parse STR as a subnet of IPN. - This is mostly a convenience interface over `parse-subnet'." + This is mostly a convenience interface over `parse-subnet'; we compute + various of the parameters from IPN rather than requiring them to be passed + in explicitly. + + Returns two values: the combined base address, as an `ipnaddr' and + combined mask, as an integer." + (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) @@ -387,7 +493,21 @@ (export 'string-subipnet) (defun string-subipnet (ipn str &key (start 0) (end nil)) - "Parse an IP subnet from a parent net IPN and a suffix string STR." + "Parse an IP subnet from a parent net IPN and a suffix string STR. + + The (substring of) STR is expected to have the form ADDRESS/MASK, where + ADDRESS is a relative subnet base address, and MASK is either a relative + subnet mask or a (full) prefix length. Returns the resulting ipnet. If + the relative base address overlaps with the existing subnet (because the + base network's prefix length doesn't cover a whole number of components), + then the subnet base must either agree in the overlapping portion with the + parent base address or be zero. + + For example, if IPN is the network 172.29.0.0/16, then `199/24' or + `199/255' both designate the subnet 172.29.199.0/24. Similarly, starting + from 2001:ba8:1d9:8000::/52, then `8042/ffff' and `42/64' both designate + the network 2001:ba8:1d9:8042::/64." + (multiple-value-bind (addr mask) (parse-subipnet ipn str :start start :end end) (ipaddr-ipnet addr mask))) @@ -570,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) @@ -593,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) @@ -616,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))))) ;;;-------------------------------------------------------------------------- @@ -776,8 +1114,38 @@ (process-net-form name net subnets)) ',name)) +(defun filter-by-family (func form family) + "Handle a family-switch form. + + Here, FUNC is a function of two arguments ITEM and FAMILY. FORM is either + a list of the form ((FAMILY . ITEM) ...), or an ITEM which is directly + acceptable to FUNC. Return a list of the resulting outputs of FUNC." + + (if (and (listp form) + (every (lambda (clause) + (and (listp clause) + (family-addrclass (car clause)))) + form)) + (mapcan (lambda (clause) + (let ((fam (car clause))) + (and (or (eq family t) + (eq family fam)) + (list (funcall func (cdr clause) fam))))) + form) + (list (funcall func form family)))) + (export 'net-parse-to-ipnets) (defun net-parse-to-ipnets (form &optional (family t)) + "Parse FORM into a list of ipnet objects. + + The FORM can be any of the following. + + * NAME -- a named network, established using `net-create' or `defnet' + + * IPNET -- a network, in a form acceptable to `ipnet' + + * ((FAMILY . FORM) ...) -- a sequence of networks, filtered by FAMILY" + (flet ((hack (form family) (let* ((form (if (and (consp form) (endp (cdr form))) @@ -790,18 +1158,7 @@ (remove family ipns :key #'ipnet-family :test-not #'eq))))) - (let* ((ipns (if (and (listp form) - (every (lambda (clause) - (and (listp clause) - (symbolp (car clause)) - (or (eq (car clause) t) - (family-addrclass - (car clause))))) - form)) - (mappend (lambda (clause) - (hack (cdr clause) (car clause))) - form) - (hack form family))) + (let* ((ipns (apply #'append (filter-by-family #'hack form family))) (merged (reduce (lambda (ipns ipn) (if (find (ipnet-family ipn) ipns :key #'ipnet-family) @@ -809,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)) @@ -917,29 +1276,17 @@ (net-host (car form) (cadr form) family)) (t (filter-addresses (list (ipaddr indic)) family)))))) - (let ((host (cond - ((not (eq family t)) - (hack addr family)) - ((and (listp addr) - (every (lambda (clause) - (and (listp clause) - (symbolp (car clause)) - (or (eq (car clause) t) - (family-addrclass (car clause))))) - addr)) - (make-instance 'host - :addrs (reduce #'merge-addresses - (mapcar - (lambda (clause) - (host-addrs - (hack (cdr clause) - (car clause)))) - (reverse addr)) - :initial-value nil))) - (t - (hack addr t))))) + (let* ((list (filter-by-family #'hack addr family)) + (host (if (and list (cdr list)) + (make-instance 'host + :addrs (reduce #'merge-addresses + (mapcar #'host-addrs + (reverse list)) + :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)