zone.lisp: New utility for hashing files.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 53800f06bc3a29cc746d54cc36df6471431b8909..177ded6b292c7601a2befb06f1135906cb43c3d0 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -111,6 +111,36 @@ (defun iso-date (&optional time &key datep timep (sep #\ ))
       (when timep
        (format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 
       (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.
 
 (defmacro defenum (name (&key export) &body values)
   "Set up symbol properties for manifest constants.
 


@@ -172,6 +202,19 @@ (defun mapenum (func name)
   "Call FUNC on TAG/VALUE pairs from the enumeration called NAME."
   (maphash func (get name 'enum-forward)))
 
   "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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 


@@ -690,6 +733,16 @@ (defun rec-ensure (n)
                    (do ((new (* 2 have) (* 2 new)))
                        ((<= want new) new))))))
 
                    (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."
 (export 'rec-byte)
 (defun rec-byte (octets value)
   "Append an unsigned byte, OCTETS octets wide, with VALUE, to the record."


@@ -861,8 +914,8 @@ (defzoneparse :dkim (name data rec)
       (rec :type :txt
           :data (nreverse things)))))
 
       (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*
 
 (export '*sshfp-pathname-defaults*)
 (defvar *sshfp-pathname-defaults*


@@ -1245,7 +1298,7 @@ (defmethod zone-write-header ((format (eql :bind)) zone)
 (export 'bind-format-record)
 (defun bind-format-record (zr format &rest args)
   (format *zone-output-stream*
 (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*))
          (bind-output-hostname (zr-name zr))
          (let ((ttl (zr-ttl zr)))
            (and (/= ttl (zone-default-ttl *writing-zone*))


@@ -1253,61 +1306,73 @@ (defun bind-format-record (zr format &rest args)
          (string-upcase (symbol-name (zr-type zr)))
          format args))
 
          (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*
 (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))
          (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)
 
 (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)
 
 (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)
 
 (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)
 
 (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)
 
 (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)
 
 (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)
                      (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)
                        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 :txt)) zr)
 
 (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; tinydns-data output format.


@@ -1322,7 +1387,7 @@ (defmethod zone-write-raw-rrdata ((format (eql :tinydns)) zr type data)
                    (dotimes (i (length data))
                      (let ((byte (aref data i)))
                        (if (or (<= byte 32)
                    (dotimes (i (length data))
                      (let ((byte (aref data i)))
                        (if (or (<= byte 32)

-                               (>= byte 128)
+                               (>= byte 127)

                                (member byte '(#\: #\\) :key #'char-code))
                            (format out "\\~3,'0O" byte)
                            (write-char (code-char byte) out)))))
                                (member byte '(#\: #\\) :key #'char-code))
                            (format out "\\~3,'0O" byte)
                            (write-char (code-char byte) out)))))