X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/3986e085fba0fa1aad7c04474060d083cc96b261..29d9eca406634f25c1bdae7ca659760454f1100a:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 3aa25ba..7db70b1 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -111,6 +111,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 +202,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.
 
@@ -690,6 +733,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."
@@ -861,8 +914,8 @@
       (rec :type :txt
 	   :data (nreverse things)))))
 
-(defenum sshfp-algorithm (rsa 1) (dsa 2) (ecdsa 3))
-(defenum sshfp-type (sha-1 1) (sha-256 2))
+(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3))
+(defenum sshfp-type () (:sha-1 1) (:sha-256 2))
 
 (export '*sshfp-pathname-defaults*)
 (defvar *sshfp-pathname-defaults*
@@ -903,6 +956,182 @@
       (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))))))
+
+(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
+     (with-temporary-files (context :base "tmpfile.tmp")
+       (let* ((kind (identify-tlsa-selector-file data))
+	      (raw (raw-tlsa-assoc-data kind selector data context)))
+	 (read-tlsa-match-data match raw context))))))
+
+(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)
+
 (defzoneparse :mx (name data rec :zname zname)
   ":mx ((HOST :prio INT :ip IPADDR)*)"
   (dolist (mx (listify data))
@@ -1245,7 +1474,7 @@ $TTL ~2@*~D~2%"
 (export 'bind-format-record)
 (defun bind-format-record (zr format &rest args)
   (format *zone-output-stream*
-	  "~A~20T~@[~8D~]~30TIN ~A~40T~?~%"
+	  "~A~20T~@[~8D~]~30TIN ~A~40T~?"
 	  (bind-output-hostname (zr-name zr))
 	  (let ((ttl (zr-ttl zr)))
 	    (and (/= ttl (zone-default-ttl *writing-zone*))
@@ -1253,61 +1482,78 @@ $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))))
+  (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :aaaa)) zr)
-  (bind-format-record zr "~A" (ipaddr-string (zr-data zr))))
+  (bind-format-record zr "~A~%" (ipaddr-string (zr-data zr))))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ptr)) zr)
-  (bind-format-record zr "~A" (bind-hostname (zr-data zr))))
+  (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr)
-  (bind-format-record zr "~A" (bind-hostname (zr-data 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))))
+  (bind-format-record zr "~A~%" (bind-hostname (zr-data zr))))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :mx)) zr)
-  (bind-format-record zr "~2D ~A"
+  (bind-format-record zr "~2D ~A~%"
 		      (cdr (zr-data zr))
 		      (bind-hostname (car (zr-data zr)))))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :srv)) zr)
   (destructuring-bind (prio weight port host) (zr-data zr)
-    (bind-format-record zr "~2D ~5D ~5D ~A"
+    (bind-format-record zr "~2D ~5D ~5D ~A~%"
 			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)))
+  (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 :txt)) zr)
-  (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}" (zr-data zr)))
+  (bind-format-record zr "~{~#[\"\"~;~S~:;(~@{~%~8T~S~} )~]~}~%"
+		      (zr-data zr)))
 
 ;;;--------------------------------------------------------------------------
 ;;; tinydns-data output format.