chiark / gitweb /
zone.lisp: New utility for hashing files.
[zone] / zone.lisp
index 5e0b0a9..177ded6 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)))))
 
+(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 @@ (defun mapenum (func name)
   "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 @@ (defun rec-ensure (n)
                    (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."