Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
Hayley Patton
netfarm
Commits
fedabe84
Commit
fedabe84
authored
Mar 21, 2020
by
Hayley Patton
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Finish binary format, hashes use binary format, fix signature reading in text format
parent
d6753367
Changes
9
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
198 additions
and
44 deletions
+198
-44
Code/Binary-format/parser.lisp
Code/Binary-format/parser.lisp
+48
-14
Code/Binary-format/renderer.lisp
Code/Binary-format/renderer.lisp
+101
-2
Code/Crypto/hash.lisp
Code/Crypto/hash.lisp
+13
-18
Code/Objects/objects.lisp
Code/Objects/objects.lisp
+1
-1
Code/Text-format/new-parser.lisp
Code/Text-format/new-parser.lisp
+4
-4
Code/conditions.lisp
Code/conditions.lisp
+11
-0
Code/netfarm.asd
Code/netfarm.asd
+6
-1
Code/package.lisp
Code/package.lisp
+3
-1
Tests/new-parser.lisp
Tests/new-parser.lisp
+11
-3
No files found.
Code/Binary-format/parser.lisp
View file @
fedabe84
...
...
@@ -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
)))
Code/Binary-format/renderer.lisp
View file @
fedabe84
...
...
@@ -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
)))
Code/Crypto/hash.lisp
View file @
fedabe84
(
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."
...
...
Code/Objects/objects.lisp
View file @
fedabe84
...
...
@@ -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
))
...
...
Code/Text-format/new-parser.lisp
View file @
fedabe84
...
...
@@ -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."
...
...
Code/conditions.lisp
0 → 100644
View file @
fedabe84
(
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
)))
Code/netfarm.asd
View file @
fedabe84
...
...
@@ -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"
))))))
Code/package.lisp
View file @
fedabe84
...
...
@@ -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
...
...
Tests/new-parser.lisp
View file @
fedabe84
...
...
@@ -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/8
HDxcfJy83P0dPV19nb3d/h4+Xn6evt7/Hz9ff5+/3/w=
=
Bw8XHycvNz9HT1dfZ293f4ePl5+nr7e/x8/X3+fv9/8= AQIDBAUGBwgJCgsMDQ4PEBESExQVFhcYGRobHB0eHyA
BAgMEBQYHCAkKCwwNDg8QERITFBUWFxgZGhscHR4fIA=
=
---
---
"
: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
))))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment