X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/382d444fbf6310ffd1a040fde9c281a08f84eb3d..HEAD:/zone.lisp diff --git a/zone.lisp b/zone.lisp index f68af5d..7649f54 100644 --- a/zone.lisp +++ b/zone.lisp @@ -68,31 +68,66 @@ (defun to-mixed-base (base val) (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." @@ -265,7 +300,7 @@ (defvar *default-zone-source* "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*) @@ -273,19 +308,19 @@ (defvar *default-zone-admin* nil "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*) -(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*) -(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*) -(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*) @@ -869,6 +904,11 @@ (defmethod zone-record-rrdata ((type (eql :cname)) 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 @@ -991,7 +1031,7 @@ (defzoneparse :spf (name data rec :zname zname) (write-char #\space out)) (let* ((width (ipnet-width net)) (mask (ipnet-mask net)) - (plen (ipmask-cidl-slash width mask))) + (plen (ipmask-cidr-slash width mask))) (unless plen (error "invalid netmask in network ~A" net)) (format out "~A~A:~A~@[/~D~]" @@ -1660,20 +1700,20 @@ (defmethod zone-write-header ((format (eql :bind)) zone) 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) - (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)