Commit 91ab9838 authored by  Hayley Patton's avatar Hayley Patton 🐢
parents f96c70dd fef764d7
(in-package :netfarm)
(defun make-output-vector (parts position)
(let ((output-vector (make-array position
:element-type '(unsigned-byte 8)))
(start 0))
(declare (optimize (speed 3) (safety 0))
(fixnum start))
(loop for part of-type (simple-array (unsigned-byte 8) (*))
in (reverse parts)
do (loop for output-position of-type fixnum from start
for input-position of-type fixnum below (length part)
for byte = (aref part input-position)
do (setf (aref output-vector output-position) byte))
(incf start (length part)))
(defmacro with-output-to-vector ((function-name) &body body)
(alexandria:with-gensyms (parts position)
`(let ((,parts '())
(,position 0))
(declare (fixnum ,position))
(flet ((,function-name (vector)
(declare ((simple-array (unsigned-byte 8) (*)) vector))
(push vector ,parts)
(incf ,position (length vector))))
(make-output-vector ,parts ,position)))))
(in-package :netfarm)
(declaim (inline write-type-tag write-integer)
(optimize (speed 3)))
(defun write-type-tag (tag function)
(let ((v (make-array 1 :element-type '(unsigned-byte 8))))
(setf (aref v 0) tag)
(funcall function v)
(defun write-integer (integer function)
(let ((byte-count (ceiling (integer-length integer) 8)))
(assert (< byte-count 256))
(flet ((get-byte (n)
(ldb (byte 8 (* n 8)) integer)))
(funcall function (vector byte-count))
(loop with buffer = (make-array byte-count
:element-type '(unsigned-byte 8))
for byte-position from (1- byte-count) downto 0
for buffer-position from 0
do (setf (aref buffer buffer-position)
(get-byte byte-position))
finally (funcall function buffer)))))
(defun write-type-tag (tag function)
(funcall function (vector tag)))
(write-type-tag byte-count function)
(loop with buffer = (make-array byte-count
:element-type '(unsigned-byte 8))
for byte-position from (1- byte-count) downto 0
for step = integer then (ash step -8)
do (setf (aref buffer byte-position)
(logand step #xFF))
finally (funcall function buffer))))
(defgeneric binary-render-to-function (object function)
(:method ((s string) function)
......@@ -128,18 +131,16 @@
(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))))
(with-output-to-vector (f)
(binary-render-to-function object #'f))
(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))
(with-output-to-vector (f)
(binary-render-object-to-function object #'f
(binary-render-object-to-function object function
......@@ -40,14 +40,20 @@
:external-format *encoding*)))
(define-codec base64-data
#'bytes->base64 #'base64->bytes)
(lambda (string)
(let* ((bytes* (base64->bytes string))
(length (length bytes*)))
(coerce (subseq bytes* 0 length) '(vector (unsigned-byte 8))))))
(define-codec ref
(lambda (reference)
(check-type reference reference)
(bytes->base64 (reference-hash reference)))
(lambda (string)
(make-instance 'reference :hash (base64->bytes string))))
(make-instance 'reference
:hash (coerce (subseq (base64->bytes string) 0 32)
'(vector (unsigned-byte 8))))))
(defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*)))
......@@ -9,8 +9,12 @@
'(vector (unsigned-byte 8)))))
(defun base-hash-object (object &key (emit-signatures t))
(hash-bytes (binary-render-object object :emit-signatures emit-signatures
:emit-computed-values nil)))
(let ((digest (make-digest :sha256)))
(binary-render-object object :emit-signatures emit-signatures
:emit-computed-values nil
:function (lambda (vector)
(update-digest digest vector)))
(produce-digest digest)))
(defgeneric hash-object (object)
(:documentation "Generate a hash for an object, including its signatures but not computed values.")
......@@ -29,4 +29,4 @@
(loop for instruction in code
append (assemble-instruction instruction))
'(vector (unsigned-byte 8))))
......@@ -49,8 +49,9 @@
(:file "new-renderer")))
(:module "Binary-format"
:depends-on ("Objects")
:components ((:file "parser")
(:file "renderer")))
:components ((:file "fasterer-output")
(:file "parser")
(:file "renderer" :depends-on ("fasterer-output"))))
(:module "Crypto"
:depends-on ("Binary-format")
:serial t
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