X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/0516211301c96f9394b73f36575b72ad21f51e4c..65391c5d2d115b52c068c778bddc4d50422f8d39:/zone.lisp diff --git a/zone.lisp b/zone.lisp index e819cd1..2267026 100644 --- a/zone.lisp +++ b/zone.lisp @@ -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))) @@ -111,6 +119,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 +210,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 +237,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 +251,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. @@ -446,7 +497,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 @@ -636,15 +687,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 +741,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." @@ -815,6 +876,7 @@ (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}*)" @@ -861,37 +923,40 @@ (rec :type :txt :data (nreverse things))))) -(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3)) +(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 fpr) words + (rec :data (list (parse-integer alg) + (parse-integer type) + fpr)))))))) + (t + (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) @@ -903,6 +968,234 @@ (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)))))) + +(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 +1273,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 +1483,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. @@ -1253,30 +1570,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)))) @@ -1306,6 +1634,20 @@ $TTL ~2@*~D~2%" (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 :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~} )~]~}~%" (zr-data zr)))