;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;;--------------------------------------------------------------------------
+;;; Packaging.
+
(defpackage #:zone
(:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:mdw.safely)
(:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
#:defrevzone #:zone-save
#:defzoneparse #:zone-parse-host
#:timespec-seconds #:make-zone-serial))
+
(in-package #:zone)
+;;;--------------------------------------------------------------------------
+;;; Basic types.
+
(defun mask (n)
"Return 2^N - 1: i.e., a mask of N set bits."
(1- (ash 1 n)))
"The type of IP (version 4) addresses."
'u32)
+;;;--------------------------------------------------------------------------
+;;; Various random utilities.
+
+(defun to-integer (x)
+ "Convert X to an integer in the most straightforward way."
+ (floor (rational x)))
+
+(defun from-mixed-base (base val)
+ "BASE is a list of the ranges for the `digits' of a mixed-base
+representation. Convert VAL, a list of digits, into an integer."
+ (do ((base base (cdr base))
+ (val (cdr val) (cdr val))
+ (a (car val) (+ (* a (car base)) (car val))))
+ ((or (null base) (null val)) a)))
+
+(defun to-mixed-base (base val)
+ "BASE is a list of the ranges for the `digits' of a mixed-base
+representation. Convert VAL, an integer, into a list of digits."
+ (let ((base (reverse base))
+ (a nil))
+ (loop
+ (unless base
+ (push val a)
+ (return a))
+ (multiple-value-bind (q r) (floor val (pop base))
+ (push r a)
+ (setf val q)))))
+
+(defun timespec-seconds (ts)
+ "Convert a timespec TS to seconds. A timespec may be a real count of
+seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
+units."
+ (cond ((null ts) 0)
+ ((realp ts) (floor ts))
+ ((atom ts)
+ (error "Unknown timespec format ~A" ts))
+ ((null (cdr ts))
+ (timespec-seconds (car ts)))
+ (t (+ (to-integer (* (car ts)
+ (case (intern (string-upcase
+ (stringify (cadr ts)))
+ '#:zone)
+ ((s sec secs second seconds) 1)
+ ((m min mins minute minutes) 60)
+ ((h hr hrs hour hours) #.(* 60 60))
+ ((d dy dys day days) #.(* 24 60 60))
+ ((w wk wks week weeks) #.(* 7 24 60 60))
+ ((y yr yrs year years) #.(* 365 24 60 60))
+ (t (error "Unknown time unit ~A"
+ (cadr ts))))))
+ (timespec-seconds (cddr ts))))))
+
+(defun hash-table-keys (ht)
+ "Return a list of the keys in hashtable HT."
+ (collecting ()
+ (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
+
+(defun iso-date (&optional time &key datep timep (sep #\ ))
+ "Construct a textual date or time in ISO format. The TIME is the universal
+time to convert, which defaults to now; DATEP is whether to emit the date;
+TIMEP is whether to emit the time, and SEP (default is space) is how to
+separate the two."
+ (multiple-value-bind
+ (sec min hr day mon yr dow dstp tz)
+ (decode-universal-time (if (or (null time) (eq time :now))
+ (get-universal-time)
+ time))
+ (declare (ignore dow dstp tz))
+ (with-output-to-string (s)
+ (when datep
+ (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
+ (when timep
+ (write-char sep s)))
+ (when timep
+ (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
+
+;;;--------------------------------------------------------------------------
+;;; Simple messing with IP addresses.
+
(defun string-ipaddr (str &key (start 0) (end nil))
"Parse STR as an IP address in dotted-quad form and return the integer
equivalent. STR may be anything at all: it's converted as if by
(unless (= noct 4)
(error "Wrong number of octets in IP address"))
addr))
+
(defun ipaddr-byte (ip n)
"Return byte N (from most significant downwards) of an IP address."
(assert (<= 0 n 3))
(logand #xff (ash ip (* -8 (- 3 n)))))
+
(defun ipaddr-string (ip)
"Transform the address IP into a string in dotted-quad form."
(check-type ip ipaddr)
(join-strings #\. (collecting ()
(dotimes (i 4)
(collect (ipaddr-byte ip i))))))
+
(defun ipaddrp (ip)
"Answer true if IP is a valid IP address in integer form."
(typep ip 'ipaddr))
+
(defun ipaddr (ip)
"Convert IP to an IP address. If it's an integer, return it unchanged;
otherwise convert by `string-ipaddr'."
(ipaddr ip)
(t (string-ipaddr ip))))
+;;;--------------------------------------------------------------------------
+;;; Netmasks.
+
(defun integer-netmask (i)
"Given an integer I, return a netmask with its I top bits set."
(- (ash 1 32) (ash 1 (- 32 i))))
+
(defun ipmask (ip)
"Transform IP into a netmask. If it's a small integer then it's converted
by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
(null (mask 32))
((integer 0 32) (integer-netmask ip))
(t (ipaddr ip))))
+
(defun ipmask-cidl-slash (mask)
"Given a netmask MASK, return an integer N such that (integer-netmask N) =
MASK, or nil if this is impossible."
(when (= mask (integer-netmask i))
(return i))))
+;;;--------------------------------------------------------------------------
+;;; Networks: pairing an address and netmask.
+
(defun make-ipnet (net mask)
"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 mask)))
(cons (logand net mask) mask)))
+
(defun string-ipnet (str &key (start 0) (end nil))
"Parse an IP-network from the string STR."
(setf str (stringify str))
:end end))))
(make-ipnet (parse-ipaddr (subseq str start end))
(integer-netmask 32)))))
+
(defun ipnet (net &optional mask)
"Construct an IP-network object from the given arguments. A number of
forms are acceptable:
(cond (mask (make-ipnet net mask))
((or (stringp net) (symbolp net)) (string-ipnet net))
(t (apply #'make-ipnet (pairify net 32)))))
+
(defun ipnet-net (ipn)
"Return the base network address of IPN."
(car ipn))
+
(defun ipnet-mask (ipn)
"Return the netmask of IPN."
(cdr ipn))
+
(defmacro with-ipnet ((net mask) ipn &body body)
"Evaluate BODY with NET and MASK bound to the base address and netmask of
IPN. Either NET or MASK (or, less usefully, both) may be nil if not wanted."
(let (,@(and net `((,net (ipnet-net ,tmp))))
,@(and mask `((,mask (ipnet-mask ,tmp)))))
,@body))))
+
(defun ipnet-pretty (ipn)
"Convert IPN to a pretty cons-cell form."
(with-ipnet (net mask) ipn
(cons (ipaddr-string net)
(or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
+
(defun ipnet-string (ipn)
"Convert IPN to a string."
(with-ipnet (net mask) ipn
(format nil "~A/~A"
(ipaddr-string net)
(or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
+
(defun ipnet-broadcast (ipn)
"Return the broadcast address for the network IPN."
(with-ipnet (net mask) ipn
(logior net (logxor (mask 32) mask))))
+
(defun ipnet-hosts (ipn)
"Return the number of available addresses in network IPN."
(ash 1 (- 32 (logcount (ipnet-mask ipn)))))
+
(defun ipnet-host (ipn host)
"Return the address of the given HOST in network IPN. This works even with
a non-contiguous netmask."
(setf h (logandc2 h m))))
(setf m (ash m 1))
(incf i)))))
+
(defun ipaddr-networkp (ip ipn)
"Returns true if address IP is within network IPN."
(with-ipnet (net mask) ipn
(= net (logand ip mask))))
+
(defun ipnet-subnetp (ipn subn)
"Returns true if SUBN is a (non-strict) subnet of IPN."
(with-ipnet (net mask) ipn
(and (= net (logand subnet mask))
(= submask (logior mask submask))))))
+(defun ipnet-changeable-bytes (mask)
+ "Answers how many low-order bytes of MASK are (entirely or partially)
+changeable. This is used when constructing reverse zones."
+ (dotimes (i 4 4)
+ (when (/= (ipaddr-byte mask i) 255)
+ (return (- 4 i)))))
+
+;;;--------------------------------------------------------------------------
+;;; Name resolution.
+
+#+cmu
(defun resolve-hostname (name)
"Resolve a hostname to an IP address using the DNS, or return nil."
(let ((he (ext:lookup-host-entry name)))
(and he
(ext:host-entry-addr he))))
+
+#+cmu
(defun canonify-hostname (name)
"Resolve a hostname to canonical form using the DNS, or return nil."
(let ((he (ext:lookup-host-entry name)))
(and he
(ext:host-entry-name he))))
+
+;;;--------------------------------------------------------------------------
+;;; Host names and specifiers.
+
(defun parse-ipaddr (addr)
"Convert the string ADDR into an IP address: tries all sorts of things:
(defvar *hosts* (make-hash-table :test #'equal)
"The table of known hostnames.")
+
(defun host-find (name)
"Find a host by NAME."
(gethash (string-downcase (stringify name)) *hosts*))
+
(defun (setf host-find) (addr name)
"Make NAME map to ADDR (must be an ipaddr in integer form)."
(setf (gethash (string-downcase (stringify name)) *hosts*) addr))
+
(defun host-create (name addr)
"Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
(setf (host-find name) (parse-ipaddr addr)))
+
(defmacro defhost (name addr)
"Main host definition macro. Neither NAME nor ADDR is evaluated."
`(progn
(host-create ',name ',addr)
',name))
+;;;--------------------------------------------------------------------------
+;;; Network names and specifiers.
+
(defstruct (net (:predicate netp))
"A network structure. Slots:
(defvar *networks* (make-hash-table :test #'equal)
"The table of known networks.")
+
(defun net-find (name)
"Find a network by NAME."
(gethash (string-downcase (stringify name)) *networks*))
+
(defun (setf net-find) (net name)
"Make NAME map to NET."
(setf (gethash (string-downcase (stringify name)) *networks*) net))
+
(defun net-get-as-ipnet (form)
"Transform FORM into an ipnet. FORM may be a network name, or something
acceptable to the ipnet function."
(let ((net (net-find form)))
(if net (net-ipnet net)
(ipnet form))))
+
(defun net-create (name &rest args)
"Construct a new network called NAME and add it to the map. The ARGS
describe the new network, in a form acceptable to the ipnet function."
:ipnet ipn
:hosts (ipnet-hosts ipn)
:next 1))))
+
(defmacro defnet (name &rest args)
"Main network definition macro. Neither NAME nor any of the ARGS is
evaluated."
`(progn
(net-create ',name ,@(mapcar (lambda (x) `',x) args))
',name))
+
(defun net-next-host (net)
"Given a NET, return the IP address (as integer) of the next available
address in the network."
(let ((next (net-next net)))
(incf (net-next net))
(net-host net next)))
+
(defun net-host (net host)
"Return the given HOST on the NEXT. HOST may be an index (in range, of
course), or one of the keywords:
(:broadcast (ipnet-broadcast (net-ipnet net)))
(t (ipnet-host (net-ipnet net) host))))
-(defun to-integer (x)
- "Convert X to an integer in the most straightforward way."
- (floor (rational x)))
-(defun timespec-seconds (ts)
- "Convert a timespec TS to seconds. A timespec may be a real count of
-seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
-units."
- (cond ((null ts) 0)
- ((realp ts) (floor ts))
- ((atom ts)
- (error "Unknown timespec format ~A" ts))
- ((null (cdr ts))
- (timespec-seconds (car ts)))
- (t (+ (to-integer (* (car ts)
- (case (intern (string-upcase
- (stringify (cadr ts)))
- '#:zone)
- ((s sec secs second seconds) 1)
- ((m min mins minute minutes) 60)
- ((h hr hrs hour hours) #.(* 60 60))
- ((d dy dys day days) #.(* 24 60 60))
- ((w wk wks week weeks) #.(* 7 24 60 60))
- ((y yr yrs year years) #.(* 365 24 60 60))
- (t (error "Unknown time unit ~A"
- (cadr ts))))))
- (timespec-seconds (cddr ts))))))
+;;;--------------------------------------------------------------------------
+;;; Zone types.
(defstruct (soa (:predicate soap))
"Start-of-authority record information."
expire
min-ttl
serial)
+
(defstruct (mx (:predicate mxp))
"Mail-exchange record information."
priority
domain)
+
(defstruct (zone (:predicate zonep))
"Zone information."
soa
name
records)
+;;;--------------------------------------------------------------------------
+;;; Zone defaults. It is intended that scripts override these.
+
(defvar *default-zone-source*
(let ((hn (unix:unix-gethostname)))
(and hn (concatenate 'string (canonify-hostname hn) ".")))
"The default zone source: the current host's name.")
+
(defvar *default-zone-refresh* (* 24 60 60)
"Default zone refresh interval: one day.")
+
(defvar *default-zone-admin* nil
"Default zone administrator's email address.")
+
(defvar *default-zone-retry* (* 60 60)
"Default znoe retry interval: one hour.")
+
(defvar *default-zone-expire* (* 14 24 60 60)
"Default zone expiry time: two weeks.")
+
(defvar *default-zone-min-ttl* (* 4 60 60)
"Default zone minimum TTL/negative TTL: four hours.")
+
(defvar *default-zone-ttl* (* 8 60 60)
"Default zone TTL (for records without explicit TTLs): 8 hours.")
+
(defvar *default-mx-priority* 50
"Default MX priority.")
-(defun from-mixed-base (base val)
- "BASE is a list of the ranges for the `digits' of a mixed-base
-representation. Convert VAL, a list of digits, into an integer."
- (do ((base base (cdr base))
- (val (cdr val) (cdr val))
- (a (car val) (+ (* a (car base)) (car val))))
- ((or (null base) (null val)) a)))
-(defun to-mixed-base (base val)
- "BASE is a list of the ranges for the `digits' of a mixed-base
-representation. Convert VAL, an integer, into a list of digits."
- (let ((base (reverse base))
- (a nil))
- (loop
- (unless base
- (push val a)
- (return a))
- (multiple-value-bind (q r) (floor val (pop base))
- (push r a)
- (setf val q)))))
+;;;--------------------------------------------------------------------------
+;;; Serial numbering.
(defun make-zone-serial (name)
"Given a zone NAME, come up with a new serial number. This will (very
(cons seq now)))
(from-mixed-base '(100 100 100) (reverse (cons seq now)))))
+;;;--------------------------------------------------------------------------
+;;; Zone variables and structures.
+
(defvar *zones* (make-hash-table :test #'equal)
"Map of known zones.")
+
(defun zone-find (name)
"Find a zone given its NAME."
(gethash (string-downcase (stringify name)) *zones*))
+
(defun (setf zone-find) (zone name)
"Make the zone NAME map to ZONE."
(setf (gethash (string-downcase (stringify name)) *zones*) zone))
ttl
records)
+;;;--------------------------------------------------------------------------
+;;; Zone infrastructure.
+
(defun zone-process-records (rec ttl func)
"Sort out the list of records in REC, calling FUNC for each one. TTL is
the default time-to-live for records which don't specify one."
(string-downcase (subseq f 0 (1- (length f)))))
(t (string-downcase (concatenate 'string f "."
(stringify zname))))))
-(defun ipnet-changeable-bytes (mask)
- "Answers how many low-order bytes of MASK are (entirely or partially)
-changeable. This is used when constructing reverse zones."
- (dotimes (i 4 4)
- (when (/= (ipaddr-byte mask i) 255)
- (return (- 4 i)))))
(defun default-rev-zone (base bytes)
+ "Return the default reverse-zone name for the given BASE address and number
+of fixed leading BYTES."
(join-strings #\. (collecting ()
(loop for i from (- 3 bytes) downto 0
do (collect (ipaddr-byte base i)))
for i from (- 4 bytes) below 4
collect (logand #xff (ash net (* -8 i))))
(list "in-addr.arpa"))))))
-
+
(defun zone-net-from-name (name)
"Given a NAME in the in-addr.arpa space, convert it to an ipnet."
(let* ((name (string-downcase (stringify name)))
:data (join-strings #\. (list tail tdom)))
list)))))))
-
+;;;--------------------------------------------------------------------------
+;;; Zone form parsing.
(defun zone-parse-head (head)
"Parse the HEAD of a zone form. This has the form
:min-ttl (timespec-seconds min-ttl)
:serial serial))))
-(defun hash-table-keys (ht)
- "Return a list of the keys in hashtable HT."
- (collecting ()
- (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
-
(defmacro defzoneparse (types (name data list
&key (zname (gensym "ZNAME"))
(ttl (gensym "TTL"))
(defsubp (gensym "DEFSUBP")))
&body body)
+ "Define a new zone record type (or TYPES -- a list of synonyms is
+permitted). The arguments are as follows:
+
+NAME The name of the record to be added.
+
+DATA The content of the record to be added (a single object, unevaluated).
+
+LIST A function to add a record to the zone. See below.
+
+ZNAME The name of the zone being constructed.
+
+TTL The TTL for this record.
+
+DEFSUBP Whether this is the default subdomain for this entry.
+
+You get to choose your own names for these. ZNAME, TTL and DEFSUBP are
+optional: you don't have to accept them if you're not interested.
+
+The LIST argument names a function to be bound in the body to add a new
+low-level record to the zone. It has the prototype
+
+ (LIST &key :name :type :data :ttl :defsubp)
+
+Except for defsubp, these 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))))
(zone-parse-records zone (cdr zf))
zone)))
+(defun zone-create (zf)
+ "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)))
+ (setf (zone-find name) zone)
+ name))
+
+(defmacro defzone (soa &rest zf)
+ "Zone definition macro."
+ `(zone-create '(,soa ,@zf)))
+
+(defmacro defrevzone (head &rest zf)
+ "Define a reverse zone, with the correct name."
+ (destructuring-bind
+ (net &rest soa-args)
+ (listify head)
+ (let ((bytes nil))
+ (when (and soa-args (integerp (car soa-args)))
+ (setf bytes (pop soa-args)))
+ `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
+
+;;;--------------------------------------------------------------------------
+;;; Zone record parsers.
+
(defzoneparse :a (name data rec :defsubp defsubp)
":a IPADDR"
(rec :data (parse-ipaddr data) :defsubp defsubp))
+
(defzoneparse :ptr (name data rec :zname zname)
":ptr HOST"
(rec :data (zone-parse-host data zname)))
+
(defzoneparse :cname (name data rec :zname zname)
":cname HOST"
(rec :data (zone-parse-host data zname)))
+
(defzoneparse :mx (name data rec :zname zname)
":mx ((HOST :prio INT :ip IPADDR)*)"
(dolist (mx (listify data))
(let ((host (zone-parse-host mxname zname)))
(when ip (rec :name host :type :a :data (parse-ipaddr ip)))
(rec :data (cons host prio))))))
+
(defzoneparse :ns (name data rec :zname zname)
":ns ((HOST :ip IPADDR)*)"
(dolist (ns (listify data))
(let ((host (zone-parse-host nsname zname)))
(when ip (rec :name host :type :a :data (parse-ipaddr ip)))
(rec :data host)))))
+
(defzoneparse :alias (name data rec :zname zname)
":alias (LABEL*)"
(dolist (a (listify data))
(rec :name (zone-parse-host a zname)
:type :cname
:data name)))
+
(defzoneparse :net (name data rec)
":net (NETWORK*)"
(dolist (net (listify data))
:type :cname
:data (format nil "~A.~A" tail tdom))))))))
-(defun iso-date (&optional time &key datep timep (sep #\ ))
- "Construct a textual date or time in ISO format. The TIME is the universal
-time to convert, which defaults to now; DATEP is whether to emit the date;
-TIMEP is whether to emit the time, and SEP (default is space) is how to
-separate the two."
- (multiple-value-bind
- (sec min hr day mon yr dow dstp tz)
- (decode-universal-time (if (or (null time) (eq time :now))
- (get-universal-time)
- time))
- (declare (ignore dow dstp tz))
- (with-output-to-string (s)
- (when datep
- (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
- (when timep
- (write-char sep s)))
- (when timep
- (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
+;;;--------------------------------------------------------------------------
+;;; Zone file output.
(defun zone-write (zone &optional (stream *standard-output*))
"Write a ZONE's records to STREAM."
(printrec zr)
(format stream "~S~%" (stringify (zr-data zr))))))))
-(defun zone-create (zf)
- "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)))
- (setf (zone-find name) zone)
- name))
-(defmacro defzone (soa &rest zf)
- "Zone definition macro."
- `(zone-create '(,soa ,@zf)))
-(defmacro defrevzone (head &rest zf)
- "Define a reverse zone, with the correct name."
- (destructuring-bind
- (net &rest soa-args)
- (listify head)
- (let ((bytes nil))
- (when (and soa-args (integerp (car soa-args)))
- (setf bytes (pop soa-args)))
- `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
-
-
(defun zone-save (zones)
"Write the named ZONES to files. If no zones are given, write all the
zones."
~mdw / zone / commitdiff