zone.lisp: A bunch of functions for building raw DNS records.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index d71536c..ea7a2f1 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -439,7 +439,7 @@
        (ttl min-ttl)
        (serial (make-zone-serial zname)))
       (listify head)
-    (values zname
+    (values (string-downcase zname)
            (timespec-seconds ttl)
            (make-soa :admin admin
                      :source (zone-parse-host source zname)
@@ -632,8 +632,8 @@
   (rec :data (zone-parse-host data zname)))
 
 (defzoneparse :txt (name data rec)
-  ":txt TEXT"
-  (rec :data data))
+  ":txt (TEXT*)"
+  (rec :data (listify data)))
 
 (export '*dkim-pathname-defaults*)
 (defvar *dkim-pathname-defaults*
@@ -821,7 +821,7 @@
                       :ttl (zr-ttl zr) :data (zr-name zr))
                  (setf (gethash name seen) t))))))))))
 
-(defzoneparse (:multi) (name data rec :zname zname :ttl ttl)
+(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
@@ -883,6 +883,73 @@
                       :make-ptr-p (zr-make-ptr-p zr)))))))))))
 
 ;;;--------------------------------------------------------------------------
+;;; 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))))))
+
+(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*)))
+
+(defun rec-u8 (value)
+  "Append an 8-bit VALUE to the current record."
+  (rec-byte 1 value))
+(defun rec-u16 (value)
+  "Append a 16-bit VALUE to the current record."
+  (rec-byte 2 value))
+(defun rec-u32 (value)
+  "Append a 32-bit VALUE to the current record."
+  (rec-byte 4 value))
+
+(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*)))
+
+(defun rec-name (s)
+  "Append a domain name S.
+
+   No attempt is made to perform compression of the name."
+  (let ((i 0) (n (length s)))
+    (loop (let* ((dot (position #\. s :start i))
+                (lim (or dot n)))
+           (rec-u8 (- lim i))
+           (rec-raw-string s :start i :end lim)
+           (if dot
+               (setf i (1+ dot))
+               (return))))
+    (when (< i n)
+      (rec-u8 0))))
+
+(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*)))
+
+;;;--------------------------------------------------------------------------
 ;;; Zone file output.
 
 (export 'zone-write)
@@ -955,7 +1022,8 @@ $TTL ~2@*~D~2%"
                    (setf (char copy at) #\.))
                  copy)))
       (format stream "~
-~A~30TIN SOA~40T~A ~A (
+~A~30TIN SOA~40T~A (
+~55@A~60T ;administrator
 ~45T~10D~60T ;serial
 ~45T~10D~60T ;refresh
 ~45T~10D~60T ;retry
@@ -1002,7 +1070,7 @@ $TTL ~2@*~D~2%"
     (cons "~2D ~2D ~A" data))
   (:method ((type (eql :txt)) data)
     (cons "~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]"
-         (mapcar #'stringify (listify data)))))
+         (mapcar #'stringify data))))
 
 (defmethod bind-record (type zr)
   (destructuring-bind (format &rest args)