zone-run: Add simple script for running `zone' without a vast image.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index a80428fa6882404964f63faf0563d26616e324d8..7649f540f0dfa998ca03dc4ebfaa1c30f8dfbd06 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -26,7 +26,7 @@
 
 (defpackage #:zone
   (:use #:common-lisp
 
 (defpackage #:zone
   (:use #:common-lisp

-       #:mdw.base #:mdw.str #:collect #:safely
+       #:mdw.base #:mdw.str #:anaphora #:collect #:safely

        #:net #:services)
   (:import-from #:net #:round-down #:round-up))
 
        #:net #:services)
   (:import-from #:net #:round-down #:round-up))
 


@@ -68,31 +68,66 @@ (defun to-mixed-base (base val)
        (push r a)
        (setf val q)))))
 
        (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))))))
+(let ((unit-scale (make-hash-table))
+      (scales nil))
+
+  (dolist (item `(((:second :seconds :sec :secs :s) ,1)
+                 ((:minute :minutes :min :mins :m) ,60)
+                 ((:hour :hours :hr :hrs :h) ,(* 60 60))
+                 ((:day :days :dy :dys :d) ,(* 24 60 60))
+                 ((:week :weeks :wk :wks :w) ,(* 7 24 60 60))))
+    (destructuring-bind
+       ((&whole units singular plural &rest hunoz) scale) item
+      (declare (ignore hunoz))
+      (dolist (unit units) (setf (gethash unit unit-scale) scale))
+      (push (cons scale (cons singular plural)) scales)))
+  (setf scales (sort scales #'> :key #'car))
+
+  (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."
+    (labels ((convert (acc ts)
+              (cond ((null ts) acc)
+                    ((realp ts) (+ acc (floor ts)))
+                    ((atom ts) (error "Unknown timespec format ~A" ts))
+                    (t
+                     (destructuring-bind
+                         (count &optional unit &rest tail) ts
+                       (let ((scale
+                               (acond ((null unit) 1)
+                                      ((gethash (intern (string-upcase
+                                                         (stringify unit))
+                                                        :keyword)
+                                                unit-scale)
+                                       it)
+                                      (t
+                                       (error "Unknown time unit ~S"
+                                              unit)))))
+                         (convert (+ acc (to-integer (* count scale)))
+                                  tail)))))))
+      (convert 0 ts)))
+
+  (export 'seconds-timespec)
+  (defun seconds-timespec (secs)
+    "Convert a count of seconds to a time specification."
+    (let ((sign (if (minusp secs) -1 +1)) (secs (abs secs)))
+    (collecting ()
+      (loop (cond ((zerop secs)
+                  (unless (collected) (collect-append '(0 :seconds)))
+                  (return))
+                 ((< secs 60)
+                  (collect (* secs sign))
+                  (collect (if (= secs 1) :second :seconds))
+                  (return))
+                 (t
+                  (let ((match (find secs scales :test #'>= :key #'car)))
+                    (multiple-value-bind (quot rem) (floor secs (car match))
+                      (collect (* quot sign))
+                      (collect (if (= quot 1) (cadr match) (cddr match)))
+                      (setf secs rem))))))))))

 
 (defun hash-table-keys (ht)
   "Return a list of the keys in hashtable HT."
 
 (defun hash-table-keys (ht)
   "Return a list of the keys in hashtable HT."


@@ -265,7 +300,7 @@ (defvar *default-zone-source*
   "The default zone source: the current host's name.")
 
 (export '*default-zone-refresh*)
   "The default zone source: the current host's name.")
 
 (export '*default-zone-refresh*)

-(defvar *default-zone-refresh* (* 8 60 60)
+(defvar *default-zone-refresh* '(8 :hours)

   "Default zone refresh interval: eight hours.")
 
 (export '*default-zone-admin*)
   "Default zone refresh interval: eight hours.")
 
 (export '*default-zone-admin*)


@@ -273,19 +308,19 @@ (defvar *default-zone-admin* nil
   "Default zone administrator's email address.")
 
 (export '*default-zone-retry*)
   "Default zone administrator's email address.")
 
 (export '*default-zone-retry*)

-(defvar *default-zone-retry* (* 20 60)
+(defvar *default-zone-retry* '(20 :minutes)

   "Default zone retry interval: twenty minutes.")
 
 (export '*default-zone-expire*)
   "Default zone retry interval: twenty minutes.")
 
 (export '*default-zone-expire*)

-(defvar *default-zone-expire* (* 3 24 60 60)
+(defvar *default-zone-expire* '(3 :days)

   "Default zone expiry time: three days.")
 
 (export '*default-zone-min-ttl*)
   "Default zone expiry time: three days.")
 
 (export '*default-zone-min-ttl*)

-(defvar *default-zone-min-ttl* (* 4 60 60)
+(defvar *default-zone-min-ttl* '(4 :hours)

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

-(defvar *default-zone-ttl* (* 4 60 60)
+(defvar *default-zone-ttl* '(4 :hours)

   "Default zone TTL (for records without explicit TTLs): four hours.")
 
 (export '*default-mx-priority*)
   "Default zone TTL (for records without explicit TTLs): four hours.")
 
 (export '*default-mx-priority*)


@@ -776,7 +811,7 @@ (defun rec-u32 (value)
 
 (export 'rec-raw-string)
 (defun rec-raw-string (s &key (start 0) end)
 
 (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.
+  "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."
 
    No arrangement is made for reporting the length of the string.  That must
    be done by the caller, if necessary."


@@ -868,14 +903,152 @@ (defmethod zone-record-rrdata ((type (eql :cname)) zr)
   (rec-name (zr-data zr))
   5)
 
   (rec-name (zr-data zr))
   5)
 

+(defun split-txt-data (data)
+  "Split the string DATA into pieces small enough to fit in a TXT record.
+
+   Return a list of strings L such that (a) (apply #'concatenate 'string L)
+   is equal to the original string DATA, and (b) (every (lambda (s) (<=
+   (length s) 255)) L) is true."
+  (collecting ()
+    (let ((i 0) (n (length data)))
+      (loop
+       (let ((end (+ i 255)))
+         (when (<= n end) (return))
+         (let ((split (acond ((position #\; data :from-end t
+                                        :start i :end end)
+                              (+ it 1))
+                             ((position #\space data :from-end t
+                                        :start i :end end)
+                              (+ it 1))
+                             (t end))))
+           (loop
+             (when (or (>= split end)
+                       (char/= (char data split) #\space))
+               (return))
+             (incf split))
+           (collect (subseq data i split))
+           (setf i split))))
+      (collect (subseq data i)))))
+

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

-  (rec :data (listify data)))
+  (rec :data (cond ((stringp data) (split-txt-data data))
+                  (t
+                   (dolist (piece data)
+                     (unless (<= (length piece) 255)
+                       (error "`:txt' record piece `~A' too long" piece)))
+                   data))))

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

+(defzoneparse :spf (name data rec :zname zname)
+  ":spf ([[ (:version STRING) |
+           ({:pass | :fail | :soft | :shrug}
+            {:all |
+             :include LABEL |
+             :a [[ :label LABEL | :v4mask MASK | :v6mask MASK ]] |
+             :ptr [LABEL] |
+             {:ip | :ip4 | :ip6} {STRING | NET | HOST}}) |
+           (:redirect LABEL) |
+           (:exp LABEL) ]])"
+  (rec :type :txt
+       :data
+       (split-txt-data
+       (with-output-to-string (out)
+         (let ((firstp t))
+           (dolist (item data)
+             (if firstp (setf firstp nil)
+                 (write-char #\space out))
+             (let ((head (car item))
+                   (tail (cdr item)))
+             (ecase head
+               (:version (destructuring-bind (ver) tail
+                           (format out "v=~A" ver)))
+               ((:pass :fail :soft :shrug)
+                (let ((qual (ecase head
+                              (:pass #\+)
+                              (:fail #\-)
+                              (:soft #\~)
+                              (:shrug #\?))))
+                  (setf head (pop tail))
+                  (ecase head
+                    (:all
+                     (destructuring-bind () tail
+                       (format out "~Aall" qual)))
+                    ((:include :exists)
+                     (destructuring-bind (label) tail
+                       (format out "~A~(~A~):~A"
+                               qual head
+                               (if (stringp label) label
+                                   (zone-parse-host label zname)))))
+                    ((:a :mx)
+                     (destructuring-bind (&key label v4mask v6mask) tail
+                       (format out "~A~(~A~)~@[:~A~]~@[/~D~]~@[//~D~]"
+                               qual head
+                               (cond ((null label) nil)
+                                     ((stringp label) label)
+                                     (t (zone-parse-host label zname)))
+                               v4mask
+                               v6mask)))
+                    (:ptr
+                     (destructuring-bind (&optional label) tail
+                       (format out "~Aptr~@[:~A~]"
+                               qual
+                               (cond ((null label) nil)
+                                     ((stringp label) label)
+                                     (t (zone-parse-host label zname))))))
+                    ((:ip :ip4 :ip6)
+                     (let* ((family (ecase head
+                                      (:ip t)
+                                      (:ip4 :ipv4)
+                                      (:ip6 :ipv6)))
+                            (nets
+                             (collecting ()
+                               (dolist (net tail)
+                                 (acond
+                                   ((host-find net)
+                                    (let ((any nil))
+                                      (dolist (addr (host-addrs it))
+                                        (when (or (eq family t)
+                                                  (eq family
+                                                      (ipaddr-family addr)))
+                                          (setf any t)
+                                          (collect (make-ipnet
+                                                    addr
+                                                    (ipaddr-width addr)))))
+                                      (unless any
+                                        (error
+                                         "No matching addresses for `~A'"
+                                         net))))
+                                   (t
+                                    (collect-append
+                                     (net-parse-to-ipnets net family))))))))
+                       (setf firstp t)
+                       (dolist (net nets)
+                         (if firstp (setf firstp nil)
+                             (write-char #\space out))
+                         (let* ((width (ipnet-width net))
+                                (mask (ipnet-mask net))
+                                (plen (ipmask-cidr-slash width mask)))
+                           (unless plen
+                             (error "invalid netmask in network ~A" net))
+                           (format out "~A~A:~A~@[/~D~]"
+                                   qual
+                                   (ecase (ipnet-family net)
+                                     (:ipv4 "ip4")
+                                     (:ipv6 "ip6"))
+                                   (ipnet-net net)
+                                   (and (/= plen width) plen)))))))))
+               ((:redirect :exp)
+                (destructuring-bind (label) tail
+                  (format out "~(~A~)=~A"
+                          head
+                          (if (stringp label) label
+                              (zone-parse-host label zname)))))))))))))
+
+

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


@@ -885,47 +1058,29 @@ (pushnew '*dkim-pathname-defaults* *zone-config*)
 (defzoneparse :dkim (name data rec)
   ":dkim (KEYFILE {:TAG VALUE}*)"
   (destructuring-bind (file &rest plist) (listify data)
 (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)))))
+    (rec :type :txt
+        :data
+        (split-txt-data
+         (with-output-to-string (out)
+           (format out "~{~(~A~)=~A; ~}" plist)
+           (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)))
+                   (when (string= line "-----END PUBLIC KEY-----")
+                     (return))
+                   (write-string line out))))))))))
+
+(defzoneparse :dmarc (name data rec)
+  ":dmarc ({:TAG VALUE}*)"
+  (rec :type :txt
+       :data (split-txt-data (format nil "~{~(~A~)=~A~^; ~}" data))))

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


@@ -1545,20 +1700,20 @@ (defmethod zone-write-header ((format (eql :bind)) zone)
                  copy)))
       (format *zone-output-stream* "~
 ~A~30TIN SOA~40T~A (
                  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%"
+~55@A~58T; administrator
+~45T~10D~58T; serial
+~45T~10D~58T; refresh: ~{~D ~(~A~)~^ ~}
+~45T~10D~58T; retry: ~{~D ~(~A~)~^ ~}
+~45T~10D~58T; expire: ~{~D ~(~A~)~^ ~}
+~45T~10D )~58T; min-ttl: ~{~D ~(~A~)~^ ~}~2%"

              (bind-output-hostname (zone-name zone))
              (bind-hostname (soa-source soa))
              admin
              (soa-serial soa)
              (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))))
+             (soa-refresh soa) (seconds-timespec (soa-refresh soa))
+             (soa-retry soa) (seconds-timespec (soa-retry soa))
+             (soa-expire soa) (seconds-timespec (soa-expire soa))
+             (soa-min-ttl soa) (seconds-timespec (soa-min-ttl soa)))))

 
 (export 'bind-format-record)
 (defun bind-format-record (zr format &rest args)
 
 (export 'bind-format-record)
 (defun bind-format-record (zr format &rest args)