Commit fedabe84 authored by  Hayley Patton's avatar Hayley Patton 🐢

Finish binary format, hashes use binary format, fix signature reading in text format

parent d6753367
......@@ -9,29 +9,28 @@
(ash accumulator 8))))
accumulator))
(defun read-byte-vector (function count)
(let ((vector (make-array count :element-type '(unsigned-byte 8))))
(dotimes (n count)
(setf (aref vector n) (funcall function)))
vector))
(defgeneric binary-parse-from-type-tag (type-tag function)
(:method ((tag (eql 1)) function)
(let* ((byte-length (read-integer function))
(bytes (make-array byte-length :element-type '(unsigned-byte 8))))
(dotimes (n byte-length)
(setf (aref bytes n)
(funcall function)))
(babel:octets-to-string bytes :encoding :utf-8)))
(babel:octets-to-string (read-byte-vector function
(read-integer function))
:encoding :utf-8))
(:method ((tag (eql 2)) function)
(let* ((vector-length (read-integer function))
(vector (make-array vector-length :element-type '(unsigned-byte 8))))
(dotimes (n byte-length)
(setf (aref vector n)
(funcall function)))
vector))
(read-byte-vector function (read-integer function)))
(:method ((tag (eql 3)) function)
(read-integer function))
(:method ((tag (eql 4)) function)
(let ((integer (read-integer function)))
(if (zerop integer)
(error "Don't use the negative-integer tag for zeroes")
(squirty-bottle "Don't use the negative-integer tag for zeroes")
(- integer))))
(:method ((tag (eql 5)) function)
(assert (plusp *reader-depth*) () "too much list recursion")
(let ((length (read-integer function)))
(loop repeat length
collect (binary-parse-from-function function))))
......@@ -39,7 +38,9 @@
(let ((hash (make-array 32 :element-type '(unsigned-byte 8))))
(dotimes (n 32)
(setf (aref hash n) (funcall function)))
(make-instance 'reference :hash hash))))
(make-instance 'reference :hash hash)))
(:method ((tag (eql 7)) function) :true)
(:method ((tag (eql 8)) function) :false))
(defun binary-parse-from-function (function)
(binary-parse-from-type-tag (funcall function) function))
......@@ -53,3 +54,36 @@
(prog1 (aref vector position)
(incf position)))))
(binary-parse-from-function function-or-vector)))
(defun read-signatures (function)
(loop repeat (read-integer function)
collect (cons (make-instance 'reference
:hash (read-byte-vector function 32))
(read-byte-vector function 64))))
(defun read-hash-table (function)
(let ((size (read-integer function)))
(assert (< size 5000))
(let ((table (make-hash-table :test 'equal :size size)))
(dotimes (n size)
(setf (gethash (binary-parse-from-function function) table)
(binary-parse-from-function function)))
table)))
(defun binary-parse-object-from-function (function &key source name)
(make-instance 'vague-object
:name name :source source
:signatures (read-signatures function)
:metadata (read-hash-table function)
:values (read-hash-table function)
:computed-values (read-hash-table function)))
(defun binary-parse-object (function-or-vector)
(if (vectorp function-or-vector)
(let ((position 0)
(vector function-or-vector))
(binary-parse-object-from-function
(lambda ()
(prog1 (aref vector position)
(incf position)))))
(binary-parse-object-from-function function-or-vector)))
......@@ -38,11 +38,110 @@
(binary-render-to-function element function)))
(:method ((r reference) function)
(write-type-tag 6 function)
(funcall function (reference-hash function))))
(funcall function (reference-hash function)))
(:method ((o object) function)
(write-type-tag 6 function)
(funcall function (hash-object function)))
(:method ((x (eql ':true)) function)
(write-type-tag 7 function))
(:method ((x (eql ':false)) function)
(write-type-tag 8 function)))
(defmacro do-bound-sorted-slots ((netfarm-name value object slot-function)
(length &body pre-body)
&body body)
(alexandria:with-gensyms (slot-alist bound-alist sorted-alist
slot pair class)
(alexandria:once-only (object)
`(let* ((,class (class-of ,object))
(,slot-alist (string-hash-table->alist (,slot-function ,class)))
(,bound-alist (loop for ,pair in ,slot-alist
for (nil . ,slot) = ,pair
when (closer-mop:slot-boundp-using-class ,class
,object
,slot)
collect ,pair))
(,length (length ,bound-alist))
(,sorted-alist (sort ,bound-alist #'string< :key #'car)))
,@pre-body
(dolist (,slot ,sorted-alist)
(destructuring-bind (,netfarm-name . ,slot) ,slot
(let ((,value (closer-mop:slot-value-using-class ,class ,object ,slot)))
,@body)))))))
(defun write-object-values (object function)
(do-bound-sorted-slots (name value object
netfarm-class-slot-table)
(l (write-integer l function))
(binary-render-to-function name function)
(binary-render-to-function value function)))
(defun write-object-computed-values (object function)
(do-bound-sorted-slots (name computed-values object
netfarm-class-slot-table)
(l (write-integer l function))
(binary-render-to-function name function)
(let ((equivalent-list
(loop for computed-value in computed-values
collect (list (computed-value-cause computed-value)
(computed-value-value computed-value)))))
(binary-render-to-function equivalent-list function))))
(defun write-hash-table (hash-table function)
(let ((keys (sort (alexandria:hash-table-keys hash-table) #'string<)))
(write-integer (length keys) function)
(dolist (key keys)
(binary-render-to-function key function)
(binary-render-to-function (gethash key hash-table) function))))
(defgeneric binary-render-object-to-function (object function
emit-computed-values?
emit-signatures?)
(:method ((object object) function emit-computed-values? emit-signatures?)
(when emit-signatures?
(write-integer (length (object-signatures object)) function)
(dolist (signature-pair (object-signatures object))
(destructuring-bind (user . signature)
signature-pair
(funcall function (netfarm:hash-object user))
(funcall function signature)))
(setf (gethash "schema" (object-metadata object))
(netfarm-class-name (class-of object))))
(write-hash-table (object-metadata object) function)
(write-object-values object function)
(when emit-computed-values?
(write-object-computed-values object function)))
(:method ((vague-object vague-object) function emit-computed-values? emit-signatures?)
(when emit-signatures?
(write-integer (length (vague-object-signatures vague-object))
function)
(dolist (signature-pair (vague-object-signatures vague-object))
(destructuring-bind (user . signature)
signature-pair
(funcall function (netfarm:hash-object user))
(funcall function signature))))
(write-hash-table (vague-object-metadata vague-object) function)
(write-hash-table (vague-object-values vague-object) function)
(when emit-computed-values?
(write-hash-table (vague-object-computed-values vague-object) function))))
(defun binary-render (object &optional function)
(if (null function)
(flexi-streams:with-output-to-sequence (s)
(binary-render-to-function object (lambda (bytes)
(write-sequence bytes s))))
(binary-render-to-function object function)))
(defun binary-render-object (object &key function
(emit-computed-values t)
(emit-signatures t))
(if (null function)
(flexi-streams:with-output-to-sequence (s)
(binary-render-object-to-function object (lambda (bytes)
(write-sequence bytes s))
emit-computed-values
emit-signatures))
(binary-render-object-to-function object function
emit-computed-values
emit-signatures)))
(in-package :netfarm)
(declaim (inline hash-text))
(declaim (inline hash-text hash-bytes))
(defun hash-text (text)
(declare (string text))
(digest-sequence :sha256 (babel:string-to-octets text :encoding :utf-8)))
(defun hash-bytes (bytes)
(digest-sequence :sha256 (subseq bytes 0 (length bytes))))
(defun base-hash-object (object)
(hash-text (render-object object :emit-signatures nil :emit-computed-values nil)))
(hash-bytes (binary-render-object object :emit-signatures t
:emit-computed-values nil)))
(defun hash-object (object)
"Generate a hash for an object that includes the hash of the object itself and its signatures.
For signatures S_1 to S_n and object hash H, the hashed sequence is S_1 | S_2 | ... | S_n | H"
(digest-sequence :sha256
;; digest-sequence REALLY wants a vector of unsigned bytes.
;; Ironclad must be doing something when it takes so long to
;; compile...
(coerce
(reduce (lambda (x y) (concatenate 'vector x y))
(if (typep object 'vague-object)
(vague-object-signatures object)
(object-signatures object))
:key #'cdr
:initial-value (base-hash-object object))
'(vector (unsigned-byte 8)))))
(defgeneric hash-object (object)
(:documentation "Generate a hash for an object, including its signatures but not computed values.")
(:method ((object object))
(base-hash-object object))
(:method ((vague-object vague-object))
(base-hash-object vague-object))
(:method ((reference reference))
(reference-hash reference)))
(defun hash-object* (object)
"Generate a hash for an object using HASH-OBJECT, but then base64-encode it. This seems common enough to deserve a function."
......
......@@ -14,7 +14,7 @@
(macrolet ((mht () '(make-hash-table :test 'equal)))
(define-tuple vague-object ()
((source)
((source :initform nil)
(signatures :initform nil)
(metadata :initform (mht))
(values :initform (mht))
......
......@@ -7,11 +7,11 @@
(defun parse-signatures (lines)
(loop for line in lines
collect (destructuring-bind (owner* signature*) (split-sequence #\Space line)
(let ((owner (make-instance 'reference :hash owner*))
(let ((owner (decode-base64-string owner*))
(signature (decode-base64-string signature*)))
(assert (= (length (decode-base64-string owner*))
(length signature) 32))
(cons owner signature)))))
(assert (= (length owner) 32))
(assert (= (length signature) 64))
(cons (make-instance 'reference :hash owner) signature)))))
(defun parse-all (stream)
"Parse every value in a stream into a list."
......
(in-package :netfarm)
(define-condition squirty-bottle (error)
((reason :initarg :reason :reader squirty-bottle-reason))
(:report (lambda (c s)
(format s "~&Bad user! You did something very, very bad:~%~2t~a"
(squirty-bottle-reason c)))))
(defun squirty-bottle (reason-control &rest reason-arguments)
(error 'squirty-bottle
:reason (apply #'format nil reason-control reason-arguments)))
......@@ -5,6 +5,7 @@
:license "Cooperative Software License v1+"
:version "0.1.0"
:components ((:file "package")
(:file "conditions" :depends-on ("package"))
(:file "macros")
(:module "Codecs"
:depends-on ("package" "macros")
......@@ -43,7 +44,11 @@
:depends-on ("Codecs" "Objects")
:components ((:file "new-parser")
(:file "new-renderer")))
(:module "Binary-format"
:depends-on ("Objects")
:components ((:file "parser")
(:file "renderer")))
(:module "Crypto"
:depends-on ("Text-format")
:depends-on ("Binary-format")
:components ((:file "hash")
(:file "keys" :depends-on ("hash"))))))
......@@ -2,9 +2,11 @@
(:use :cl :ironclad :s-base64 :flexi-streams :split-sequence)
(:export
;; formats
#:binary-parse #:binary-render-object
#:parse-block #:render-object
#:apply-class
#:parse #:render
#:binary-parse #:binary-render
#:apply-class
#:*reader-depth*
#:base64->bytes #:bytes->base64
;; objects
......
......@@ -53,14 +53,14 @@
(define-test read-signature
:parent parser-tests
(with-parsed ("AQIDBAUGBwgJCgsMDQ4PEBESExQVFhcYGRobHB0eHyA= Bw8XHycvNz9HT1dfZ293f4ePl5+nr7e/x8/X3+fv9/8=
Bw8XHycvNz9HT1dfZ293f4ePl5+nr7e/x8/X3+fv9/8= AQIDBAUGBwgJCgsMDQ4PEBESExQVFhcYGRobHB0eHyA=
(with-parsed ("AQIDBAUGBwgJCgsMDQ4PEBESExQVFhcYGRobHB0eHyA= Bw8XHycvNz9HT1dfZ293f4ePl5+nr7e/x8/X3+fv9/8HDxcfJy83P0dPV19nb3d/h4+Xn6evt7/Hz9ff5+/3/w==
Bw8XHycvNz9HT1dfZ293f4ePl5+nr7e/x8/X3+fv9/8= AQIDBAUGBwgJCgsMDQ4PEBESExQVFhcYGRobHB0eHyABAgMEBQYHCAkKCwwNDg8QERITFBUWFxgZGhscHR4fIA==
---
---
"
:vague vague-object)
(let* ((signature-pairs (vague-object-signatures vague-object))
(users (mapcar (alexandria:compose #'base64->bytes #'reference-hash #'car) signature-pairs))
(users (mapcar (alexandria:compose #'reference-hash #'car) signature-pairs))
(signatures (mapcar #'cdr signature-pairs)))
(is equalp '(#( 1 2 3 4 5 6 7 8
9 10 11 12 13 14 15 16
......@@ -74,10 +74,18 @@ Bw8XHycvNz9HT1dfZ293f4ePl5+nr7e/x8/X3+fv9/8= AQIDBAUGBwgJCgsMDQ4PEBESExQVFhcYGRo
(is equalp '(#( 7 15 23 31 39 47 55 63
71 79 87 95 103 111 119 127
135 143 151 159 167 175 183 191
199 207 215 223 231 239 247 255
7 15 23 31 39 47 55 63
71 79 87 95 103 111 119 127
135 143 151 159 167 175 183 191
199 207 215 223 231 239 247 255)
#( 1 2 3 4 5 6 7 8
9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24
25 26 27 28 29 30 31 32
1 2 3 4 5 6 7 8
9 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24
25 26 27 28 29 30 31 32))
signatures))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment