zone.lisp: Memoize the conversion of TLSA association-data files.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index e43e017..a90490a 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -934,27 +934,29 @@
 
 (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)
@@ -1075,6 +1077,16 @@
                       (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.
 
@@ -1095,10 +1107,19 @@
                (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))))))
+     (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)*)"