~mdw
/
zone
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
zone: Use new with-parsed-body macro.
[zone]
/
zone.lisp
diff --git
a/zone.lisp
b/zone.lisp
index
79c6c19
..
5755d11
100644
(file)
--- a/
zone.lisp
+++ b/
zone.lisp
@@
-49,7
+49,7
@@
(defun from-mixed-base (base val)
"BASE is a list of the ranges for the `digits' of a mixed-base
(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))))
(do ((base base (cdr base))
(val (cdr val) (cdr val))
(a (car val) (+ (* a (car base)) (car val))))
@@
-57,7
+57,7
@@
representation. Convert VAL, a list of digits, into an integer."
(defun to-mixed-base (base val)
"BASE is a list of the ranges for the `digits' of a mixed-base
(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
(let ((base (reverse base))
(a nil))
(loop
@@
-70,8
+70,8
@@
representation. Convert VAL, an integer, into a list of digits."
(defun timespec-seconds (ts)
"Convert a timespec TS to seconds. A timespec may be a real count of
(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)
(cond ((null ts) 0)
((realp ts) (floor ts))
((atom ts)
@@
-99,9
+99,9
@@
units."
(defun iso-date (&optional time &key datep timep (sep #\ ))
"Construct a textual date or time in ISO format. The TIME is the universal
(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))
(multiple-value-bind
(sec min hr day mon yr dow dstp tz)
(decode-universal-time (if (or (null time) (eq time :now))
@@
-144,8
+144,18
@@
separate the two."
;;;--------------------------------------------------------------------------
;;; Zone defaults. It is intended that scripts override these.
;;;--------------------------------------------------------------------------
;;; Zone defaults. It is intended that scripts override these.
+#+ecl
+(cffi:defcfun gethostname :int
+ (name :pointer)
+ (len :uint))
+
(defvar *default-zone-source*
(defvar *default-zone-source*
- (let ((hn (unix:unix-gethostname)))
+ (let ((hn #+cmu (unix:unix-gethostname)
+ #+clisp (unix:get-host-name)
+ #+ecl (cffi:with-foreign-pointer-as-string (buffer 256 len)
+ (let ((rc (gethostname buffer len)))
+ (unless (zerop rc)
+ (error "gethostname(2) failed (rc = ~A)." rc))))))
(and hn (concatenate 'string (canonify-hostname hn) ".")))
"The default zone source: the current host's name.")
(and hn (concatenate 'string (canonify-hostname hn) ".")))
"The default zone source: the current host's name.")
@@
-175,7
+185,7
@@
separate the two."
(defun make-zone-serial (name)
"Given a zone NAME, come up with a new serial number. This will (very
(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
(let* ((file (format nil "~(~A~).serial" name))
(last (with-open-file (in file
:direction :input
@@
-223,7
+233,7
@@
carefully) update a file ZONE.serial in the current directory."
(defstruct (zone-subdomain (:conc-name zs-))
"A subdomain. Slightly weird. Used internally by zone-process-records
(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)
name
ttl
records)
@@
-233,7
+243,7
@@
below, and shouldn't escape."
(defun zone-process-records (rec ttl func)
"Sort out the list of records in REC, calling FUNC for each one. TTL is
(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
(labels ((sift (rec ttl)
(collecting (top sub)
(loop
@@
-283,7
+293,7
@@
the default time-to-live for records which don't specify one."
(defun zone-parse-host (f zname)
"Parse a host name F: if F ends in a dot then it's considered absolute;
(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))
(setf f (stringify f))
(cond ((string= f "@") (stringify zname))
((and (plusp (length f))
@@
-293,7
+303,7
@@
otherwise it's relative to ZNAME."
(stringify zname))))))
(defun default-rev-zone (base bytes)
"Return the default reverse-zone name for the given BASE address and number
(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)))
(join-strings #\. (collecting ()
(loop for i from (- 3 bytes) downto 0
do (collect (ipaddr-byte base i)))
@@
-301,7
+311,7
@@
of fixed leading BYTES."
(defun zone-name-from-net (net &optional bytes)
"Given a NET, and maybe the BYTES to use, convert to the appropriate
(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
(let ((ipn (net-get-as-ipnet net)))
(with-ipnet (net mask) ipn
(unless bytes
@@
-341,8
+351,8
@@
subdomain of in-addr.arpa."
(defun zone-reverse-records (records net list bytes dom)
"Construct a reverse zone given a forward zone's RECORDS list, the NET that
(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))
(dolist (zr records)
(when (and (eq (zr-type zr) :a)
(not (zr-defsubp zr))
@@
-363,7
+373,7
@@
many BYTES of data need to end up in the zone, and the DOM-ain suffix."
(defun zone-reverse (data name list)
"Process a :reverse record's DATA, for a domain called NAME, and add the
(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)
(destructuring-bind
(net &key bytes zones)
(listify data)
@@
-378,15
+388,15
@@
records to the LIST."
name))))
(defun zone-parse-net (net name)
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,
(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
(with-ipnet (net mask) ipn
(join-strings #\.
(reverse
@@
-397,7
+407,7
@@
return the default deletate zone prefix."
(defun zone-cidr-delegation (data name ttl list)
"Given :cidr-delegation info DATA, for a record called NAME and the current
(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))
(destructuring-bind
(net &key bytes)
(listify (car data))
@@
-444,8
+454,8
@@
TTL, write lots of CNAME records to LIST."
(NAME &key :source :admin :refresh :retry
:expire :min-ttl :ttl :serial)
(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
(destructuring-bind
(zname
&key
@@
-475,34
+485,35
@@
soa structure representing the zone head."
(defsubp (gensym "DEFSUBP")))
&body body)
"Define a new zone record type (or TYPES -- a list of synonyms is
(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))))
(setf types (listify types))
(let* ((type (car types))
(func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
- (
multiple-value-bind (doc decls body) (parse-body body)
+ (
with-parsed-body (body decls doc) body
(with-gensyms (col tname ttype tttl tdata tdefsubp i)
`(progn
(dolist (,i ',types)
(with-gensyms (col tname ttype tttl tdata tdefsubp i)
`(progn
(dolist (,i ',types)
@@
-557,12
+568,12
@@
accept the arguments)."
(defun zone-parse (zf)
"Parse a ZONE form. The syntax of a zone form is as follows:
(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
(multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
(let ((zone (make-zone :name zname
:default-ttl ttl
@@
-573,7
+584,7
@@
ZONE-RECORD:
(defun zone-create (zf)
"Zone construction function. Given a zone form ZF, construct the zone and
(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)
(let* ((zone (zone-parse zf))
(name (zone-name zone)))
(setf (zone-find name) zone)
@@
-753,8
+764,8
@@
add it to the table."
;;; Zone file `~(~A~)'
;;; (generated ~A)
;;; Zone file `~(~A~)'
;;; (generated ~A)
-$ORIGIN ~
@0
*~(~A.~)
-$TTL ~
@2
*~D~2%"
+$ORIGIN ~
0@
*~(~A.~)
+$TTL ~
2@
*~D~2%"
(zone-name zone)
(iso-date :now :datep t :timep t)
(zone-default-ttl zone))
(zone-name zone)
(iso-date :now :datep t :timep t)
(zone-default-ttl zone))
@@
-795,7
+806,7
@@
$TTL ~@2*~D~2%"
(defun zone-save (zones)
"Write the named ZONES to files. If no zones are given, write all the
(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)
(unless zones
(setf zones (hash-table-keys *zones*)))
(safely (safe)