chiark / gitweb /
Initial checkin.
[zone] / zone.lisp
CommitLineData
7e282fb5 1;;; -*-lisp-*-
2;;;
3;;; $Id$
4;;;
5;;; DNS zone generation
6;;;
7;;; (c) 2005 Straylight/Edgeware
8;;;
9
10;;;----- Licensing notice ---------------------------------------------------
11;;;
12;;; This program is free software; you can redistribute it and/or modify
13;;; it under the terms of the GNU General Public License as published by
14;;; the Free Software Foundation; either version 2 of the License, or
15;;; (at your option) any later version.
16;;;
17;;; This program is distributed in the hope that it will be useful,
18;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;;; GNU General Public License for more details.
21;;;
22;;; You should have received a copy of the GNU General Public License
23;;; along with this program; if not, write to the Free Software Foundation,
24;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25
26(defpackage #:zone
27 (:use #:common-lisp #:mdw.base #:mdw.str #:mdw.collect #:mdw.safely)
28 (:export #:ipaddr #:string-ipaddr #:ipaddr-byte #:ipaddr-string #:ipaddrp
29 #:integer-netmask #:ipmask #:ipmask-cidl-slash #:make-ipnet
30 #:string-ipnet #:ipnet #:ipnet-net #:ipnet-mask #:with-ipnet
31 #:ipnet-pretty #:ipnet-string #:ipnet-broadcast #:ipnet-hosts
32 #:ipnet-host #:ipaddr-networkp #:ipnet-subnetp
33 #:host-find# #:host-create #:defhost #:parse-ipaddr
34 #:net #:net-find #:net-get-as-ipnet #:net-create #:defnet
35 #:net-next-host #:net-host
36 #:soa #:mx #:zone #:zone-record #:zone-subdomain
37 #:*default-zone-source* #:*default-zone-refresh*
38 #:*default-zone-retry* #:*default-zone-expire*
39 #:*default-zone-min-ttl* #:*default-zone-ttl*
40 #:*default-mx-priority* #:*default-zone-admin*
41 #:zone-find #:zone-parse #:zone-write #:zone-create #:defzone
42 #:defrevzone #:zone-save
43 #:timespec-seconds #:make-zone-serial))
44(in-package #:zone)
45
46(defun mask (n)
47 "Return 2^N - 1: i.e., a mask of N set bits."
48 (1- (ash 1 n)))
49(deftype u32 ()
50 "The type of unsigned 32-bit values."
51 '(unsigned-byte 32))
52(deftype ipaddr ()
53 "The type of IP (version 4) addresses."
54 'u32)
55
56(defun string-ipaddr (str &key (start 0) (end nil))
57 "Parse STR as an IP address in dotted-quad form and return the integer
58equivalent. STR may be anything at all: it's converted as if by
59`stringify'. The START and END arguments may be used to parse out a
60substring."
61 (setf str (stringify str))
62 (unless end
63 (setf end (length str)))
64 (let ((addr 0) (noct 0))
65 (loop
66 (let* ((pos (position #\. str :start start :end end))
67 (i (parse-integer str :start start :end (or pos end))))
68 (unless (<= 0 i 256)
69 (error "IP address octet out of range"))
70 (setf addr (+ (* addr 256) i))
71 (incf noct)
72 (unless pos
73 (return))
74 (setf start (1+ pos))))
75 (unless (= noct 4)
76 (error "Wrong number of octets in IP address"))
77 addr))
78(defun ipaddr-byte (ip n)
79 "Return byte N (from most significant downwards) of an IP address."
80 (assert (<= 0 n 3))
81 (logand #xff (ash ip (* -8 (- 3 n)))))
82(defun ipaddr-string (ip)
83 "Transform the address IP into a string in dotted-quad form."
84 (check-type ip ipaddr)
85 (join-strings #\. (collecting ()
86 (dotimes (i 4)
87 (collect (ipaddr-byte ip i))))))
88(defun ipaddrp (ip)
89 "Answer true if IP is a valid IP address in integer form."
90 (typep ip 'ipaddr))
91(defun ipaddr (ip)
92 "Convert IP to an IP address. If it's an integer, return it unchanged;
93otherwise convert by `string-ipaddr'."
94 (typecase ip
95 (ipaddr ip)
96 (t (string-ipaddr ip))))
97
98(defun integer-netmask (i)
99 "Given an integer I, return a netmask with its I top bits set."
100 (- (ash 1 32) (ash 1 (- 32 i))))
101(defun ipmask (ip)
102 "Transform IP into a netmask. If it's a small integer then it's converted
103by `integer-netmask'; if nil, then all-bits-set; otherwise convert using
104`ipaddr'."
105 (typecase ip
106 (null (mask 32))
107 ((integer 0 32) (integer-netmask ip))
108 (t (ipaddr ip))))
109(defun ipmask-cidl-slash (mask)
110 "Given a netmask MASK, return an integer N such that (integer-netmask N) =
111MASK, or nil if this is impossible."
112 (dotimes (i 33)
113 (when (= mask (integer-netmask i))
114 (return i))))
115
116(defun make-ipnet (net mask)
117 "Construct an IP-network object given the NET and MASK; these are
118transformed as though by `ipaddr' and `ipmask'."
119 (let ((net (ipaddr net))
120 (mask (ipmask mask)))
121 (cons (logand net mask) mask)))
122(defun string-ipnet (str &key (start 0) (end nil))
123 "Parse an IP-network from the string STR."
124 (setf str (stringify str))
125 (unless end (setf end (length str)))
126 (let ((sl (position #\/ str :start start :end end)))
127 (if sl
128 (make-ipnet (parse-ipaddr (subseq str start sl))
129 (if (find #\. str :start (1+ sl) :end end)
130 (string-ipaddr str :start (1+ sl) :end end)
131 (integer-netmask (parse-integer str
132 :start (1+ sl)
133 :end end))))
134 (make-ipnet (parse-ipaddr (subseq str start end))
135 (integer-netmask 32)))))
136(defun ipnet (net &optional mask)
137 "Construct an IP-network object from the given arguments. A number of
138forms are acceptable:
139
140 * NET MASK -- as for `make-ipnet'.
141 * ADDR -- a single address (equivalent to ADDR 32)
142 * (NET . MASK|nil) -- a single-object representation.
143 * IPNET -- return an equivalent (`equal', not necessarily `eql') version."
144 (cond (mask (make-ipnet net mask))
145 ((or (stringp net) (symbolp net)) (string-ipnet net))
146 (t (apply #'make-ipnet (pairify net 32)))))
147(defun ipnet-net (ipn)
148 "Return the base network address of IPN."
149 (car ipn))
150(defun ipnet-mask (ipn)
151 "Return the netmask of IPN."
152 (cdr ipn))
153(defmacro with-ipnet ((net mask) ipn &body body)
154 "Evaluate BODY with NET and MASK bound to the base address and netmask of
155IPN. Either NET or MASK (or, less usefully, both) may be nil if not wanted."
156 (with-gensyms tmp
157 `(let ((,tmp ,ipn))
158 (let (,@(and net `((,net (ipnet-net ,tmp))))
159 ,@(and mask `((,mask (ipnet-mask ,tmp)))))
160 ,@body))))
161(defun ipnet-pretty (ipn)
162 "Convert IPN to a pretty cons-cell form."
163 (with-ipnet (net mask) ipn
164 (cons (ipaddr-string net)
165 (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
166(defun ipnet-string (ipn)
167 "Convert IPN to a string."
168 (with-ipnet (net mask) ipn
169 (format nil "~A/~A"
170 (ipaddr-string net)
171 (or (ipmask-cidl-slash mask) (ipaddr-string mask)))))
172(defun ipnet-broadcast (ipn)
173 "Return the broadcast address for the network IPN."
174 (with-ipnet (net mask) ipn
175 (logior net (logxor (mask 32) mask))))
176(defun ipnet-hosts (ipn)
177 "Return the number of available addresses in network IPN."
178 (ash 1 (- 32 (logcount (ipnet-mask ipn)))))
179(defun ipnet-host (ipn host)
180 "Return the address of the given HOST in network IPN. This works even with
181a non-contiguous netmask."
182 (check-type host u32)
183 (with-ipnet (net mask) ipn
184 (let ((i 0) (m 1) (a net) (h host))
185 (loop
186 (when (>= i 32)
187 (error "Host index ~D out of range for network ~A"
188 host (ipnet-pretty ipn)))
189 (cond ((zerop h)
190 (return a))
191 ((logbitp i mask)
192 (setf h (ash h 1)))
193 (t
194 (setf a (logior a (logand m h)))
195 (setf h (logandc2 h m))))
196 (setf m (ash m 1))
197 (incf i)))))
198(defun ipaddr-networkp (ip ipn)
199 "Returns true if address IP is within network IPN."
200 (with-ipnet (net mask) ipn
201 (= net (logand ip mask))))
202(defun ipnet-subnetp (ipn subn)
203 "Returns true if SUBN is a (non-strict) subnet of IPN."
204 (with-ipnet (net mask) ipn
205 (with-ipnet (subnet submask) subn
206 (and (= net (logand subnet mask))
207 (= submask (logior mask submask))))))
208
209(defun resolve-hostname (name)
210 "Resolve a hostname to an IP address using the DNS, or return nil."
211 (let ((he (ext:lookup-host-entry name)))
212 (and he
213 (ext:host-entry-addr he))))
214(defun parse-ipaddr (addr)
215 "Convert the string ADDR into an IP address: tries all sorts of things:
216
217 (NET [INDEX]) -- index a network: NET is a network name defined by defnet;
218 INDEX is an index or one of the special symbols understood by net-host,
219 and defaults to :next
220 INTEGER -- an integer IP address
221 IPADDR -- an IP address in dotted-quad form
222 HOST -- a host name defined by defhost
223 DNSNAME -- a name string to look up in the DNS"
224 (cond ((listp addr)
225 (destructuring-bind
226 (net host)
227 (pairify addr :next)
228 (net-host (or (net-find net)
229 (error "Network ~A not found" net))
230 host)))
231 ((ipaddrp addr) addr)
232 (t
233 (setf addr (string-downcase (stringify addr)))
234 (or (host-find addr)
235 (and (plusp (length addr))
236 (digit-char-p (char addr 0))
237 (string-ipaddr addr))
238 (resolve-hostname (stringify addr))
239 (error "Host name ~A unresolvable" addr)))))
240
241(defvar *hosts* (make-hash-table :test #'equal)
242 "The table of known hostnames.")
243(defun host-find (name)
244 "Find a host by NAME."
245 (gethash (string-downcase (stringify name)) *hosts*))
246(defun (setf host-find) (addr name)
247 "Make NAME map to ADDR (must be an ipaddr in integer form)."
248 (setf (gethash (string-downcase (stringify name)) *hosts*) addr))
249(defun host-create (name addr)
250 "Make host NAME map to ADDR (anything acceptable to parse-ipaddr)."
251 (setf (host-find name) (parse-ipaddr addr)))
252(defmacro defhost (name addr)
253 "Main host definition macro. Neither NAME nor ADDR is evaluated."
254 `(progn
255 (host-create ',name ',addr)
256 ',name))
257
258(defstruct (net (:predicate netp))
259 "A network structure. Slots:
260
261NAME The network's name, as a string
262IPNET The network base address and mask
263HOSTS Number of hosts in the network
264NEXT Index of the next unassigned host"
265 name
266 ipnet
267 hosts
268 next)
269
270(defvar *networks* (make-hash-table :test #'equal)
271 "The table of known networks.")
272(defun net-find (name)
273 "Find a network by NAME."
274 (gethash (string-downcase (stringify name)) *networks*))
275(defun (setf net-find) (net name)
276 "Make NAME map to NET."
277 (setf (gethash (string-downcase (stringify name)) *networks*) net))
278(defun net-get-as-ipnet (form)
279 "Transform FORM into an ipnet. FORM may be a network name, or something
280acceptable to the ipnet function."
281 (let ((net (net-find form)))
282 (if net (net-ipnet net)
283 (ipnet form))))
284(defun net-create (name &rest args)
285 "Construct a new network called NAME and add it to the map. The ARGS
286describe the new network, in a form acceptable to the ipnet function."
287 (let ((ipn (apply #'ipnet args)))
288 (setf (net-find name)
289 (make-net :name (string-downcase (stringify name))
290 :ipnet ipn
291 :hosts (ipnet-hosts ipn)
292 :next 1))))
293(defmacro defnet (name &rest args)
294 "Main network definition macro. Neither NAME nor any of the ARGS is
295evaluated."
296 `(progn
297 (net-create ',name ,@(mapcar (lambda (x) `',x) args))
298 ',name))
299(defun net-next-host (net)
300 "Given a NET, return the IP address (as integer) of the next available
301address in the network."
302 (unless (< (net-next net) (net-hosts net))
303 (error "No more hosts left in network ~A" (net-name net)))
304 (let ((next (net-next net)))
305 (incf (net-next net))
306 (net-host net next)))
307(defun net-host (net host)
308 "Return the given HOST on the NEXT. HOST may be an index (in range, of
309course), or one of the keywords:
310:NEXT next host, as by net-next-host
311:NET network base address
312:BROADCAST network broadcast address"
313 (case host
314 (:next (net-next-host net))
315 (:net (ipnet-net (net-ipnet net)))
316 (:broadcast (ipnet-broadcast (net-ipnet net)))
317 (t (ipnet-host (net-ipnet net) host))))
318
319(defun to-integer (x)
320 "Convert X to an integer in the most straightforward way."
321 (floor (rational x)))
322(defun timespec-seconds (ts)
323 "Convert a timespec TS to seconds. A timespec may be a real count of
324seconds, or a list (COUNT UNIT): UNIT may be any of a number of obvious time
325units."
326 (cond ((null ts) 0)
327 ((realp ts) (floor ts))
328 ((atom ts)
329 (error "Unknown timespec format ~A" ts))
330 ((null (cdr ts))
331 (timespec-seconds (car ts)))
332 (t (+ (to-integer (* (car ts)
333 (case (intern (string-upcase
334 (stringify (cadr ts)))
335 '#:zone)
336 ((s sec secs second seconds) 1)
337 ((m min mins minute minutes) 60)
338 ((h hr hrs hour hours) #.(* 60 60))
339 ((d dy dys day days) #.(* 24 60 60))
340 ((w wk wks week weeks) #.(* 7 24 60 60))
341 ((y yr yrs year years) #.(* 365 24 60 60))
342 (t (error "Unknown time unit ~A"
343 (cadr ts))))))
344 (timespec-seconds (cddr ts))))))
345
346(defstruct (soa (:predicate soap))
347 "Start-of-authority record information."
348 source
349 admin
350 refresh
351 retry
352 expire
353 min-ttl
354 serial)
355(defstruct (mx (:predicate mxp))
356 "Mail-exchange record information."
357 priority
358 domain)
359(defstruct (zone (:predicate zonep))
360 "Zone information."
361 soa
362 default-ttl
363 name
364 records)
365
366(defvar *default-zone-source*
367 (let ((hn (unix:unix-gethostname)))
368 (and hn (resolve-hostname hn)))
369 "The default zone source: the current host's name.")
370(defvar *default-zone-refresh* (* 24 60 60)
371 "Default zone refresh interval: one day.")
372(defvar *default-zone-admin* nil
373 "Default zone administrator's email address.")
374(defvar *default-zone-retry* (* 60 60)
375 "Default znoe retry interval: one hour.")
376(defvar *default-zone-expire* (* 14 24 60 60)
377 "Default zone expiry time: two weeks.")
378(defvar *default-zone-min-ttl* (* 4 60 60)
379 "Default zone minimum TTL/negative TTL: four hours.")
380(defvar *default-zone-ttl* (* 8 60 60)
381 "Default zone TTL (for records without explicit TTLs): 8 hours.")
382(defvar *default-mx-priority* 50
383 "Default MX priority.")
384
385(defun from-mixed-base (base val)
386 "BASE is a list of the ranges for the `digits' of a mixed-base
387representation. Convert VAL, a list of digits, into an integer."
388 (do ((base base (cdr base))
389 (val (cdr val) (cdr val))
390 (a (car val) (+ (* a (car base)) (car val))))
391 ((or (null base) (null val)) a)))
392(defun to-mixed-base (base val)
393 "BASE is a list of the ranges for the `digits' of a mixed-base
394representation. Convert VAL, an integer, into a list of digits."
395 (let ((base (reverse base))
396 (a nil))
397 (loop
398 (unless base
399 (push val a)
400 (return a))
401 (multiple-value-bind (q r) (floor val (pop base))
402 (push r a)
403 (setf val q)))))
404
405(defun make-zone-serial (name)
406 "Given a zone NAME, come up with a new serial number. This will (very
407carefully) update a file ZONE.serial in the current directory."
408 (let* ((file (format nil "~(~A~).serial" name))
409 (last (with-open-file (in file
410 :direction :input
411 :if-does-not-exist nil)
412 (if in (read in)
413 (list 0 0 0 0))))
414 (now (multiple-value-bind
415 (sec min hr dy mon yr dow dstp tz)
416 (get-decoded-time)
417 (declare (ignore sec min hr dow dstp tz))
418 (list dy mon yr)))
419 (seq (cond ((not (equal now (cdr last))) 0)
420 ((< (car last) 99) (1+ (car last)))
421 (t (error "Run out of sequence numbers for ~A" name)))))
422 (safely-writing (out file)
423 (format out
424 ";; Serial number file for zone ~A~%~
425 ;; (LAST-SEQ DAY MONTH YEAR)~%~
426 ~S~%"
427 name
428 (cons seq now)))
429 (from-mixed-base '(100 100 100) (reverse (cons seq now)))))
430
431(defvar *zones* (make-hash-table :test #'equal)
432 "Map of known zones.")
433(defun zone-find (name)
434 "Find a zone given its NAME."
435 (gethash (string-downcase (stringify name)) *zones*))
436(defun (setf zone-find) (zone name)
437 "Make the zone NAME map to ZONE."
438 (setf (gethash (string-downcase (stringify name)) *zones*) zone))
439
440(defstruct (zone-record (:conc-name zr-))
441 "A zone record."
442 (name '<unnamed>)
443 ttl
444 type
445 (defsubp nil)
446 data)
447
448(defstruct (zone-subdomain (:conc-name zs-))
449 "A subdomain. Slightly weird. Used internally by zone-process-records
450below, and shouldn't escape."
451 name
452 ttl
453 records)
454
455(defun zone-process-records (rec ttl func)
456 "Sort out the list of records in REC, calling FUNC for each one. TTL is
457the default time-to-live for records which don't specify one."
458 (labels ((sift (rec ttl)
459 (collecting (top sub)
460 (loop
461 (unless rec
462 (return))
463 (let ((r (pop rec)))
464 (cond ((eq r :ttl)
465 (setf ttl (pop rec)))
466 ((symbolp r)
467 (collect (make-zone-record :type r
468 :ttl ttl
469 :data (pop rec))
470 top))
471 ((listp r)
472 (dolist (name (listify (car r)))
473 (collect (make-zone-subdomain :name name
474 :ttl ttl
475 :records (cdr r))
476 sub)))
477 (t
478 (error "Unexpected record form ~A" (car r))))))))
479 (process (rec dom ttl defsubp)
480 (multiple-value-bind (top sub) (sift rec ttl)
481 (if (and dom (null top) sub)
482 (let ((s (pop sub)))
483 (process (zs-records s)
484 dom
485 (zs-ttl s)
486 defsubp)
487 (process (zs-records s)
488 (cons (zs-name s) dom)
489 (zs-ttl s)
490 t))
491 (let ((name (and dom
492 (string-downcase
493 (join-strings #\. (reverse dom))))))
494 (dolist (zr top)
495 (setf (zr-name zr) name)
496 (setf (zr-defsubp zr) defsubp)
497 (funcall func zr))))
498 (dolist (s sub)
499 (process (zs-records s)
500 (cons (zs-name s) dom)
501 (zs-ttl s)
502 defsubp)))))
503 (process rec nil ttl nil)))
504
505(defun zone-parse-host (f zname)
506 "Parse a host name F: if F ends in a dot then it's considered absolute;
507otherwise it's relative to ZNAME."
508 (setf f (stringify f))
509 (cond ((string= f "@") (stringify zname))
510 ((and (plusp (length f))
511 (char= (char f (1- (length f))) #\.))
512 (string-downcase (subseq f 0 (1- (length f)))))
513 (t (string-downcase (concatenate 'string f "."
514 (stringify zname))))))
515(defun ipnet-changeable-bytes (mask)
516 "Answers how many low-order bytes of MASK are (entirely or partially)
517changeable. This is used when constructing reverse zones."
518 (dotimes (i 4 4)
519 (when (/= (ipaddr-byte mask i) 255)
520 (return (- 4 i)))))
521(defun default-rev-zone (base bytes)
522 (join-strings #\. (collecting ()
523 (loop for i from (- 3 bytes) downto 0
524 do (collect (ipaddr-byte base i)))
525 (collect "in-addr.arpa"))))
526
527(defun zone-name-from-net (net &optional bytes)
528 "Given a NET, and maybe the BYTES to use, convert to the appropriate
529subdomain of in-addr.arpa."
530 (let ((ipn (net-get-as-ipnet net)))
531 (with-ipnet (net mask) ipn
532 (unless bytes
533 (setf bytes (- 4 (ipnet-changeable-bytes mask))))
534 (join-strings #\.
535 (append (loop
536 for i from (- 4 bytes) below 4
537 collect (logand #xff (ash net (* -8 i))))
538 (list "in-addr.arpa"))))))
539
540(defun zone-net-from-name (name)
541 "Given a NAME in the in-addr.arpa space, convert it to an ipnet."
542 (let* ((name (string-downcase (stringify name)))
543 (len (length name))
544 (suffix ".in-addr.arpa")
545 (sufflen (length suffix))
546 (addr 0)
547 (n 0)
548 (end (- len sufflen)))
549 (unless (and (> len sufflen)
550 (string= name suffix :start1 end))
551 (error "`~A' not in ~A." name suffix))
552 (loop
553 with start = 0
554 for dot = (position #\. name :start start :end end)
555 for byte = (parse-integer name
556 :start start
557 :end (or dot end))
558 do (setf addr (logior addr (ash byte (* 8 n))))
559 (incf n)
560 when (>= n 4)
561 do (error "Can't deduce network from ~A." name)
562 while dot
563 do (setf start (1+ dot)))
564 (setf addr (ash addr (* 8 (- 4 n))))
565 (make-ipnet addr (* 8 n))))
566
567(defun zone-reverse-records (records net list bytes dom)
568 "Construct a reverse zone given a forward zone's RECORDS list, the NET that
569the reverse zone is to serve, a LIST to collect the records into, how
570many BYTES of data need to end up in the zone, and the DOM-ain suffix."
571 (dolist (zr records)
572 (when (and (eq (zr-type zr) :a)
573 (not (zr-defsubp zr))
574 (ipaddr-networkp (zr-data zr) net))
575 (collect (make-zone-record
576 :name (string-downcase
577 (join-strings
578 #\.
579 (collecting ()
580 (dotimes (i bytes)
581 (collect (logand #xff (ash (zr-data zr)
582 (* -8 i)))))
583 (collect dom))))
584 :type :ptr
585 :ttl (zr-ttl zr)
586 :data (zr-name zr))
587 list))))
588
589(defun zone-reverse (data name list)
590 "Process a :reverse record's DATA, for a domain called NAME, and add the
591records to the LIST."
592 (destructuring-bind
593 (net &key bytes zones)
594 (listify data)
595 (setf net (zone-parse-net net name))
596 (dolist (z (or (listify zones)
597 (hash-table-keys *zones*)))
598 (zone-reverse-records (zone-records (zone-find z))
599 net
600 list
601 (or bytes
602 (ipnet-changeable-bytes (ipnet-mask net)))
603 name))))
604
605(defun zone-parse-net (net name)
606 "Given a NET, and the NAME of a domain to guess from if NET is null,
607return the ipnet for the network."
608 (if net
609 (net-get-as-ipnet net)
610 (zone-net-from-name name)))
611
612(defun zone-cidr-delg-default-name (ipn bytes)
613 "Given a delegated net IPN and the parent's number of changing BYTES,
614return the default deletate zone prefix."
615 (with-ipnet (net mask) ipn
616 (join-strings #\.
617 (reverse
618 (loop
619 for i from (1- bytes) downto 0
620 until (zerop (logand mask (ash #xff (* 8 i))))
621 collect (logand #xff (ash net (* -8 i))))))))
622
623(defun zone-cidr-delegation (data name ttl list)
624 "Given :cidr-delegation info DATA, for a record called NAME and the current
625TTL, write lots of CNAME records to LIST."
626 (destructuring-bind
627 (net &key bytes)
628 (listify (car data))
629 (setf net (zone-parse-net net name))
630 (unless bytes
631 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
632 (dolist (map (cdr data))
633 (destructuring-bind
634 (tnet &optional tdom)
635 (listify map)
636 (setf tnet (zone-parse-net tnet name))
637 (unless (ipnet-subnetp net tnet)
638 (error "~A is not a subnet of ~A."
639 (ipnet-pretty tnet)
640 (ipnet-pretty net)))
641 (unless tdom
642 (setf tdom
643 (join-strings #\.
644 (list (zone-cidr-delg-default-name tnet bytes)
645 name))))
646 (setf tdom (string-downcase tdom))
647 (dotimes (i (ipnet-hosts tnet))
648 (let* ((addr (ipnet-host tnet i))
649 (tail (join-strings #\.
650 (loop
651 for i from 0 below bytes
652 collect
653 (logand #xff
654 (ash addr (* 8 i)))))))
655 (collect (make-zone-record
656 :name (join-strings #\.
657 (list tail name))
658 :type :cname
659 :ttl ttl
660 :data (join-strings #\. (list tail tdom)))
661 list)))))))
662
663
664
665(defun zone-parse-head (head)
666 "Parse the HEAD of a zone form. This has the form
667
668 (NAME &key :source :admin :refresh :retry
669 :expire :min-ttl :ttl :serial)
670
671though a singleton NAME needn't be a list. Returns the default TTL and an
672soa structure representing the zone head."
673 (destructuring-bind
674 (zname
675 &key
676 (source (concatenate 'string *default-zone-source* "."))
677 (admin (or *default-zone-admin*
678 (format nil "hostmaster@~A" zname)))
679 (refresh *default-zone-refresh*)
680 (retry *default-zone-retry*)
681 (expire *default-zone-expire*)
682 (min-ttl *default-zone-min-ttl*)
683 (ttl min-ttl)
684 (serial (make-zone-serial zname)))
685 (listify head)
686 (values zname
687 (timespec-seconds ttl)
688 (make-soa :admin admin
689 :source (zone-parse-host source zname)
690 :refresh (timespec-seconds refresh)
691 :retry (timespec-seconds retry)
692 :expire (timespec-seconds expire)
693 :min-ttl (timespec-seconds min-ttl)
694 :serial serial))))
695
696(defun hash-table-keys (ht)
697 "Return a list of the keys in hashtable HT."
698 (collecting ()
699 (maphash (lambda (key val) (declare (ignore val)) (collect key)) ht)))
700
701(defmacro defzoneparse (types (name data list
702 &key (zname (gensym "ZNAME"))
703 (ttl (gensym "TTL"))
704 (defsubp (gensym "DEFSUBP")))
705 &body body)
706 (setf types (listify types))
707 (let* ((type (car types))
708 (func (intern (format nil "ZONE-PARSE/~:@(~A~)" type))))
709 (with-gensyms (col tname ttype tttl tdata tdefsubp i)
710 `(progn
711 (dolist (,i ',types)
712 (setf (get ,i 'zone-parse) ',func))
713 (defun ,func (,name ,data ,ttl ,col ,zname ,defsubp)
714 (declare (ignorable ,zname ,defsubp))
715 (flet ((,list (&key ((:name ,tname) ,name)
716 ((:type ,ttype) ,type)
717 ((:data ,tdata) ,data)
718 ((:ttl ,tttl) ,ttl)
719 ((:defsubp ,tdefsubp) nil))
720 (collect (make-zone-record :name ,tname
721 :type ,ttype
722 :data ,tdata
723 :ttl ,tttl
724 :defsubp ,tdefsubp)
725 ,col)))
726 ,@body))
727 ',type))))
728
729(defun zone-parse-records (zone records)
730 (let ((zname (zone-name zone)))
731 (with-collection (rec)
732 (flet ((parse-record (zr)
733 (let ((func (or (get (zr-type zr) 'zone-parse)
734 (error "No parser for record ~A."
735 (zr-type zr))))
736 (name (and (zr-name zr)
737 (stringify (zr-name zr)))))
738 (if (or (not name)
739 (string= name "@"))
740 (setf name zname)
741 (let ((len (length name)))
742 (if (or (zerop len)
743 (char/= (char name (1- len)) #\.))
744 (setf name (join-strings #\.
745 (list name zname))))))
746 (funcall func
747 name
748 (zr-data zr)
749 (zr-ttl zr)
750 rec
751 zname
752 (zr-defsubp zr)))))
753 (zone-process-records records
754 (zone-default-ttl zone)
755 #'parse-record ))
756 (setf (zone-records zone) (nconc (zone-records zone) rec)))))
757
758(defun zone-parse (zf)
759 "Parse a ZONE form. The syntax of a zone form is as follows:
760
761ZONE-FORM:
762 ZONE-HEAD ZONE-RECORD*
763
764ZONE-RECORD:
765 ((NAME*) ZONE-RECORD*)
766| SYM ARGS"
767 (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
768 (let ((zone (make-zone :name zname
769 :default-ttl ttl
770 :soa soa
771 :records nil)))
772 (zone-parse-records zone (cdr zf))
773 zone)))
774
775(defzoneparse :a (name data rec :defsubp defsubp)
776 ":a IPADDR"
777 (rec :data (parse-ipaddr data) :defsubp defsubp))
778(defzoneparse :ptr (name data rec :zname zname)
779 ":ptr HOST"
780 (rec :data (zone-parse-host data zname)))
781(defzoneparse :cname (name data rec :zname zname)
782 ":cname HOST"
783 (rec :data (zone-parse-host data zname)))
784(defzoneparse :mx (name data rec :zname zname)
785 ":mx ((HOST :prio INT :ip IPADDR)*)"
786 (dolist (mx (listify data))
787 (destructuring-bind
788 (mxname &key (prio *default-mx-priority*) ip)
789 (listify mx)
790 (let ((host (zone-parse-host mxname zname)))
791 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
792 (rec :data (cons host prio))))))
793(defzoneparse :ns (name data rec :zname zname)
794 ":ns ((HOST :ip IPADDR)*)"
795 (dolist (ns (listify data))
796 (destructuring-bind
797 (nsname &key ip)
798 (listify ns)
799 (let ((host (zone-parse-host nsname zname)))
800 (when ip (rec :name host :type :a :data (parse-ipaddr ip)))
801 (rec :data host)))))
802(defzoneparse :alias (name data rec :zname zname)
803 ":alias (LABEL*)"
804 (dolist (a (listify data))
805 (rec :name (zone-parse-host a zname)
806 :type :cname
807 :data name)))
808
809(defzoneparse (:rev :reverse) (name data rec)
810 ":reverse ((NET :bytes BYTES) ZONE*)"
811 (setf data (listify data))
812 (destructuring-bind
813 (net &key bytes)
814 (listify (car data))
815 (setf net (zone-parse-net net name))
816 (unless bytes
817 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
818 (dolist (z (or (cdr data)
819 (hash-table-keys *zones*)))
820 (dolist (zr (zone-records (zone-find z)))
821 (when (and (eq (zr-type zr) :a)
822 (not (zr-defsubp zr))
823 (ipaddr-networkp (zr-data zr) net))
824 (rec :name (string-downcase
825 (join-strings
826 #\.
827 (collecting ()
828 (dotimes (i bytes)
829 (collect (logand #xff (ash (zr-data zr)
830 (* -8 i)))))
831 (collect name))))
832 :type :ptr
833 :ttl (zr-ttl zr)
834 :data (zr-name zr)))))))
835
836(defzoneparse (:cidr-delegation :cidr) (name data rec)
837 ":cidr-delegation ((NET :bytes BYTES) (TARGET-NET [TARGET-ZONE])*)"
838 (destructuring-bind
839 (net &key bytes)
840 (listify (car data))
841 (setf net (zone-parse-net net name))
842 (unless bytes
843 (setf bytes (ipnet-changeable-bytes (ipnet-mask net))))
844 (dolist (map (cdr data))
845 (destructuring-bind
846 (tnet &optional tdom)
847 (listify map)
848 (setf tnet (zone-parse-net tnet name))
849 (unless (ipnet-subnetp net tnet)
850 (error "~A is not a subnet of ~A."
851 (ipnet-pretty tnet)
852 (ipnet-pretty net)))
853 (unless tdom
854 (with-ipnet (net mask) tnet
855 (setf tdom
856 (join-strings
857 #\.
858 (append (reverse (loop
859 for i from (1- bytes) downto 0
860 until (zerop (logand mask
861 (ash #xff
862 (* 8 i))))
863 collect (logand #xff
864 (ash net (* -8 i)))))
865 (list name))))))
866 (setf tdom (string-downcase tdom))
867 (dotimes (i (ipnet-hosts tnet))
868 (let* ((addr (ipnet-host tnet i))
869 (tail (join-strings #\.
870 (loop
871 for i from 0 below bytes
872 collect
873 (logand #xff
874 (ash addr (* 8 i)))))))
875 (rec :name (format nil "~A.~A" tail name)
876 :type :cname
877 :data (format nil "~A.~A" tail tdom))))))))
878
879(defun iso-date (&optional time &key datep timep (sep #\ ))
880 "Construct a textual date or time in ISO format. The TIME is the universal
881time to convert, which defaults to now; DATEP is whether to emit the date;
882TIMEP is whether to emit the time, and SEP (default is space) is how to
883separate the two."
884 (multiple-value-bind
885 (sec min hr day mon yr dow dstp tz)
886 (decode-universal-time (if (or (null time) (eq time :now))
887 (get-universal-time)
888 time))
889 (declare (ignore dow dstp tz))
890 (with-output-to-string (s)
891 (when datep
892 (format s "~4,'0D-~2,'0D-~2,'0D" yr mon day)
893 (when timep
894 (write-char sep s)))
895 (when timep
896 (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
897
898(defun zone-write (zone &optional (stream *standard-output*))
899 "Write a ZONE's records to STREAM."
900 (labels ((fix-admin (a)
901 (let ((at (position #\@ a))
902 (s (concatenate 'string (string-downcase a) ".")))
903 (when s
904 (setf (char s at) #\.))
905 s))
906 (fix-host (h)
907 (if (not h)
908 "@"
909 (let* ((h (string-downcase (stringify h)))
910 (hl (length h))
911 (r (string-downcase (zone-name zone)))
912 (rl (length r)))
913 (cond ((string= r h) "@")
914 ((and (> hl rl)
915 (char= (char h (- hl rl 1)) #\.)
916 (string= h r :start1 (- hl rl)))
917 (subseq h 0 (- hl rl 1)))
918 (t (concatenate 'string h "."))))))
919 (printrec (zr)
920 (format stream "~A~20T~@[~8D~]~30TIN ~A~40T"
921 (fix-host (zr-name zr))
922 (and (/= (zr-ttl zr) (zone-default-ttl zone))
923 (zr-ttl zr))
924 (string-upcase (symbol-name (zr-type zr))))))
925 (format stream "~
926;;; Zone file `~(~A~)'
927;;; (generated ~A)
928
929$ORIGIN ~@0*~(~A.~)
930$TTL ~@2*~D~2%"
931 (zone-name zone)
932 (iso-date :now :datep t :timep t)
933 (zone-default-ttl zone))
934 (let ((soa (zone-soa zone)))
935 (format stream "~
936~A~30TIN SOA~40T~A ~A (
937~45T~10D~60T ;serial
938~45T~10D~60T ;refresh
939~45T~10D~60T ;retry
940~45T~10D~60T ;expire
941~45T~10D )~60T ;min-ttl~2%"
942 (fix-host (zone-name zone))
943 (fix-host (soa-source soa))
944 (fix-admin (soa-admin soa))
945 (soa-serial soa)
946 (soa-refresh soa)
947 (soa-retry soa)
948 (soa-expire soa)
949 (soa-min-ttl soa)))
950 (dolist (zr (zone-records zone))
951 (case (zr-type zr)
952 (:a
953 (printrec zr)
954 (format stream "~A~%" (ipaddr-string (zr-data zr))))
955 ((:ptr :cname)
956 (printrec zr)
957 (format stream "~A~%" (fix-host (zr-data zr))))
958 (:ns
959 (printrec zr)
960 (format stream "~A~%" (fix-host (zr-data zr))))
961 (:mx
962 (printrec zr)
963 (let ((mx (zr-data zr)))
964 (format stream "~2D ~A~%" (cdr mx) (fix-host (car mx)))))
965 (:txt
966 (printrec zr)
967 (format stream "~S~%" (stringify (zr-data zr))))))))
968
969(defun zone-create (zf)
970 "Zone construction function. Given a zone form ZF, construct the zone and
971add it to the table."
972 (let* ((zone (zone-parse zf))
973 (name (zone-name zone)))
974 (setf (zone-find name) zone)
975 name))
976(defmacro defzone (soa &rest zf)
977 "Zone definition macro."
978 `(zone-create '(,soa ,@zf)))
979(defmacro defrevzone (head &rest zf)
980 "Define a reverse zone, with the correct name."
981 (destructuring-bind
982 (net &rest soa-args)
983 (listify head)
984 (let ((bytes nil))
985 (when (and soa-args (integerp (car soa-args)))
986 (setf bytes (pop soa-args)))
987 `(zone-create '((,(zone-name-from-net net bytes) ,@soa-args) ,@zf)))))
988
989
990(defun zone-save (zones)
991 "Write the named ZONES to files. If no zones are given, write all the
992zones."
993 (unless zones
994 (setf zones (hash-table-keys *zones*)))
995 (safely (safe)
996 (dolist (z zones)
997 (let ((zz (zone-find z)))
998 (unless zz
999 (error "Unknown zone `~A'." z))
1000 (let ((stream (safely-open-output-stream safe
1001 (string-downcase
1002 (stringify z)))))
1003 (zone-write zz stream))))))
1004
1005;;;----- That's all, folks --------------------------------------------------