X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/807e319f86d552c12b7436eb3027bcf55608d501..476808d8bacf084e6632b3aebbe14c28ec49e09a:/zone.lisp diff --git a/zone.lisp b/zone.lisp index d855d0f..177ded6 100644 --- a/zone.lisp +++ b/zone.lisp @@ -111,6 +111,110 @@ (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. + + The VALUES are a list of (TAG VALUE) pairs. Each TAG is a symbol; we set + the NAME property on TAG to VALUE, and export TAG. There are also handy + hash-tables mapping in the forward and reverse directions, in the name + symbol's `enum-forward' and `enum-reverse' properties." + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,(let*/gensyms (export) + (with-gensyms (forward reverse valtmp) + `(let ((,forward (make-hash-table)) + (,reverse (make-hash-table))) + (when ,export (export ',name)) + ,@(mapcar (lambda (item) + (destructuring-bind (tag value) item + (let ((constant + (intern (concatenate 'string + (symbol-name name) + "/" + (symbol-name tag))))) + `(let ((,valtmp ,value)) + (when ,export + (export ',constant) + (when (eq (symbol-package ',tag) *package*) + (export ',tag))) + (defconstant ,constant ,valtmp) + (setf (get ',tag ',name) ,value + (gethash ',tag ,forward) ,valtmp + (gethash ,valtmp ,reverse) ',tag))))) + values) + (setf (get ',name 'enum-forward) ,forward + (get ',name 'enum-reverse) ,reverse)))))) + +(defun lookup-enum (name tag &key min max) + "Look up a TAG in an enumeration. + + If TAG is a symbol, check its NAME property; if it's a fixnum then take it + as it is. Make sure that it's between MIN and MAX, if they're not nil." + (let ((value (etypecase tag + (fixnum tag) + (symbol (or (get tag name) + (error "~S is not a known ~A" tag name)))))) + (unless (and (or (null min) (<= min value)) + (or (null max) (<= value max))) + (error "Value ~S out of range for ~A" value name)) + value)) + +(defun reverse-enum (name value) + "Reverse-lookup of a VALUE in enumeration NAME. + + If a tag for the VALUE is found, return it and `t'; otherwise return VALUE + unchanged and `nil'." + (multiple-value-bind (tag foundp) (gethash value (get name 'enum-reverse)) + (if foundp + (values tag t) + (values value nil)))) + +(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. @@ -629,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." @@ -771,13 +885,15 @@ (defzoneparse :dkim (name data rec) (flush)) (when (plusp len) (cond ((< len 64) - (unless out (setf out (make-string-output-stream))) + (unless out + (setf out (make-string-output-stream))) (write-string text out)) (t (do ((i 0 j) (j 64 (+ j 64))) ((>= i len)) - (push (subseq text i (min j len)) things)))))))) + (push (subseq text i (min j len)) + things)))))))) (do ((p plist (cddr p))) ((endp p)) (emit (format nil "~(~A~)=~A;" (car p) (cadr p)))) @@ -798,15 +914,8 @@ (defzoneparse :dkim (name data rec) (rec :type :txt :data (nreverse things))))) -(eval-when (:load-toplevel :execute) - (dolist (item '((sshfp-algorithm rsa 1) - (sshfp-algorithm dsa 2) - (sshfp-algorithm ecdsa 3) - (sshfp-type sha-1 1) - (sshfp-type sha-256 2))) - (destructuring-bind (prop sym val) item - (setf (get sym prop) val) - (export sym)))) +(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* @@ -830,17 +939,12 @@ (defzoneparse :sshfp (name data rec) (rec :data (list (parse-integer alg) (parse-integer type) fpr))))))) - (flet ((lookup (what prop) - (etypecase what - (fixnum what) - (symbol (or (get what prop) - (error "~S is not a known ~A" what prop)))))) - (dolist (item (listify data)) - (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1)) - (listify item) - (rec :data (list (lookup alg 'sshfp-algorithm) - (lookup type 'sshfp-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)))))) (defmethod zone-record-rrdata ((type (eql :sshfp)) zr) (destructuring-bind (alg type fpr) (zr-data zr) @@ -891,7 +995,8 @@ (defzoneparse :alias (name data rec :zname zname) :data name))) (defzoneparse :srv (name data rec :zname zname) - ":srv (((SERVICE &key :port) (PROVIDER &key :port :prio :weight :ip)*)*)" + ":srv (((SERVICE &key :port :protocol) + (PROVIDER &key :port :prio :weight :ip)*)*)" (dolist (srv data) (destructuring-bind (servopts &rest providers) srv (destructuring-bind @@ -1193,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* - "~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*)) @@ -1201,61 +1306,73 @@ (defun bind-format-record (zr format &rest 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* - "~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 :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. @@ -1270,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) - (>= byte 128) + (>= byte 127) (member byte '(#\: #\\) :key #'char-code)) (format out "\\~3,'0O" byte) (write-char (code-char byte) out)))))