(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
-`stringify'. The START and END arguments may be used to parse out a
-substring."
+ equivalent. STR may be anything at all: it's converted as if by
+ `stringify'. The START and END arguments may be used to parse out a
+ substring."
(setf str (stringify str))
(unless end
(setf end (length str)))
(defun ipaddr (ip)
"Convert IP to an IP address. If it's an integer, return it unchanged;
-otherwise convert by `string-ipaddr'."
+ otherwise convert by `string-ipaddr'."
(typecase ip
(ipaddr ip)
(t (string-ipaddr ip))))
(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
-`ipaddr'."
+ by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
+ `ipaddr'."
(typecase ip
(null (mask 32))
((integer 0 32) (integer-netmask 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."
+ MASK, or nil if this is impossible."
(dotimes (i 33)
(when (= mask (integer-netmask i))
(return i))))
(defun make-ipnet (net mask)
"Construct an IP-network object given the NET and MASK; these are
-transformed as though by `ipaddr' and `ipmask'."
+ transformed as though by `ipaddr' and `ipmask'."
(let ((net (ipaddr net))
(mask (ipmask mask)))
(cons (logand net mask) mask)))
(integer-netmask 32)))))
(defun ipnet (net)
- "Construct an IP-network object from the given argument. A number of
-forms are acceptable:
+ "Construct an IP-network object from the given argument. A number of forms
+ are acceptable:
- * ADDR -- a single address (equivalent to ADDR 32)
- * (NET . MASK|nil) -- a single-object representation.
- * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
+ * ADDR -- a single address (equivalent to ADDR 32)
+ * (NET . MASK|nil) -- a single-object representation.
+ * IPNET -- return an equivalent (`equal', not necessarily `eql')
+ version."
(cond ((or (stringp net) (symbolp net)) (string-ipnet net))
(t (apply #'make-ipnet (pairify net 32)))))
(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."
+ IPN. Either NET or MASK (or, less usefully, both) may be nil if not
+ wanted."
(with-gensyms tmp
`(let ((,tmp ,ipn))
(let (,@(and net `((,net (ipnet-net ,tmp))))
(defun ipnet-host (ipn host)
"Return the address of the given HOST in network IPN. This works even with
-a non-contiguous netmask."
+ a non-contiguous netmask."
(check-type host u32)
(with-ipnet (net mask) ipn
(let ((i 0) (m 1) (a net) (h host))
(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."
+ changeable. This is used when constructing reverse zones."
(dotimes (i 4 4)
(when (/= (ipaddr-byte mask i) 255)
(return (- 4 i)))))
(defun parse-ipaddr (addr)
"Convert the string ADDR into an IP address: tries all sorts of things:
- (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
- INDEX is an index or one of the special symbols understood by net-host,
- and defaults to :next
- INTEGER -- an integer IP address
- IPADDR -- an IP address in dotted-quad form
- HOST -- a host name defined by defhost
- DNSNAME -- a name string to look up in the DNS"
+ (NET [INDEX]) index a network: NET is a network name defined by
+ defnet; INDEX is an index or one of the special
+ symbols understood by net-host, and defaults to :next
+
+ INTEGER an integer IP address
+
+ IPADDR an IP address in dotted-quad form
+
+ HOST a host name defined by defhost
+
+ DNSNAME a name string to look up in the DNS"
(cond ((listp addr)
(destructuring-bind
(net host)
(defstruct (net (:predicate netp))
"A network structure. Slots:
-NAME The network's name, as a string
-IPNET The network base address and mask
-HOSTS Number of hosts in the network
-NEXT Index of the next unassigned host"
+ NAME The network's name, as a string
+ IPNET The network base address and mask
+ HOSTS Number of hosts in the network
+ NEXT Index of the next unassigned host"
name
ipnet
hosts
(defun process-net-form (root addr subnets)
"Unpack a net-form. The return value is a list of entries, each of which
-is a list of the form (NAME ADDR MASK). The first entry is merely repeats
-the given ROOT and ADDR arguments (unpacking ADDR into separate network
-address and mask). The SUBNETS are then processed: they are a list of items
-of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
-NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
-the same form. An error is signalled if a net's subnets use up more hosts
-than the net has to start with."
+ is a list of the form (NAME ADDR MASK). The first entry is merely repeats
+ the given ROOT and ADDR arguments (unpacking ADDR into separate network
+ address and mask). The SUBNETS are then processed: they are a list of
+ items of the form (NAME NUM-HOSTS . SUBNETS), where NAME names the subnet,
+ NUM-HOSTS is the number of hosts in it, and SUBNETS are its sub-subnets in
+ the same form. An error is signalled if a net's subnets use up more hosts
+ than the net has to start with."
(labels ((frob (subnets limit finger)
(when subnets
(destructuring-bind (name size &rest subs) (car subnets)
(defun net-create (name net)
"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."
+ describe the new network, in a form acceptable to the ipnet function."
(let ((ipn (ipnet net)))
(setf (net-find name)
(make-net :name (string-downcase (stringify name))
(defun net-next-host (net)
"Given a NET, return the IP address (as integer) of the next available
-address in the network."
+ address in the network."
(unless (< (net-next net) (net-hosts net))
(error "No more hosts left in network ~A" (net-name net)))
(let ((next (net-next net)))
(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:
-:NEXT next host, as by net-next-host
-:NET network base address
-:BROADCAST network broadcast address"
+ course), or one of the keywords:
+
+ :NEXT next host, as by net-next-host
+ :NET network base address
+ :BROADCAST network broadcast address"
(case host
(:next (net-next-host net))
(:net (ipnet-net (net-ipnet net)))
(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."
+ 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))))
(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."
+ representation. Convert VAL, an integer, into a list of digits."
(let ((base (reverse base))
(a nil))
(loop
(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."
+ 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)
(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."
+ 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))
(defun make-zone-serial (name)
"Given a zone NAME, come up with a new serial number. This will (very
-carefully) update a file ZONE.serial in the current directory."
+ carefully) update a file ZONE.serial in the current directory."
(let* ((file (format nil "~(~A~).serial" name))
(last (with-open-file (in file
:direction :input
(defstruct (zone-subdomain (:conc-name zs-))
"A subdomain. Slightly weird. Used internally by zone-process-records
-below, and shouldn't escape."
+ below, and shouldn't escape."
name
ttl
records)
(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."
+ the default time-to-live for records which don't specify one."
(labels ((sift (rec ttl)
(collecting (top sub)
(loop
(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."
+ otherwise it's relative to ZNAME."
(setf f (stringify f))
(cond ((string= f "@") (stringify zname))
((and (plusp (length f))
(stringify zname))))))
(defun default-rev-zone (base bytes)
"Return the default reverse-zone name for the given BASE address and number
-of fixed leading BYTES."
+ of fixed leading BYTES."
(join-strings #\. (collecting ()
(loop for i from (- 3 bytes) downto 0
do (collect (ipaddr-byte base i)))
(defun zone-name-from-net (net &optional bytes)
"Given a NET, and maybe the BYTES to use, convert to the appropriate
-subdomain of in-addr.arpa."
+ subdomain of in-addr.arpa."
(let ((ipn (net-get-as-ipnet net)))
(with-ipnet (net mask) ipn
(unless bytes
(defun zone-reverse-records (records net list bytes dom)
"Construct a reverse zone given a forward zone's RECORDS list, the NET that
-the reverse zone is to serve, a LIST to collect the records into, how
-many BYTES of data need to end up in the zone, and the DOM-ain suffix."
+ the reverse zone is to serve, a LIST to collect the records into, how many
+ BYTES of data need to end up in the zone, and the DOM-ain suffix."
(dolist (zr records)
(when (and (eq (zr-type zr) :a)
(not (zr-defsubp zr))
(defun zone-reverse (data name list)
"Process a :reverse record's DATA, for a domain called NAME, and add the
-records to the LIST."
+ records to the LIST."
(destructuring-bind
(net &key bytes zones)
(listify data)
name))))
(defun zone-parse-net (net name)
- "Given a NET, and the NAME of a domain to guess from if NET is null,
-return the ipnet for the network."
+ "Given a NET, and the NAME of a domain to guess from if NET is null, return
+ the ipnet for the network."
(if net
(net-get-as-ipnet net)
(zone-net-from-name name)))
(defun zone-cidr-delg-default-name (ipn bytes)
"Given a delegated net IPN and the parent's number of changing BYTES,
-return the default deletate zone prefix."
+ return the default deletate zone prefix."
(with-ipnet (net mask) ipn
(join-strings #\.
(reverse
(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."
+ TTL, write lots of CNAME records to LIST."
(destructuring-bind
(net &key bytes)
(listify (car data))
(NAME &key :source :admin :refresh :retry
:expire :min-ttl :ttl :serial)
-though a singleton NAME needn't be a list. Returns the default TTL and an
-soa structure representing the zone head."
+ though a singleton NAME needn't be a list. Returns the default TTL and an
+ soa structure representing the zone head."
(destructuring-bind
(zname
&key
(defsubp (gensym "DEFSUBP")))
&body body)
"Define a new zone record type (or TYPES -- a list of synonyms is
-permitted). The arguments are as follows:
+ permitted). The arguments are as follows:
-NAME The name of the record to be added.
+ NAME The name of the record to be added.
-DATA The content of the record to be added (a single object, unevaluated).
+ 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.
+ LIST A function to add a record to the zone. See below.
-ZNAME The name of the zone being constructed.
+ ZNAME The name of the zone being constructed.
-TTL The TTL for this record.
+ TTL The TTL for this record.
-DEFSUBP Whether this is the default subdomain for this entry.
+ 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.
+ 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
+ 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)
+ (LIST &key :name :type :data :ttl :defsubp)
-Except for defsubp, these default to the above arguments (even if you didn't
-accept the arguments)."
+ 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))))
(defun zone-parse (zf)
"Parse a ZONE form. The syntax of a zone form is as follows:
-ZONE-FORM:
- ZONE-HEAD ZONE-RECORD*
+ ZONE-FORM:
+ ZONE-HEAD ZONE-RECORD*
-ZONE-RECORD:
- ((NAME*) ZONE-RECORD*)
-| SYM ARGS"
+ ZONE-RECORD:
+ ((NAME*) ZONE-RECORD*)
+ | SYM ARGS"
(multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
(let ((zone (make-zone :name zname
:default-ttl ttl
(defun zone-create (zf)
"Zone construction function. Given a zone form ZF, construct the zone and
-add it to the table."
+ add it to the table."
(let* ((zone (zone-parse zf))
(name (zone-name zone)))
(setf (zone-find name) zone)
(defun zone-save (zones)
"Write the named ZONES to files. If no zones are given, write all the
-zones."
+ zones."
(unless zones
(setf zones (hash-table-keys *zones*)))
(safely (safe)
~mdw / zone / commitdiff