X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/0516211301c96f9394b73f36575b72ad21f51e4c..HEAD:/zone.lisp diff --git a/zone.lisp b/zone.lisp index e819cd1..7649f54 100644 --- a/zone.lisp +++ b/zone.lisp @@ -26,7 +26,7 @@ (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)) @@ -35,6 +35,14 @@ ;;;-------------------------------------------------------------------------- ;;; 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))) @@ -60,31 +68,66 @@ (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." @@ -111,6 +154,36 @@ (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. @@ -172,6 +245,19 @@ "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. @@ -186,10 +272,6 @@ 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." @@ -204,6 +286,10 @@ name records) +(export 'zone-text-name) +(defun zone-text-name (zone) + (princ-to-string (zone-name zone))) + ;;;-------------------------------------------------------------------------- ;;; Zone defaults. It is intended that scripts override these. @@ -214,28 +300,28 @@ "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.") +(defvar *default-zone-refresh* '(8 :hours) + "Default zone refresh interval: eight hours.") (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.") +(defvar *default-zone-retry* '(20 :minutes) + "Default zone retry interval: twenty minutes.") (export '*default-zone-expire*) -(defvar *default-zone-expire* (* 14 24 60 60) - "Default zone expiry time: two weeks.") +(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) - "Default zone minimum TTL/negative TTL: four hours.") +(defvar *default-zone-min-ttl* '(4 :hours) + "Default zone minimum/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.") +(defvar *default-zone-ttl* '(4 :hours) + "Default zone TTL (for records without explicit TTLs): four hours.") (export '*default-mx-priority*) (defvar *default-mx-priority* 50 @@ -446,7 +532,7 @@ :ttl ttl :records (cdr r)) sub))) (t - (error "Unexpected record form ~A" (car r)))))))) + (error "Unexpected record form ~A" r))))))) (process (rec dom ttl) ;; Recursirvely process the record list REC, with a list DOM of @@ -501,7 +587,7 @@ (retry *default-zone-retry*) (expire *default-zone-expire*) (min-ttl *default-zone-min-ttl*) - (ttl min-ttl) + (ttl *default-zone-ttl*) (serial (make-zone-serial raw-zname)) &aux (zname (zone-parse-host raw-zname root-domain))) @@ -636,15 +722,15 @@ (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) + &key (family '*address-family*) + prefix-bits + &allow-other-keys) (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)) + (zone-create `((,(format nil "~A" (reverse-domain ,ipn + ,prefix-bits)) ,@',(loop for (k v) on args by #'cddr unless (member k '(:family :prefix-bits)) @@ -690,6 +776,16 @@ (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." @@ -715,7 +811,7 @@ (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." @@ -799,110 +895,463 @@ ":cname HOST" (rec :data (zone-parse-host data zname))) +(defzoneparse :dname (name data rec :zname zname) + ":dname HOST" + (rec :data (zone-parse-host data zname))) + (defmethod zone-record-rrdata ((type (eql :cname)) zr) (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*)" - (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) +(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") :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)) + (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)) (export '*sshfp-pathname-defaults*) (defvar *sshfp-pathname-defaults* - (make-pathname :directory '(:relative "keys") - :type "sshfp")) + (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)))))) + (typecase data + ((or string pathname) + (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 fprhex) words + (rec :data (list (parse-integer alg) + (parse-integer type) + (decode-hex fprhex))))))))) + (t + (dolist (item (listify data)) + (destructuring-bind (fprhex &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) + (decode-hex fprhex)))))))) (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)))) + (rec-octet-vector fpr)) 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)))))) + +(export '*tlsa-pathname-defaults*) +(defvar *tlsa-pathname-defaults* + (list (make-pathname :directory '(:relative "certs") :type "cert") + (make-pathname :directory '(:relative "keys") :type "pub")) + "Default pathname components for TLSA records.") +(pushnew '*tlsa-pathname-defaults* *zone-config*) + +(defparameter *tlsa-data-cache* (make-hash-table :test #'equal) + "Cache for TLSA association data; keys are (DATA SELECTOR MATCH).") + +(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 + (let ((key (list data selector match))) + (or (gethash key *tlsa-data-cache*) + (with-temporary-files (context :base (make-pathname :type "tmp")) + (let* ((file (or (find-if #'probe-file + (mapcar (lambda (template) + (merge-pathnames data + template)) + *tlsa-pathname-defaults*)) + (error "Couldn't find TLSA file `~A'" data))) + (kind (identify-tlsa-selector-file file)) + (raw (raw-tlsa-assoc-data kind selector file context)) + (binary (read-tlsa-match-data match raw context))) + (setf (gethash key *tlsa-data-cache*) binary)))))))) + +(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) + +(defenum dnssec-algorithm () + (:rsamd5 1) + (:dh 2) + (:dsa 3) + (:rsasha1 5) + (:dsa-nsec3-sha1 6) + (:rsasha1-nsec3-sha1 7) + (:rsasha256 8) + (:rsasha512 10) + (:ecc-gost 12) + (:ecdsap256sha256 13) + (:ecdsap384sha384 14)) + +(defenum dnssec-digest () + (:sha1 1) + (:sha256 2)) + +(defzoneparse :ds (name data rec) + ":ds ((TAG ALGORITHM DIGEST-TYPE DIGEST)*)" + (dolist (ds data) + (destructuring-bind (tag alg hashtype hash) ds + (rec :data (list tag + (lookup-enum 'dnssec-algorithm alg :min 0 :max 255) + (lookup-enum 'dnssec-digest hashtype :min 0 :max 255) + (decode-hex hash)))))) + +(defmethod zone-record-rrdata ((type (eql :ds)) zr) + (destructuring-bind (tag alg hashtype hash) zr + (rec-u16 tag) + (rec-u8 alg) + (rec-u8 hashtype) + (rec-octet-vector hash))) + (defzoneparse :mx (name data rec :zname zname) ":mx ((HOST :prio INT :ip IPADDR)*)" (dolist (mx (listify data)) @@ -980,6 +1429,29 @@ (rec-name host)) 33) +(defenum caa-flag () (:critical 128)) + +(defzoneparse :caa (name data rec) + ":caa ((TAG VALUE FLAG*)*)" + (dolist (prop data) + (destructuring-bind (tag value &rest flags) prop + (setf flags (reduce #'logior + (mapcar (lambda (item) + (lookup-enum 'caa-flag item + :min 0 :max 255)) + flags))) + (ecase tag + ((:issue :issuewild :iodef) + (rec :name name + :data (list flags tag value))))))) + +(defmethod zone-record-rrdata ((type (eql :caa)) zr) + (destructuring-bind (flags tag value) (zr-data zr) + (rec-u8 flags) + (rec-string (string-downcase tag)) + (rec-raw-string value)) + 257) + (defzoneparse :net (name data rec) ":net (NETWORK*)" (dolist (net (listify data)) @@ -1167,7 +1639,8 @@ (error "Unknown zone `~A'." z)) (let ((stream (safely-open-output-stream safe (zone-file-name z :zone)))) - (zone-write format zz stream)))))) + (zone-write format zz stream) + (close stream)))))) ;;;-------------------------------------------------------------------------- ;;; Bind format output. @@ -1227,20 +1700,20 @@ $TTL ~2@*~D~2%" 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) @@ -1253,30 +1726,41 @@ $TTL ~2@*~D~2%" (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" + "~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)) - (let* ((hex (with-output-to-string (out) - (dotimes (i (length data)) - (format out "~(~2,'0X~)" (aref data i))))) - (len (length hex))) - (cond ((< len 24) - (format *zone-output-stream* " ~A~%" hex)) - (t - (format *zone-output-stream* " (") - (let ((i 0)) - (loop - (when (>= i len) (return)) - (let ((j (min (+ i 64) len))) - (format *zone-output-stream* "~%~8T~A" (subseq hex i j)) - (setf i j)))) - (format *zone-output-stream* " )~%"))))) + (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)))) @@ -1290,6 +1774,9 @@ $TTL ~2@*~D~2%" (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 :dname)) 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)))) @@ -1304,7 +1791,23 @@ $TTL ~2@*~D~2%" 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))) + (destructuring-bind (alg type fpr) (zr-data zr) + (bind-format-record zr "~2D ~2D " alg type) + (bind-write-hex fpr 12))) + +(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 :caa)) zr) + (destructuring-bind (flags tag value) (zr-data zr) + (bind-format-record zr "~3D ~(~A~) ~S~%" flags tag value))) + +(defmethod zone-write-record ((format (eql :bind)) (type (eql :ds)) zr) + (destructuring-bind (tag alg hashtype hash) (zr-data zr) + (bind-format-record zr "~5D ~2D ~2D " tag alg hashtype) + (bind-write-hex hash 12))) (defmethod zone-write-record ((format (eql :bind)) (type (eql :txt)) zr) (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}~%"