zone.lisp, frontend.lisp: New configuration-variable machinery.

[zone] / zone.lisp

;;; -*-lisp-*-
;;;
;;; DNS zone generation
;;;
;;; (c) 2005 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; 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 #:collect #:safely
	#:net #:services)
  (:import-from #:net #:round-down #:round-up))

(in-package #:zone)

;;;--------------------------------------------------------------------------
;;; Various random utilities.

(export '*zone-config*)
(defparameter *zone-config* nil
  "A list of configuration variables.

   This is for the benefit of the frontend, which will dynamically bind them
   so that input files can override them independently.  Not intended for use
   by users.")

(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)))))

(export 'timespec-seconds)
(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)))))

(deftype octet () '(unsigned-byte 8))
(deftype octet-vector (&optional n) `(array octet (,n)))

(defun decode-hex (hex &key (start 0) end)
  "Decode a hexadecimal-encoded string, returning a vector of octets."
  (let* ((end (or end (length hex)))
	 (len (- end start))
	 (raw (make-array (floor len 2) :element-type 'octet)))
    (unless (evenp len)
      (error "Invalid hex string `~A' (odd length)" hex))
    (do ((i start (+ i 2)))
	((>= i end) raw)
      (let ((high (digit-char-p (char hex i) 16))
	    (low (digit-char-p (char hex (1+ i)) 16)))
	(unless (and high low)
	  (error "Invalid hex string `~A' (bad digit)" hex))
	(setf (aref raw (/ (- i start) 2)) (+ (* 16 high) low))))))

