X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/9f408c6016659a51546516b41c96e926bace3847..db43369d61d700b1d0100998a2d9ecefe28ff8d4:/zone.lisp?ds=sidebyside diff --git a/zone.lisp b/zone.lisp index f4f2367..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) @@ -1342,6 +1259,7 @@ $TTL ~2@*~D~2%" ;;;-------------------------------------------------------------------------- ;;; tinydns-data output format. +(export 'tinydns-output) (defun tinydns-output (code &rest fields) (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))