X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/a567a3bce51edcee4bd83afd9eea82ea42b2ce1f..cc0fa47a50532786e202ee24c6518e50ba6959e2:/zone.lisp diff --git a/zone.lisp b/zone.lisp index c830a11..ea9fda3 100644 --- a/zone.lisp +++ b/zone.lisp @@ -27,7 +27,9 @@ ;;; Packaging. (defpackage #:zone - (:use #:common-lisp #:mdw.base #:mdw.str #:collect #:safely #:net) + (:use #:common-lisp + #:mdw.base #:mdw.str #:collect #:safely + #:net #:services) (:export #:soa #:mx #:zone #:zone-record #:zone-subdomain #:*default-zone-source* #:*default-zone-refresh* #:*default-zone-retry* #:*default-zone-expire* @@ -379,46 +381,6 @@ (defun zone-cidr-delg-default-name (ipn bytes) until (zerop (logand mask (ash #xff (* 8 i)))) collect (logand #xff (ash net (* -8 i)))))))) -(defun zone-cidr-delegation (data name ttl list) - "Given :cidr-delegation info DATA, for a record called NAME and the current - TTL, write lots of CNAME records to LIST." - (destructuring-bind - (net &key bytes) - (listify (car data)) - (setf net (zone-parse-net net name)) - (unless bytes - (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) - (dolist (map (cdr data)) - (destructuring-bind - (tnet &optional tdom) - (listify map) - (setf tnet (zone-parse-net tnet name)) - (unless (ipnet-subnetp net tnet) - (error "~A is not a subnet of ~A." - (ipnet-pretty tnet) - (ipnet-pretty net))) - (unless tdom - (setf tdom - (join-strings #\. - (list (zone-cidr-delg-default-name tnet bytes) - name)))) - (setf tdom (string-downcase tdom)) - (dotimes (i (ipnet-hosts tnet)) - (let* ((addr (ipnet-host tnet i)) - (tail (join-strings #\. - (loop - for i from 0 below bytes - collect - (logand #xff - (ash addr (* 8 i))))))) - (collect (make-zone-record - :name (join-strings #\. - (list tail name)) - :type :cname - :ttl ttl - :data (join-strings #\. (list tail tdom))) - list))))))) - ;;;-------------------------------------------------------------------------- ;;; Serial numbering. @@ -538,6 +500,7 @@ (defun ,func (,prefix ,zname ,data ,ttl ,col) ((:data ,tdata) ,data) ((:ttl ,tttl) ,ttl) ((:make-ptr-p ,tmakeptrp) nil)) + #+cmu (declare (optimize ext:inhibit-warnings)) (collect (make-zone-record :name ,tname :type ,ttype :data ,tdata @@ -651,6 +614,31 @@ (defzoneparse :alias (name data rec :zname zname) :type :cname :data name))) +(defzoneparse :srv (name data rec :zname zname) + ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)" + (dolist (srv data) + (destructuring-bind (servopts &rest providers) srv + (destructuring-bind + (service &key ((:port default-port)) (protocol :tcp)) + (listify servopts) + (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))) + (dolist (prov providers) + (destructuring-bind + (srvname + &key + (port default-port) + (prio *default-mx-priority*) + (weight 0) + ip) + (listify prov) + (let ((host (zone-parse-host srvname zname))) + (when ip (rec :name host :type :a :data (parse-ipaddr ip))) + (rec :name rname + :data (list prio weight port host)))))))))) + (defzoneparse :net (name data rec) ":net (NETWORK*)" (dolist (net (listify data)) @@ -668,9 +656,7 @@ (defzoneparse :net (name data rec) (defzoneparse (:rev :reverse) (name data rec) ":reverse ((NET :bytes BYTES) ZONE*)" (setf data (listify data)) - (destructuring-bind - (net &key bytes) - (listify (car data)) + (destructuring-bind (net &key bytes) (listify (car data)) (setf net (zone-parse-net net name)) (unless bytes (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) @@ -694,18 +680,15 @@ (defzoneparse (:rev :reverse) (name data rec) :ttl (zr-ttl zr) :data (zr-name zr)) (setf (gethash name seen) t))))))))) -(defzoneparse (:cidr-delegation :cidr) (name data rec) +(defzoneparse (:cidr-delegation :cidr) (name data rec :zname zname) ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)" - (destructuring-bind - (net &key bytes) - (listify (car data)) + (setf data (listify data)) + (destructuring-bind (net &key bytes) (listify (car data)) (setf net (zone-parse-net net name)) (unless bytes (setf bytes (ipnet-changeable-bytes (ipnet-mask net)))) - (dolist (map (cdr data)) - (destructuring-bind - (tnet &optional tdom) - (listify map) + (dolist (map (or (cdr data) (list (list net)))) + (destructuring-bind (tnet &optional tdom) (listify map) (setf tnet (zone-parse-net tnet name)) (unless (ipnet-subnetp net tnet) (error "~A is not a subnet of ~A." @@ -717,25 +700,25 @@ (defzoneparse (:cidr-delegation :cidr) (name data rec) (join-strings #\. (append (reverse (loop - for i from (1- bytes) downto 0 - until (zerop (logand mask - (ash #xff - (* 8 i)))) - collect (logand #xff - (ash net (* -8 i))))) + for i from (1- bytes) downto 0 + until (zerop (logand mask + (ash #xff + (* 8 i)))) + collect (ldb (byte 8 (* i 8)) net))) (list name)))))) - (setf tdom (string-downcase tdom)) + (setf tdom (string-downcase (stringify tdom))) (dotimes (i (ipnet-hosts tnet)) - (let* ((addr (ipnet-host tnet i)) - (tail (join-strings #\. - (loop + (unless (zerop i) + (let* ((addr (ipnet-host tnet i)) + (tail (join-strings #\. + (loop for i from 0 below bytes collect - (logand #xff - (ash addr (* 8 i))))))) - (rec :name (format nil "~A.~A" tail name) - :type :cname - :data (format nil "~A.~A" tail tdom)))))))) + (logand #xff + (ash addr (* 8 i))))))) + (rec :name (format nil "~A.~A" tail name) + :type :cname + :data (format nil "~A.~A" tail tdom))))))))) ;;;-------------------------------------------------------------------------- ;;; Zone file output. @@ -849,6 +832,9 @@ (defgeneric bind-record-format-args (type data) (:method ((type (eql :ns)) data) (list "~A" (bind-hostname data))) (:method ((type (eql :mx)) data) (list "~2D ~A" (cdr data) (bind-hostname (car data)))) + (:method ((type (eql :srv)) data) + (destructuring-bind (prio weight port host) data + (list "~2D ~5D ~5D ~A" prio weight port (bind-hostname host)))) (:method ((type (eql :txt)) data) (list "~S" (stringify data)))) ;;;----- That's all, folks --------------------------------------------------