(defun slurp-file (file &optional (element-type 'character))
  "Read and return the contents of FILE as a vector."
  (with-open-file (in file :element-type element-type)
    (let ((buf (make-array 1024 :element-type element-type))
	  (pos 0))
      (loop
	(let ((end (read-sequence buf in :start pos)))
	  (when (< end (length buf))
	    (return (adjust-array buf end)))
	  (setf pos end
		buf (adjust-array buf (* 2 pos))))))))

(defmacro defenum (name (&key export) &body values)
  "Set up symbol properties for manifest constants.

   The VALUES are a list of (TAG VALUE) pairs.	Each TAG is a symbol; we set
   the NAME property on TAG to VALUE, and export TAG.  There are also handy
   hash-tables mapping in the forward and reverse directions, in the name
   symbol's `enum-forward' and `enum-reverse' properties."
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     ,(let*/gensyms (export)
	(with-gensyms (forward reverse valtmp)
	  `(let ((,forward (make-hash-table))
		 (,reverse (make-hash-table)))
	     (when ,export (export ',name))
	     ,@(mapcar (lambda (item)
			 (destructuring-bind (tag value) item
			   (let ((constant
				  (intern (concatenate 'string
						       (symbol-name name)
						       "/"
						       (symbol-name tag)))))
			     `(let ((,valtmp ,value))
				(when ,export
				  (export ',constant)
				  (when (eq (symbol-package ',tag) *package*)
				    (export ',tag)))
				(defconstant ,constant ,valtmp)
				(setf (get ',tag ',name) ,value
				      (gethash ',tag ,forward) ,valtmp
				      (gethash ,valtmp ,reverse) ',tag)))))
		       values)
	     (setf (get ',name 'enum-forward) ,forward
		   (get ',name 'enum-reverse) ,reverse))))))

(defun lookup-enum (name tag &key min max)
  "Look up a TAG in an enumeration.

   If TAG is a symbol, check its NAME property; if it's a fixnum then take it
   as it is.  Make sure that it's between MIN and MAX, if they're not nil."
  (let ((value (etypecase tag
		(fixnum tag)
		(symbol (or (get tag name)
			    (error "~S is not a known ~A" tag name))))))
    (unless (and (or (null min) (<= min value))
		(or (null max) (<= value max)))
      (error "Value ~S out of range for ~A" value name))
    value))

(defun reverse-enum (name value)
  "Reverse-lookup of a VALUE in enumeration NAME.

   If a tag for the VALUE is found, return it and `t'; otherwise return VALUE
   unchanged and `nil'."
  (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse))
    (if foundp
	(values tag t)
	(values value nil))))

(defun mapenum (func name)
  "Call FUNC on TAG/VALUE pairs from the enumeration called NAME."
  (maphash func (get name 'enum-forward)))

(defun hash-file (hash file context)
  "Hash the FILE using the OpenSSL HASH function, returning an octet string.

   CONTEXT is a temporary-files context."
  (let ((temp (temporary-file context "hash")))
    (run-program (list "openssl" "dgst" (concatenate 'string "-" hash))
		 :input file :output temp)
    (with-open-file (in temp)
      (let ((line (read-line in)))
	(assert (and (>= (length line) 9)
		     (string= line "(stdin)= " :end1 9)))
	(decode-hex line :start 9)))))

;;;--------------------------------------------------------------------------
;;; Zone types.

(export 'soa)
(defstruct (soa (:predicate soap))
  "Start-of-authority record information."
  source
  admin
  refresh
  retry
  expire
  min-ttl
  serial)

(export 'zone-text-name)
(defun zone-text-name (zone)
  (princ-to-string (zone-name zone)))

(export 'mx)
(defstruct (mx (:predicate mxp))
  "Mail-exchange record information."
  priority
  domain)

(export 'zone)
(defstruct (zone (:predicate zonep))
  "Zone information."
  soa
  default-ttl
  name
  records)

;;;--------------------------------------------------------------------------
;;; Zone defaults.  It is intended that scripts override these.

(export '*default-zone-source*)
(defvar *default-zone-source*
  (let ((hn (gethostname)))
    (and hn (concatenate 'string (canonify-hostname hn) ".")))
  "The default zone source: the current host's name.")

(export '*default-zone-refresh*)
(defvar *default-zone-refresh* (* 24 60 60)
  "Default zone refresh interval: one day.")

(export '*default-zone-admin*)
(defvar *default-zone-admin* nil
  "Default zone administrator's email address.")

(export '*default-zone-retry*)
(defvar *default-zone-retry* (* 60 60)
  "Default znoe retry interval: one hour.")

(export '*default-zone-expire*)
(defvar *default-zone-expire* (* 14 24 60 60)
  "Default zone expiry time: two weeks.")

(export '*default-zone-min-ttl*)
(defvar *default-zone-min-ttl* (* 4 60 60)
  "Default zone minimum TTL/negative TTL: four hours.")

(export '*default-zone-ttl*)
(defvar *default-zone-ttl* (* 8 60 60)
  "Default zone TTL (for records without explicit TTLs): 8 hours.")

(export '*default-mx-priority*)
(defvar *default-mx-priority* 50
  "Default MX priority.")

;;;--------------------------------------------------------------------------
;;; Zone variables and structures.

(defvar *zones* (make-hash-table :test #'equal)
  "Map of known zones.")

(export 'zone-find)
(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))

(export 'zone-record)
(defstruct (zone-record (:conc-name zr-))
  "A zone record."
  (name '<unnamed>)
  ttl
  type
  (make-ptr-p nil)
  data)

(export 'zone-subdomain)
(defstruct (zone-subdomain (:conc-name zs-))
  "A subdomain.

   Slightly weird.  Used internally by `zone-process-records', and shouldn't
   escape."
  name
  ttl
  records)

(export '*zone-output-path*)
(defvar *zone-output-path* nil
  "Pathname defaults to merge into output files.

   If this is nil then use the prevailing `*default-pathname-defaults*'.
   This is not the same as capturing the `*default-pathname-defaults*' from
   load time.")

(export '*preferred-subnets*)
(defvar *preferred-subnets* nil
  "Subnets to prefer when selecting defaults.")

;;;--------------------------------------------------------------------------
;;; Zone infrastructure.

(defun zone-file-name (zone type)
  "Choose a file name for a given ZONE and TYPE."
  (merge-pathnames (make-pathname :name (string-downcase zone)
				  :type (string-downcase type))
		   (or *zone-output-path* *default-pathname-defaults*)))

(export 'zone-preferred-subnet-p)
(defun zone-preferred-subnet-p (name)
  "Answer whether NAME (a string or symbol) names a preferred subnet."
  (member name *preferred-subnets* :test #'string-equal))

(export 'preferred-subnet-case)
(defmacro preferred-subnet-case (&body clauses)
  "Execute a form based on which networks are considered preferred.

   The CLAUSES have the form (SUBNETS . FORMS) -- evaluate the first FORMS
   whose SUBNETS (a list or single symbol, not evaluated) are listed in
   `*preferred-subnets*'.  If SUBNETS is the symbol `t' then the clause
   always matches."
  `(cond
    ,@(mapcar (lambda (clause)
		(let ((subnets (car clause)))
		  (cons (cond ((eq subnets t)
			       t)
			      ((listp subnets)
			       `(or ,@(mapcar (lambda (subnet)
						`(zone-preferred-subnet-p
						  ',subnet))
					      subnets)))
			      (t
			       `(zone-preferred-subnet-p ',subnets)))
			(cdr clause))))
	      clauses)))

(export 'zone-parse-host)
(defun zone-parse-host (form &optional tail)
  "Parse a host name FORM from a value in a zone form.

   The underlying parsing is done using `parse-domain-name'.  Here, we
   interpret various kinds of Lisp object specially.  In particular: `nil'
   refers to the TAIL zone (just like a plain `@'); and a symbol is downcased
   before use."
  (let ((name (etypecase form
		(null (make-domain-name :labels nil :absolutep nil))
		(domain-name form)
		(symbol (parse-domain-name (string-downcase form)))
		(string (parse-domain-name form)))))
    (if (null tail) name
	(domain-name-concat name tail))))

(export 'zone-records-sorted)
(defun zone-records-sorted (zone)
  "Return the ZONE's records, in a pleasant sorted order."
  (sort (copy-seq (zone-records zone))
	(lambda (zr-a zr-b)
	  (multiple-value-bind (precp follp)
	      (domain-name< (zr-name zr-a) (zr-name zr-b))
	    (cond (precp t)
		  (follp nil)
		  (t (string< (zr-type zr-a) (zr-type zr-b))))))))

;;;--------------------------------------------------------------------------
;;; Serial numbering.

(export 'make-zone-serial)
(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."
  (let* ((file (zone-file-name name :serial))
	 (last (with-open-file (in file
				   :direction :input
				   :if-does-not-exist nil)
		 (if in (read in)
		     (list 0 0 0 0))))
	 (now (multiple-value-bind
		  (sec min hr dy mon yr dow dstp tz)
		  (get-decoded-time)
		(declare (ignore sec min hr dow dstp tz))
		(list dy mon yr)))
	 (seq (cond ((not (equal now (cdr last))) 0)
		    ((< (car last) 99) (1+ (car last)))
		    (t (error "Run out of sequence numbers for ~A" name)))))
    (safely-writing (out file)
      (format out
	      ";; Serial number file for zone ~A~%~
	       ;;   (LAST-SEQ DAY MONTH YEAR)~%~
	       ~S~%"
	      name
	      (cons seq now)))
    (from-mixed-base '(100 100 100) (reverse (cons seq now)))))

;;;--------------------------------------------------------------------------
;;; Zone form parsing.

(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.

   REC is a list of records of the form

	({ :ttl TTL | TYPE DATA | (LABEL . REC) }*)

   The various kinds of entries have the following meanings.

   :ttl TTL		Set the TTL for subsequent records (at this level of
			  nesting only).

   TYPE DATA		Define a record with a particular TYPE and DATA.
			  Record types are defined using `defzoneparse' and
			  the syntax of the data is idiosyncratic.

   ((LABEL ...) . REC)	Define records for labels within the zone.  Any
			  records defined within REC will have their domains
			  prefixed by each of the LABELs.  A singleton list
			  of labels may instead be written as a single
			  label.  Note, therefore, that

				(host (sub :a \"169.254.1.1\"))

			  defines a record for `host.sub' -- not `sub.host'.

   If REC contains no top-level records, but it does define records for a
   label listed in `*preferred-subnets*', then the records for the first such
   label are also promoted to top-level.

   The FUNC is called for each record encountered, represented as a
   `zone-record' object.  Zone parsers are not called: you get the record
   types and data from the input form; see `zone-parse-records' if you want
   the raw output."

  (labels ((sift (rec ttl)
	     ;; Parse the record list REC into lists of `zone-record' and
	     ;; `zone-subdomain' objects, sorting out TTLs and so on.
	     ;; Returns them as two values.

	     (collecting (top sub)
	       (loop
		 (unless rec
		   (return))
		 (let ((r (pop rec)))
		   (cond ((eq r :ttl)
			  (setf ttl (pop rec)))
			 ((symbolp r)
			  (collect (make-zone-record :type r
						     :ttl ttl
						     :data (pop rec))
				   top))
			 ((listp r)
			  (dolist (name (listify (car r)))
			    (collect (make-zone-subdomain
				      :name (zone-parse-host name)
				      :ttl ttl :records (cdr r))
				     sub)))
			 (t
			  (error "Unexpected record form ~A" (car r))))))))

	   (process (rec dom ttl)
	     ;; Recursirvely process the record list REC, with a list DOM of
	     ;; prefix labels, and a default TTL.  Promote records for a
	     ;; preferred subnet to toplevel if there are no toplevel records
	     ;; already.

	     (multiple-value-bind (top sub) (sift rec ttl)
	       (if (and dom (null top) sub)
		   (let ((preferred
			  (or (find-if
			       (lambda (s)
				 (let ((ll (domain-name-labels (zs-name s))))
				   (and (consp ll) (null (cdr ll))
					(zone-preferred-subnet-p (car ll)))))
			       sub)
			      (car sub))))
		     (when preferred
		       (process (zs-records preferred)
				dom
				(zs-ttl preferred))))
		   (let ((name dom))
		     (dolist (zr top)
		       (setf (zr-name zr) name)
		       (funcall func zr))))
	       (dolist (s sub)
		 (process (zs-records s)
			  (if (null dom) (zs-name s)
			      (domain-name-concat dom (zs-name s)))
			  (zs-ttl s))))))

    ;; Process the records we're given with no prefix.
    (process rec nil ttl)))

(defun zone-parse-head (head)
  "Parse the HEAD of a zone form.

   This has the form

     (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."
  (destructuring-bind
      (raw-zname
       &key
       (source *default-zone-source*)
       (admin (or *default-zone-admin*
		  (format nil "hostmaster@~A" raw-zname)))
       (refresh *default-zone-refresh*)
       (retry *default-zone-retry*)
       (expire *default-zone-expire*)
       (min-ttl *default-zone-min-ttl*)
       (ttl min-ttl)
       (serial (make-zone-serial raw-zname))
       &aux
       (zname (zone-parse-host raw-zname root-domain)))
      (listify head)
    (values zname
	    (timespec-seconds ttl)
	    (make-soa :admin admin
		      :source (zone-parse-host source zname)
		      :refresh (timespec-seconds refresh)
		      :retry (timespec-seconds retry)
		      :expire (timespec-seconds expire)
		      :min-ttl (timespec-seconds min-ttl)
		      :serial serial))))

(export 'defzoneparse)
(defmacro defzoneparse (types (name data list
			       &key (prefix (gensym "PREFIX"))
				    (zname (gensym "ZNAME"))
				    (ttl (gensym "TTL")))
			&body body)
  "Define a new zone record type.

   The arguments are as follows:

   TYPES	A singleton type symbol, or a list of aliases.

   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.

   PREFIX	The prefix tag used in the original form.

   ZNAME	The name of the zone being constructed.

   TTL		The TTL for this record.

   You get to choose your own names for these.  ZNAME, PREFIX and TTL 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 :make-ptr-p)

   These (except MAKE-PTR-P, which defaults to nil) 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))))
    (with-parsed-body (body decls doc) body
      (with-gensyms (col tname ttype tttl tdata tmakeptrp i)
	`(progn
	   (dolist (,i ',types)
	     (setf (get ,i 'zone-parse) ',func))
	   (defun ,func (,prefix ,zname ,data ,ttl ,col)
	     ,@doc
	     ,@decls
	     (let ((,name (if (null ,prefix) ,zname
			      (domain-name-concat ,prefix ,zname))))
	       (flet ((,list (&key ((:name ,tname) ,name)
				   ((:type ,ttype) ,type)
				   ((: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
						   :ttl ,tttl
						   :make-ptr-p ,tmakeptrp)
				 ,col)))
		 ,@body)))
	   ',type)))))

(export 'zone-parse-records)
(defun zone-parse-records (zname ttl records)
  "Parse a sequence of RECORDS and return a list of raw records.

   The records are parsed relative to the zone name ZNAME, and using the
   given default TTL."
  (collecting (rec)
    (flet ((parse-record (zr)
	     (let ((func (or (get (zr-type zr) 'zone-parse)
			     (error "No parser for record ~A."
				    (zr-type zr))))
		   (name (and (zr-name zr) (zr-name zr))))
	       (funcall func name zname (zr-data zr) (zr-ttl zr) rec))))
      (zone-process-records records ttl #'parse-record))))

(export 'zone-parse)
(defun zone-parse (zf)
  "Parse a ZONE form.

   The syntax of a zone form is as follows:

   ZONE-FORM:
     ZONE-HEAD ZONE-RECORD*

   ZONE-RECORD:
     ((NAME*) ZONE-RECORD*)
   | SYM ARGS"
  (multiple-value-bind (zname ttl soa) (zone-parse-head (car zf))
    (make-zone :name zname
	       :default-ttl ttl
	       :soa soa
	       :records (zone-parse-records zname ttl (cdr zf)))))

(export 'zone-create)
(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-text-name zone)))
    (setf (zone-find name) zone)
    name))

(export 'defzone)
(defmacro defzone (soa &body zf)
  "Zone definition macro."
  `(zone-create '(,soa ,@zf)))

(export '*address-family*)
(defvar *address-family* t
  "The default address family.  This is bound by `defrevzone'.")

(export 'defrevzone)
(defmacro defrevzone (head &body zf)
  "Define a reverse zone, with the correct name."
  (destructuring-bind (nets &rest args
			    &key &allow-other-keys
				 (family '*address-family*)
				 prefix-bits)
      (listify head)
    (with-gensyms (ipn)
      `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
	 (let ((*address-family* (ipnet-family ,ipn)))
	   (zone-create `((,(format nil "~A." (reverse-domain ,ipn
							      ,prefix-bits))
			    ,@',(loop for (k v) on args by #'cddr
				      unless (member k
						     '(:family :prefix-bits))
				      nconc (list k v)))
			  ,@',zf)))))))

(export 'map-host-addresses)
(defun map-host-addresses (func addr &key (family *address-family*))
  "Call FUNC for each address denoted by ADDR (a `host-parse' address)."

  (dolist (a (host-addrs (host-parse addr family)))
    (funcall func a)))

(export 'do-host)
(defmacro do-host ((addr spec &key (family *address-family*)) &body body)
  "Evaluate BODY, binding ADDR to each address denoted by SPEC."
  `(dolist (,addr (host-addrs (host-parse ,spec ,family)))
     ,@body))

(export 'zone-set-address)
(defun zone-set-address (rec addrspec &rest args
			 &key (family *address-family*) name ttl make-ptr-p)
  "Write records (using REC) defining addresses for ADDRSPEC."
  (declare (ignore name ttl make-ptr-p))
  (let ((key-args (loop for (k v) on args by #'cddr
			unless (eq k :family)
			nconc (list k v))))
    (do-host (addr addrspec :family family)
      (apply rec :type (ipaddr-rrtype addr) :data addr key-args))))

;;;--------------------------------------------------------------------------
;;; Building raw record vectors.

(defvar *record-vector* nil
  "The record vector under construction.")

(defun rec-ensure (n)
  "Ensure that at least N octets are spare in the current record."
  (let ((want (+ n (fill-pointer *record-vector*)))
	(have (array-dimension *record-vector* 0)))
    (unless (<= want have)
      (adjust-array *record-vector*
		    (do ((new (* 2 have) (* 2 new)))
			((<= want new) new))))))

(export 'rec-octet-vector)
(defun rec-octet-vector (vector &key (start 0) end)
  "Copy (part of) the VECTOR to the output."
  (let* ((end (or end (length vector)))
	 (len (- end start)))
    (rec-ensure len)
    (do ((i start (1+ i)))
	((>= i end))
      (vector-push (aref vector i) *record-vector*))))

(export 'rec-byte)
(defun rec-byte (octets value)
  "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."
  (rec-ensure octets)
  (do ((i (1- octets) (1- i)))
      ((minusp i))
    (vector-push (ldb (byte 8 (* 8 i)) value) *record-vector*)))

(export 'rec-u8)
(defun rec-u8 (value)
  "Append an 8-bit VALUE to the current record."
  (rec-byte 1 value))

(export 'rec-u16)
(defun rec-u16 (value)
  "Append a 16-bit VALUE to the current record."
  (rec-byte 2 value))

(export 'rec-u32)
(defun rec-u32 (value)
  "Append a 32-bit VALUE to the current record."
  (rec-byte 4 value))

(export 'rec-raw-string)
(defun rec-raw-string (s &key (start 0) end)
  "Append (a (substring of) a raw string S to the current record.

   No arrangement is made for reporting the length of the string.  That must
   be done by the caller, if necessary."
  (setf-default end (length s))
  (rec-ensure (- end start))
  (do ((i start (1+ i)))
      ((>= i end))
    (vector-push (char-code (char s i)) *record-vector*)))

(export 'rec-string)
(defun rec-string (s &key (start 0) end (max 255))
  (let* ((end (or end (length s)))
	 (len (- end start)))
    (unless (<= len max)
      (error "String `~A' too long" (subseq s start end)))
    (rec-u8 (- end start))
    (rec-raw-string s :start start :end end)))

(export 'rec-name)
(defun rec-name (name)
  "Append a domain NAME.

   No attempt is made to perform compression of the name."
  (dolist (label (reverse (domain-name-labels name)))
    (rec-string label :max 63))
  (rec-u8 0))

(export 'build-record)
(defmacro build-record (&body body)
  "Build a raw record, and return it as a vector of octets."
  `(let ((*record-vector* (make-array 256
				      :element-type '(unsigned-byte 8)
				      :fill-pointer 0
				      :adjustable t)))
     ,@body
     (copy-seq *record-vector*)))

(export 'zone-record-rrdata)
(defgeneric zone-record-rrdata (type zr)
  (:documentation "Emit (using the `build-record' protocol) RRDATA for ZR.

   The TYPE is a keyword naming the record type.  Return the numeric RRTYPE
   code."))

;;;--------------------------------------------------------------------------
;;; Zone record parsers.

(defzoneparse :a (name data rec)
  ":a IPADDR"
  (zone-set-address #'rec data :make-ptr-p t :family :ipv4))

(defmethod zone-record-rrdata ((type (eql :a)) zr)
  (rec-u32 (ipaddr-addr (zr-data zr)))
  1)

(defzoneparse :aaaa (name data rec)
  ":aaaa IPADDR"
  (zone-set-address #'rec data :make-ptr-p t :family :ipv6))

(defmethod zone-record-rrdata ((type (eql :aaaa)) zr)
  (rec-byte 16 (ipaddr-addr (zr-data zr)))
  28)

(defzoneparse :addr (name data rec)
  ":addr IPADDR"
  (zone-set-address #'rec data :make-ptr-p t))

(defzoneparse :svc (name data rec)
  ":svc IPADDR"
  (zone-set-address #'rec data))

(defzoneparse :ptr (name data rec :zname zname)
  ":ptr HOST"
  (rec :data (zone-parse-host data zname)))

(defmethod zone-record-rrdata ((type (eql :ptr)) zr)
  (rec-name (zr-data zr))
  12)

(defzoneparse :cname (name data rec :zname zname)
  ":cname HOST"
  (rec :data (zone-parse-host data zname)))

(defmethod zone-record-rrdata ((type (eql :cname)) zr)
  (rec-name (zr-data zr))
  5)

(defzoneparse :txt (name data rec)
  ":txt (TEXT*)"
  (rec :data (listify data)))

(defmethod zone-record-rrdata ((type (eql :txt)) zr)
  (mapc #'rec-string (zr-data zr))
  16)

(export '*dkim-pathname-defaults*)
(defvar *dkim-pathname-defaults*
  (make-pathname :directory '(:relative "keys")
		 :type "dkim"))
(pushnew '*dkim-pathname-defaults* *zone-config*)

(defzoneparse :dkim (name data rec)
  ":dkim (KEYFILE {:TAG VALUE}*)"
  (destructuring-bind (file &rest plist) (listify data)
    (let ((things nil) (out nil))
      (labels ((flush ()
		 (when out
		   (push (get-output-stream-string out) things)
		   (setf out nil)))
	       (emit (text)
		 (let ((len (length text)))
		   (when (and out (> (+ (file-position out)
					(length text))
				     64))
		     (flush))
		   (when (plusp len)
		     (cond ((< len 64)
			    (unless out
			      (setf out (make-string-output-stream)))
			    (write-string text out))
			   (t
			    (do ((i 0 j)
				 (j 64 (+ j 64)))
				((>= i len))
			      (push (subseq text i (min j len))
				    things))))))))
	(do ((p plist (cddr p)))
	    ((endp p))
	  (emit (format nil "~(~A~)=~A;" (car p) (cadr p))))
	(emit (with-output-to-string (out)
		(write-string "p=" out)
		(when file
		  (with-open-file
		      (in (merge-pathnames file *dkim-pathname-defaults*))
		    (loop
		      (when (string= (read-line in)
				     "-----BEGIN PUBLIC KEY-----")
			(return)))
		    (loop
		      (let ((line (read-line in)))
			(if (string= line "-----END PUBLIC KEY-----")
			    (return)
			    (write-string line out)))))))))
      (rec :type :txt
	   :data (nreverse things)))))

(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3))
(defenum sshfp-type () (:sha-1 1) (:sha-256 2))

(export '*sshfp-pathname-defaults*)
(defvar *sshfp-pathname-defaults*
  (make-pathname :directory '(:relative "keys") :type "sshfp")
  "Default pathname components for SSHFP records.")
(pushnew '*sshfp-pathname-defaults* *zone-config*)

(defzoneparse :sshfp (name data rec)
  ":sshfp { FILENAME | ((FPR :alg ALG :type HASH)*) }"
  (if (stringp data)
      (with-open-file (in (merge-pathnames data *sshfp-pathname-defaults*))
	(loop (let ((line (read-line in nil)))
		(unless line (return))
		(let ((words (str-split-words line)))
		  (pop words)
		  (when (string= (car words) "IN") (pop words))
		  (unless (and (string= (car words) "SSHFP")
			       (= (length words) 4))
		    (error "Invalid SSHFP record."))
		  (pop words)
		  (destructuring-bind (alg type fpr) words
		    (rec :data (list (parse-integer alg)
				     (parse-integer type)
				     fpr)))))))
      (dolist (item (listify data))
	(destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
	    (listify item)
	  (rec :data (list (lookup-enum alg 'sshfp-algorithm :min 0 :max 255)
			   (lookup-enum type 'sshfp-type :min 0 :max 255)
			   fpr))))))

(defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
  (destructuring-bind (alg type fpr) (zr-data zr)
    (rec-u8 alg)
    (rec-u8 type)
    (do ((i 0 (+ i 2))
	 (n (length fpr)))
	((>= i n))
      (rec-u8 (parse-integer fpr :start i :end (+ i 2) :radix 16))))
  44)

(defenum tlsa-usage ()
  (:ca-constraint 0)
  (:service-certificate-constraint 1)
  (:trust-anchor-assertion 2)
  (:domain-issued-certificate 3))

(defenum tlsa-selector ()
  (:certificate 0)
  (:public-key 1))

(defenum tlsa-match ()
  (:exact 0)
  (:sha-256 1)
  (:sha-512 2))

(defparameter tlsa-pem-alist
  `(("CERTIFICATE" . ,tlsa-selector/certificate)
    ("PUBLIC-KEY" . ,tlsa-selector/public-key)))

(defgeneric raw-tlsa-assoc-data (have want file context)
  (:documentation
   "Convert FILE, and strip off PEM encoding.

   The FILE contains PEM-encoded data of type HAVE -- one of the
   `tlsa-selector' codes.  Return the name of a file containing binary
   DER-encoded data of type WANT instead.  The CONTEXT is a temporary-files
   context.")

  (:method (have want file context)
    (declare (ignore context))
    (error "Can't convert `~A' from selector type ~S to type ~S" file
	   (reverse-enum 'tlsa-selector have)
	   (reverse-enum 'tlsa-selector want)))

  (:method ((have (eql tlsa-selector/certificate))
	    (want (eql tlsa-selector/certificate))
	    file context)
    (let ((temp (temporary-file context "cert")))
      (run-program (list "openssl" "x509" "-outform" "der")
		   :input file :output temp)
      temp))

  (:method ((have (eql tlsa-selector/public-key))
	    (want (eql tlsa-selector/public-key))
	    file context)
    (let ((temp (temporary-file context "pubkey-der")))
      (run-program (list "openssl" "pkey" "-pubin" "-outform" "der")
		   :input file :output temp)
      temp))

  (:method ((have (eql tlsa-selector/certificate))
	    (want (eql tlsa-selector/public-key))
	    file context)
    (let ((temp (temporary-file context "pubkey")))
      (run-program (list "openssl" "x509" "-noout" "-pubkey")
		   :input file :output temp)
      (raw-tlsa-assoc-data want want temp context))))

(defgeneric tlsa-match-data-valid-p (match data)
  (:documentation
   "Check whether the DATA (an octet vector) is valid for the MATCH type.")

  (:method (match data)
    (declare (ignore match data))
    ;; We don't know: assume the user knows what they're doing.
    t)

  (:method ((match (eql tlsa-match/sha-256)) data) (= (length data) 32))
  (:method ((match (eql tlsa-match/sha-512)) data) (= (length data) 64)))

(defgeneric read-tlsa-match-data (match file context)
  (:documentation
   "Read FILE, and return an octet vector for the correct MATCH type.

   CONTEXT is a temporary-files context.")
  (:method ((match (eql tlsa-match/exact)) file context)
    (declare (ignore context))
    (slurp-file file 'octet))
  (:method ((match (eql tlsa-match/sha-256)) file context)
    (hash-file "sha256" file context))
  (:method ((match (eql tlsa-match/sha-512)) file context)
    (hash-file "sha512" file context)))

(defgeneric tlsa-selector-pem-boundary (selector)
  (:documentation
   "Return the PEM boundary string for objects of the SELECTOR type")
  (:method ((selector (eql tlsa-selector/certificate))) "CERTIFICATE")
  (:method ((selector (eql tlsa-selector/public-key))) "PUBLIC KEY")
  (:method (selector) (declare (ignore selector)) nil))

(defun identify-tlsa-selector-file (file)
  "Return the selector type for the data stored in a PEM-format FILE."
  (with-open-file (in file)
    (loop
      (let* ((line (read-line in nil))
	     (len (length line)))
	(unless line
	  (error "No PEM boundary in `~A'" file))
	(when (and (>= len 11)
		   (string= line "-----BEGIN " :end1 11)
		   (string= line "-----" :start1 (- len 5)))
	  (mapenum (lambda (tag value)
		     (declare (ignore tag))
		     (when (string= line
				    (tlsa-selector-pem-boundary value)
				    :start1 11 :end1 (- len 5))
		       (return value)))
		   'tlsa-selector))))))

(defun convert-tlsa-selector-data (data selector match)
  "Convert certificate association DATA as required by SELECTOR and MATCH.

   If DATA is a hex string, we assume that it's already in the appropriate
   form (but if MATCH specifies a hash then we check that it's the right
   length).  If DATA is a pathname, then it should name a PEM file: we
   identify the kind of object stored in the file from the PEM header, and
   convert as necessary.

   The output is an octet vector containing the raw certificate association
   data to include in rrdata."

  (etypecase data
    (string
     (let ((bin (decode-hex data)))
       (unless (tlsa-match-data-valid-p match bin)
	 (error "Invalid data for match type ~S"
		(reverse-enum 'tlsa-match match)))
       bin))
    (pathname
     (with-temporary-files (context :base "tmpfile.tmp")
       (let* ((kind (identify-tlsa-selector-file data))
	      (raw (raw-tlsa-assoc-data kind selector data context)))
	 (read-tlsa-match-data match raw context))))))

(defzoneparse :tlsa (name data rec)
  ":tlsa (((SERVICE|PORT &key :protocol)*) (USAGE SELECTOR MATCH DATA)*)"

  (destructuring-bind (services &rest certinfos) data

    ;; First pass: build the raw-format TLSA record data.
    (let ((records nil))
      (dolist (certinfo certinfos)
	(destructuring-bind (usage-tag selector-tag match-tag data) certinfo
	  (let* ((usage (lookup-enum 'tlsa-usage usage-tag :min 0 :max 255))
		 (selector (lookup-enum 'tlsa-selector selector-tag
					:min 0 :max 255))
		 (match (lookup-enum 'tlsa-match match-tag :min 0 :max 255))
		 (raw (convert-tlsa-selector-data data selector match)))
	    (push (list usage selector match raw) records))))
      (setf records (nreverse records))

      ;; Second pass: attach records for the requested services.
      (dolist (service (listify services))
	(destructuring-bind (svc &key (protocol :tcp)) (listify service)
	  (let* ((port (etypecase svc
			 (integer svc)
			 (keyword (let ((serv (serv-by-name svc protocol)))
				    (unless serv
				      (error "Unknown service `~A'" svc))
				    (serv-port serv)))))
		 (prefixed (domain-name-concat
			    (make-domain-name
			     :labels (list (format nil "_~(~A~)" protocol)
					   (format nil "_~A" port)))
			    name)))
	    (dolist (record records)
	      (rec :name prefixed :data record))))))))

(defmethod zone-record-rrdata ((type (eql :tlsa)) zr)
  (destructuring-bind (usage selector match data) (zr-data zr)
    (rec-u8 usage)
    (rec-u8 selector)
    (rec-u8 match)
    (rec-octet-vector data))
  52)

(defzoneparse :mx (name data rec :zname zname)
  ":mx ((HOST :prio INT :ip IPADDR)*)"
  (dolist (mx (listify data))
    (destructuring-bind
	(mxname &key (prio *default-mx-priority*) ip)
	(listify mx)
      (let ((host (zone-parse-host mxname zname)))
	(when ip (zone-set-address #'rec ip :name host))
	(rec :data (cons host prio))))))

(defmethod zone-record-rrdata ((type (eql :mx)) zr)
  (let ((name (car (zr-data zr)))
	(prio (cdr (zr-data zr))))
    (rec-u16 prio)
    (rec-name name))
  15)

(defzoneparse :ns (name data rec :zname zname)
  ":ns ((HOST :ip IPADDR)*)"
  (dolist (ns (listify data))
    (destructuring-bind
	(nsname &key ip)
	(listify ns)
      (let ((host (zone-parse-host nsname zname)))
	(when ip (zone-set-address #'rec ip :name host))
	(rec :data host)))))

(defmethod zone-record-rrdata ((type (eql :ns)) zr)
  (rec-name (zr-data zr))
  2)

(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 :srv (name data rec :zname zname)
  ":srv (((SERVICE &key :port :protocol)
	  (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 (flet ((prepend (tag tail)
			      (domain-name-concat
			       (make-domain-name
				:labels (list (format nil "_~(~A~)" tag)))
			       tail)))
		       (prepend service (prepend 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 (zone-set-address #'rec ip :name host))
		(rec :name rname
		     :data (list prio weight port host))))))))))

(defmethod zone-record-rrdata ((type (eql :srv)) zr)
  (destructuring-bind (prio weight port host) (zr-data zr)
    (rec-u16 prio)
    (rec-u16 weight)
    (rec-u16 port)
    (rec-name host))
  33)

(defzoneparse :net (name data rec)
  ":net (NETWORK*)"
  (dolist (net (listify data))
    (dolist (ipn (net-ipnets (net-must-find net)))
      (let* ((base (ipnet-net ipn))
	     (rrtype (ipaddr-rrtype base)))
	(flet ((frob (kind addr)
		 (when addr
		   (rec :name (zone-parse-host kind name)
			:type rrtype
			:data addr))))
	  (frob "net" base)
	  (frob "mask" (ipaddr (ipnet-mask ipn) (ipnet-family ipn)))
	  (frob "bcast" (ipnet-broadcast ipn)))))))

(defzoneparse (:rev :reverse) (name data rec)
  ":reverse ((NET &key :prefix-bits :family) ZONE*)

   Add a reverse record each host in the ZONEs (or all zones) that lies
   within NET."
  (setf data (listify data))
  (destructuring-bind (net &key prefix-bits (family *address-family*))
      (listify (car data))

    (dolist (ipn (net-parse-to-ipnets net family))
      (let* ((seen (make-hash-table :test #'equal))
	     (width (ipnet-width ipn))
	     (frag-len (if prefix-bits (- width prefix-bits)
			   (ipnet-changeable-bits width (ipnet-mask ipn)))))
	(dolist (z (or (cdr data) (hash-table-keys *zones*)))
	  (dolist (zr (zone-records (zone-find z)))
	    (when (and (eq (zr-type zr) (ipaddr-rrtype (ipnet-net ipn)))
		       (zr-make-ptr-p zr)
		       (ipaddr-networkp (ipaddr-addr (zr-data zr)) ipn))
	      (let* ((frag (reverse-domain-fragment (zr-data zr)
						    0 frag-len))
		     (name (domain-name-concat frag name))
		     (name-string (princ-to-string name)))
		(unless (gethash name-string seen)
		  (rec :name name :type :ptr
		       :ttl (zr-ttl zr) :data (zr-name zr))
		  (setf (gethash name-string seen) t))))))))))

(defzoneparse :multi (name data rec :zname zname :ttl ttl)
  ":multi (((NET*) &key :start :end :family :suffix) . REC)

   Output multiple records covering a portion of the reverse-resolution
   namespace corresponding to the particular NETs.  The START and END bounds
   default to the most significant variable component of the
   reverse-resolution domain.

   The REC tail is a sequence of record forms (as handled by
   `zone-process-records') to be emitted for each covered address.  Within
   the bodies of these forms, the symbol `*' will be replaced by the
   domain-name fragment corresponding to the current host, optionally
   followed by the SUFFIX.

   Examples:

	(:multi ((delegated-subnet :start 8)
		 :ns (some.ns.delegated.example :ip \"169.254.5.2\")))

	(:multi ((tiny-subnet :suffix \"128.10.254.169.in-addr.arpa\")
		 :cname *))

   Obviously, nested `:multi' records won't work well."

  (destructuring-bind (nets
		       &key start end ((:suffix raw-suffix))
		       (family *address-family*))
      (listify (car data))
    (let ((suffix (if (not raw-suffix)
		      (make-domain-name :labels nil :absolutep nil)
		      (zone-parse-host raw-suffix))))
      (dolist (net (listify nets))
	(dolist (ipn (net-parse-to-ipnets net family))
	  (let* ((addr (ipnet-net ipn))
		 (width (ipaddr-width addr))
		 (comp-width (reverse-domain-component-width addr))
		 (end (round-up (or end
				    (ipnet-changeable-bits width
							   (ipnet-mask ipn)))
				comp-width))
		 (start (round-down (or start (- end comp-width))
				    comp-width))
		 (map (ipnet-host-map ipn)))
	    (multiple-value-bind (host-step host-limit)
		(ipnet-index-bounds map start end)
	      (do ((index 0 (+ index host-step)))
		  ((> index host-limit))
		(let* ((addr (ipnet-index-host map index))
		       (frag (reverse-domain-fragment addr start end))
		       (target (reduce #'domain-name-concat
				       (list frag suffix zname)
				       :from-end t
				       :initial-value root-domain)))
		  (dolist (zr (zone-parse-records (domain-name-concat frag
								      zname)
						  ttl
						  (subst target '*
							 (cdr data))))
		    (rec :name (zr-name zr)
			 :type (zr-type zr)
			 :data (zr-data zr)
			 :ttl (zr-ttl zr)
			 :make-ptr-p (zr-make-ptr-p zr))))))))))))

;;;--------------------------------------------------------------------------
;;; Zone file output.

(export 'zone-write)
(defgeneric zone-write (format zone stream)
  (:documentation "Write ZONE's records to STREAM in the specified FORMAT."))

(defvar *writing-zone* nil
  "The zone currently being written.")

(defvar *zone-output-stream* nil
  "Stream to write zone data on.")

(export 'zone-write-raw-rrdata)
(defgeneric zone-write-raw-rrdata (format zr type data)
  (:documentation "Write an otherwise unsupported record in a given FORMAT.

   ZR gives the record object, which carries the name and TTL; the TYPE is
   the numeric RRTYPE code; and DATA is an octet vector giving the RRDATA.
   This is used by the default `zone-write-record' method to handle record
   types which aren't directly supported by the format driver."))

(export 'zone-write-header)
(defgeneric zone-write-header (format zone)
  (:documentation "Emit the header for a ZONE, in a given FORMAT.

   The header includes any kind of initial comment, the SOA record, and any
   other necessary preamble.  There is no default implementation.

   This is part of the protocol used by the default method on `zone-write';
   if you override that method."))

(export 'zone-write-trailer)
(defgeneric zone-write-trailer (format zone)
  (:documentation "Emit the header for a ZONE, in a given FORMAT.

   The footer may be empty, and is so by default.

   This is part of the protocol used by the default method on `zone-write';
   if you override that method.")
  (:method (format zone)
    (declare (ignore format zone))
    nil))

(export 'zone-write-record)
(defgeneric zone-write-record (format type zr)
  (:documentation "Emit a record of the given TYPE (a keyword).

   The default implementation builds the raw RRDATA and passes it to
   `zone-write-raw-rrdata'.")
  (:method (format type zr)
    (let* (code
	   (data (build-record (setf code (zone-record-rrdata type zr)))))
      (zone-write-raw-rrdata format zr code data))))

(defmethod zone-write (format zone stream)
  "This default method calls `zone-write-header', then `zone-write-record'
   for each record in the zone, and finally `zone-write-trailer'.  While it's
   running, `*writing-zone*' is bound to the zone object, and
  `*zone-output-stream*' to the output stream."
  (let ((*writing-zone* zone)
	(*zone-output-stream* stream))
    (zone-write-header format zone)
    (dolist (zr (zone-records-sorted zone))
      (zone-write-record format (zr-type zr) zr))
    (zone-write-trailer format zone)))

(export 'zone-save)
(defun zone-save (zones &key (format :bind))
  "Write the named ZONES to files.  If no zones are given, write all the
   zones."
  (unless zones
    (setf zones (hash-table-keys *zones*)))
  (safely (safe)
    (dolist (z zones)
      (let ((zz (zone-find z)))
	(unless zz
	  (error "Unknown zone `~A'." z))
	(let ((stream (safely-open-output-stream safe
						 (zone-file-name z :zone))))
	  (zone-write format zz stream)
	  (close stream))))))

;;;--------------------------------------------------------------------------
;;; Bind format output.

(defvar *bind-last-record-name* nil
  "The previously emitted record name.

   Used for eliding record names on output.")

(export 'bind-hostname)
(defun bind-hostname (hostname)
  (let ((zone (domain-name-labels (zone-name *writing-zone*)))
	(name (domain-name-labels hostname)))
    (loop
      (unless (and zone name (string= (car zone) (car name)))
	(return))
      (pop zone) (pop name))
    (flet ((stitch (labels absolutep)
	     (format nil "~{~A~^.~}~@[.~]"
		     (reverse (mapcar #'quotify-label labels))
		     absolutep)))
      (cond (zone (stitch (domain-name-labels hostname) t))
	    (name (stitch name nil))
	    (t "@")))))

(export 'bind-output-hostname)
(defun bind-output-hostname (hostname)
  (let ((name (bind-hostname hostname)))
    (cond ((and *bind-last-record-name*
		(string= name *bind-last-record-name*))
	   "")
	  (t
	   (setf *bind-last-record-name* name)
	   name))))

(defmethod zone-write :around ((format (eql :bind)) zone stream)
  (declare (ignorable zone stream))
  (let ((*bind-last-record-name* nil))
    (call-next-method)))

(defmethod zone-write-header ((format (eql :bind)) zone)
  (format *zone-output-stream* "~
;;; Zone file `~(~A~)'
;;;   (generated ~A)

$ORIGIN ~0@*~(~A.~)
$TTL ~2@*~D~2%"
	    (zone-name zone)
	    (iso-date :now :datep t :timep t)
	    (zone-default-ttl zone))
  (let* ((soa (zone-soa zone))
	 (admin (let* ((name (soa-admin soa))
		       (at (position #\@ name))
		       (copy (format nil "~(~A~)." name)))
		  (when at
		    (setf (char copy at) #\.))
		  copy)))
      (format *zone-output-stream* "~
~A~30TIN SOA~40T~A (
~55@A~60T ;administrator
~45T~10D~60T ;serial
~45T~10D~60T ;refresh
~45T~10D~60T ;retry
~45T~10D~60T ;expire
~45T~10D )~60T ;min-ttl~2%"
	      (bind-output-hostname (zone-name zone))
	      (bind-hostname (soa-source soa))
	      admin
	      (soa-serial soa)
	      (soa-refresh soa)
	      (soa-retry soa)
	      (soa-expire soa)
	      (soa-min-ttl soa))))

(export 'bind-format-record)
(defun bind-format-record (zr format &rest args)
  (format *zone-output-stream*
	  "~A~20T~@[~8D~]~30TIN ~A~40T~?"
	  (bind-output-hostname (zr-name zr))
	  (let ((ttl (zr-ttl zr)))
	    (and (/= ttl (zone-default-ttl *writing-zone*))
		 ttl))
	  (string-upcase (symbol-name (zr-type zr)))
	  format args))

(export 'bind-write-hex)
(defun bind-write-hex (vector remain)
  "Output the VECTOR as hex, in Bind format.

   If the length (in bytes) is less than REMAIN then it's placed on the
   current line; otherwise the Bind line-continuation syntax is used."
  (flet ((output-octet (octet)
	   (format *zone-output-stream* "~(~2,'0X~)" octet)))
    (let ((len (length vector)))
      (cond ((< len remain)
	     (dotimes (i len) (output-octet (aref vector i)))
	     (terpri *zone-output-stream*))
	    (t
	     (format *zone-output-stream* "(")
	     (let ((i 0))
	     (loop
	       (when (>= i len) (return))
	       (let ((limit (min len (+ i 64))))
		 (format *zone-output-stream* "~%~8T")
		 (loop
		   (when (>= i limit) (return))
		   (output-octet (aref vector i))
		   (incf i)))))
	     (format *zone-output-stream* " )~%"))))))

(defmethod zone-write-raw-rrdata ((format (eql :bind)) zr type data)
  (format *zone-output-stream*
	  "~A~20T~@[~8D~]~30TIN TYPE~A~40T\\# ~A "
	  (bind-output-hostname (zr-name zr))
	  (let ((ttl (zr-ttl zr)))
	    (and (/= ttl (zone-default-ttl *writing-zone*))
		 ttl))
	  type
	  (length data))
  (bind-write-hex data 12))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :a)) zr)
  (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr)
  (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr)
  (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr)
  (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr)
  (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr)
  (bind-format-record zr "~2D ~A~%"
		      (cdr (zr-data zr))
		      (bind-hostname (car (zr-data zr)))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr)
  (destructuring-bind (prio weight port host) (zr-data zr)
    (bind-format-record zr "~2D ~5D ~5D ~A~%"
			prio weight port (bind-hostname host))))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr)
  (bind-format-record zr "~{~2D ~2D ~A~}~%" (zr-data zr)))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :tlsa)) zr)
  (destructuring-bind (usage selector match data) (zr-data zr)
    (bind-format-record zr "~2D ~2D ~2D " usage selector match)
    (bind-write-hex data 12)))

(defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr)
  (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}~%"
		      (zr-data zr)))

;;;--------------------------------------------------------------------------
;;; tinydns-data output format.

(export 'tinydns-output)
(defun tinydns-output (code &rest fields)
  (format *zone-output-stream* "~C~{~@[~A~]~^:~}~%" code fields))

(defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data)
  (tinydns-output #\: (zr-name zr) type
		  (with-output-to-string (out)
		    (dotimes (i (length data))
		      (let ((byte (aref data i)))
			(if (or (<= byte 32)
				(>= byte 127)
				(member byte '(#\: #\\) :key #'char-code))
			    (format out "\\~3,'0O" byte)
			    (write-char (code-char byte) out)))))
		  (zr-ttl zr)))

(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :a)) zr)
  (tinydns-output #\+ (zr-name zr)
		  (ipaddr-string (zr-data zr)) (zr-ttl zr)))

(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :aaaa)) zr)
  (tinydns-output #\3 (zr-name zr)
		  (format nil "~(~32,'0X~)" (ipaddr-addr (zr-data zr)))
		  (zr-ttl zr)))

(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ptr)) zr)
  (tinydns-output #\^ (zr-name zr) (zr-data zr) (zr-ttl zr)))

(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :cname)) zr)
  (tinydns-output #\C (zr-name zr) (zr-data zr) (zr-ttl zr)))

(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :ns)) zr)
  (tinydns-output #\& (zr-name zr) nil (zr-data zr) (zr-ttl zr)))

(defmethod zone-write-record ((format (eql :tinydns)) (type (eql :mx)) zr)
  (let ((name (car (zr-data zr)))
	(prio (cdr (zr-data zr))))
    (tinydns-output #\@ (zr-name zr) nil name prio (zr-ttl zr))))

(defmethod zone-write-header ((format (eql :tinydns)) zone)
  (format *zone-output-stream* "~
### Zone file `~(~A~)'
###   (generated ~A)
~%"
	  (zone-name zone)
	  (iso-date :now :datep t :timep t))
  (let ((soa (zone-soa zone)))
    (tinydns-output #\Z
		    (zone-name zone)
		    (soa-source soa)
		    (let* ((name (copy-seq (soa-admin soa)))
			   (at (position #\@ name)))
		      (when at (setf (char name at) #\.))
		      name)
		    (soa-serial soa)
		    (soa-refresh soa)
		    (soa-expire soa)
		    (soa-min-ttl soa)
		    (zone-default-ttl zone))))

;;;----- That's all, folks --------------------------------------------------