Commit 752b57a0 authored by Hayley Patton's avatar Hayley Patton 🔥

schema format complete

parent 63af7af0
Pipeline #627 passed with stage
in 1 minute and 21 seconds
*~
\#*\#
*.fasl
# netfarm: a distributed signed object store
This is Netfarm, a...distributed signed object store. Why did I write that?
It's just in the header. Anyways.
Netfarm is an alternate system which we believe is the "right thing".
Here's why we think it's right:
- it doesn't use nasty proof-of-work or -stake, which burn energy and
imply bandwidth and storage are scarce resources. These centralise systems
further, since the least people will hold the most tokens or hardware.
- it's actually distributed. Federation isn't much better than centralization;
if your server goes down, you need to have another account to keep using the
fediverse. Distribution has much greater fault tolerance.
- data is cryptographically signed. This allows for a proof that someone did
write something without needing a central authority to identify them for the
most part.
- data is represented as objects, instead of just values. This allows programs
to perform type-checking, and data can be strictly validated. Additionally,
"schemas", similar but not as powerful as classes, can be used to provide
semantic meaning for machines to parse.
It's not too hard to install, let's give that a go.
1. **Install Quicklisp.** Netfarm requires a decent amount of libraries, and
chasing them yourself isn't very fun or doable without a system manager
(asdf) and system source (Quicklisp). You can download
[the setup file](https://beta.quicklisp.org/quicklisp.lisp) and follow
[the instructions for installation](https://www.quicklisp.org/beta/). It's
very simple to install (just type some commands in a REPL)
and requires no configuration.
2. **Download cl-decentralise.** Netfarm doesn't handle synchronisation itself,
it uses a sibling library called `cl-decentralise`. You need to download this
as well, perhaps [from here](https://gitlab.com/netfarm.gq/cl-decentralise).
A nice trick is to clone it somewhere in `~/quicklisp/local-projects` so
Quicklisp will find it, or you can symlink it in.
3. **Download Netfarm.** Similarly, you need to put Netfarm somewhere Quicklisp
looks. You shouldn't need the URL since either you're looking at the README
there, or you've already downloaded it, but it's obtainable
[here](https://gitlab.com/netfarm.gq/netfarm).
4. **Boot up Netfarm.** Evaluate `(ql:quickload :netfarm)` in a REPL. If it
didn't work, check you've done all the previous steps. If you have, it'd be
great if you [created an issue](https://gitlab.com/netfarm.gq/netfarm/issues)
detailing what went wrong.
Cool, what can you do now?
......@@ -4,4 +4,5 @@
:components ((:file "package")
(:file "formats")
(:file "keys")
(:file "schema")
(:file "run-tests")))))
(defsystem :netfarm
:depends-on (:ironclad :decentralise :cl-base64 :split-sequence :alexandria :flexi-streams)
:depends-on (:ironclad :decentralise :s-base64 :split-sequence :alexandria :flexi-streams)
:components ((:module src
:components ((:file "package")
(:file "macros")
(:file "keys")
(:file "codecs")
(:file "formats")))))
(:file "conditions")
(:file "formats")
(:file "schema")))))
(in-package :netfarm)
(defvar *codecs* (make-hash-table :test 'equal))
(defvar *encoding* :utf-8)
(defstruct codec
encoder decoder)
(defmacro define-codec (name encode decode)
(when (symbolp name)
(setf name (string-downcase name)))
`(setf (gethash ',name *codecs*)
(make-codec :encoder ,encode
:decoder ,decode)))
(define-codec "integer"
(define-codec integer
(lambda (number)
(format nil "~d" number))
(lambda (string)
......@@ -19,11 +22,15 @@
(condition ()
(error "not parseable")))))
(define-codec "base64"
(define-codec base64
(lambda (string)
(string-to-base64-string string))
(with-output-to-string (output)
(encode-base64-bytes (string-to-octets string :external-format *encoding*)
output)))
(lambda (base64)
(base64-string-to-string base64)))
(with-input-from-string (input base64)
(octets-to-string (decode-base64-bytes input)
:external-format *encoding*))))
(defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*)))
......
(in-package :netfarm)
(define-condition netfarm-parser-error (error)
((value :initarg :value
:reader netfarm-parser-error-value))
(:report (lambda (condition stream)
(format stream "The value ~s could not be parsed"
(netfarm-parser-error-value condition)))))
(define-condition netfarm-schema-error (netfarm-parser-error)
())
(define-condition netfarm-parser-unknown-descriptor (netfarm-schema-error)
()
(:report (lambda (condition stream)
(format stream "~s is not a known schema descriptor"
(netfarm-parser-error-value condition)))))
(define-condition netfarm-parser-unknown-descriptor (netfarm-schema-error)
()
(:report (lambda (condition stream)
(format stream "~s is not a known schema descriptor"
(netfarm-parser-error-value condition)))))
(define-condition netfarm-parser-unexpected-segment (netfarm-schema-error)
()
(:report (lambda (condition stream)
(format stream "~s was not an expected segment name"
(netfarm-parser-error-value condition)))))
(define-condition netfarm-decentralise-error (error)
((erroneous-block :initarg :block-name
:reader netfarm-decentralise-error-block-name)))
(define-condition netfarm-decentralise-missing-slash (netfarm-decentralise-error)
()
(:report (lambda (condition stream)
(format stream "~s does not contain a slash in its name" condition))))
(in-package :netfarm)
(defun parse-tagged-name (name)
(let ((slash-pos (position #\/ name :from-end t)))
(when (null slash-pos)
(error 'netfarm-decentralise-missing-slash
:block-name name))
(values (subseq name (1+ slash-pos))
(subseq name 0 slash-pos))))
(defun stop-put-p (name data version channels)
(multiple-value-bind (name schema-name)
(parse-tagged-name name)
(in-package :netfarm)
;;;; A schema data type.
(defstruct schema
segments signatures pushers)
;;;; Parsing atoms
(declaim (inline split-line))
......@@ -16,9 +21,10 @@
(defun handle-rendering-string (string)
(if (or (find #\Space string)
(find #\Colon string))
(find #\Colon string)
(find #\Newline string))
(format nil "base64:~a"
(string-to-base64-string string))
(funcall (find-codec "base64" :encode) string))
string))
(defun render-atom (atom)
......@@ -33,7 +39,8 @@
(ecase format-name
((:key-value
:key-values) (make-hash-table :test 'equal))
(:triple-store nil)))
((:triple-store
:n-store) nil)))
(defun augment-data-storage (store format-name data)
"Adds data to the store defined by codec-name. May be destructive (eg hash-tables),
......@@ -48,7 +55,8 @@ may not be (eg lists)."
store)
(:triple-store (assert (alexandria:length= 3 data) (data)
"Triple-store requires 3 items, got ~d" (length data))
(cons data store))))
(cons data store))
(:n-store (cons data store))))
;;;; Utility functions for hash-tables
......@@ -61,7 +69,8 @@ may not be (eg lists)."
table)
(defun maphash* (function hash-table)
(let ((new-table (make-hash-table :test (hash-table-test hash-table))))
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
:size (hash-table-size hash-table))))
(maphash (lambda (k v)
(setf (gethash k new-table)
(funcall function k v)))
......@@ -78,6 +87,8 @@ may not be (eg lists)."
(defun split-block (parts)
"Split a Netfarm block into a hash-table of segments."
(when (stringp parts)
(setf parts (split-sequence #\Newline parts)))
(loop
with segments = (make-hash-table :test 'equal)
with current-segment = nil
......@@ -94,8 +105,8 @@ may not be (eg lists)."
(defun parse-block (text schema)
(maphash* (lambda (k v)
(parse-segment v (or (gethash k schema)
(error "Unexpected segment ~a" k))))
(parse-segment v (or (gethash k (schema-segments schema))
(error 'netfarm-parser-unexpected-segment :value k))))
(split-block text)))
;;;; Serialization
......@@ -116,7 +127,11 @@ may not be (eg lists)."
collecting (format nil "~{~a~^ ~}"
(loop for value in values collecting
(format nil "~a ~{~a~^ ~a~}"
key (mapcar #'render-atom values)))))))))
key (mapcar #'render-atom values))))))
((:n-store :triple-store)
(loop for atoms in segment
collecting (format nil "~{~a~^ ~}"
(mapcar #'render-atom atoms)))))))
(defun render-block (block schema)
(format nil "~{~a~^ ~}"
......
......@@ -14,3 +14,19 @@
collect `(,var (or ,bind
(throw ',failed nil))))
,@body))))
(defmacro case* (value (&key (test #'eql)
fall-through)
&body cases)
;; This macro just cleans up some lookup tables.
"CASE, but you get to choose the equality predicate.
No lookup tables or constant folding/pointer magic though."
(let ((actual-value (gensym "VALUE"))
(actual-test (gensym "TEST")))
`(let ((,actual-value ,value)
(,actual-test ,test))
(cond
,@(loop for (test-value . body) in cases
collect `((funcall ,actual-test ,test-value ,actual-value)
,@body))
(t ,fall-through)))))
......@@ -2,20 +2,33 @@
(:use :cl
:ironclad
:decentralise
:cl-base64
:s-base64
:flexi-streams
:split-sequence)
(:export :split-block
:parse-block
:render-block
:pack-segments
:make-keys
:shared-key
:symmetric-cipher
:symmetric-encrypt
:symmetric-decrypt
:netfarm-keys
:hash-text
:sign-text
:verify-text
:readable-verifier))
(:export
;; formats
:split-block
:parse-block
:render-block
:parse-atom
:render-atom
:pack-segments
;; schema
:schema
:define-schema
:schema-segments
:schema-signatures
:schema-pushers
:parse-schema
:*schema-segments*
;; keys
:make-keys
:shared-key
:symmetric-cipher
:symmetric-encrypt
:symmetric-decrypt
:netfarm-keys
:hash-text
:sign-text
:verify-text
:readable-verifier))
(in-package :netfarm)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun always-string (string)
(etypecase string
(string string)
(symbol (string-downcase string))))
(defun always-symbol (symbol &optional (package *package*))
(when (symbolp package)
(setf package (or (find-package package)
(error "package not found"))))
(etypecase symbol
(symbol (if (eq (symbol-package symbol) package)
symbol
(intern (symbol-name symbol) package)))
(string (intern (string-upcase symbol) package)))))
(defmacro define-schema (name &key segments signatures pushers)
(alexandria:with-gensyms (temp-table)
`(let ((,temp-table (make-hash-table :test 'equal
:size ,(length segments))))
,@(loop for segment in segments
collect (destructuring-bind (segment-name segment-type) segment
`(setf (gethash ,(always-string segment-name) ,temp-table)
,(always-symbol segment-type 'keyword))))
(defvar ,name (make-schema :segments ,temp-table
:signatures
',(loop for pair in signatures
do (assert (alexandria:length= 2 pair))
collect (mapcar #'always-string pair))
:pushers
',(loop for group in pushers
do (assert (alexandria:length= 5 group))
collect (mapcar #'always-string group)))))))
(define-schema *schema-schema*
:segments ((schema-description n-store)
(description-signatures key-value))
:signatures ((schema-description description-signatures)))
(defun type-string-to-symbol (type)
"Looks and smells like a very careful INTERN. It might be."
(case* type (:test #'string=
:fall-through (error 'netfarm-parser-unknown-segment-type
:value type))
("key-value" :key-value)
("key-values" :key-values)
("n-store" :n-store)
("triple-store" :triple-store)))
(defun parse-schema (schema)
(let ((raw-schema (parse-block schema *schema-schema*))
(type-table (make-hash-table :test 'equal))
(signatures nil)
(pushers nil))
(loop for line in (gethash "schema-description" raw-schema)
do (case* (first line)
(:test #'equal
:fall-through (error 'netfarm-parser-unknown-descriptor
:value (first line)))
("segment" (destructuring-bind (name type)
(rest line)
(setf (gethash name type-table) (type-string-to-symbol type))))
("signing" (destructuring-bind (signed signer)
(rest line)
(push (cons signed signer) signatures)))
("pushers" (let ((length (length (rest line))))
(assert (= length 5) (length)
"Pusher requires 5 values, not ~d" length)
(push (rest line) pushers)))))
(make-schema :segments type-table
:signatures signatures
:pushers pushers)))
......@@ -5,12 +5,11 @@
"a b"
"c integer:2"
"d base64:VGhlIGFzc3VtcHRpb24gdGhhdCB3aGF0IGN1cnJlbnRseSBleGlzdHMgbXVzdCBuZWNlc3NhcmlseSBleGlzdCBpcyB0aGUgYWNpZCB0aGF0IGNvcnJvZGVzIGFsbCB2aXNpb25hcnkgdGhpbmtpbmcu"))
(defvar *inspiring-bookchin-quote* "The assumption that what currently exists must necessarily exist is the acid that corrodes all visionary thinking.")
;; Create a simple schema which has one segment: "foo".
(defvar *foo-schema* (make-hash-table :test 'equal))
(setf (gethash "foo" *foo-schema*) :key-value)
(defvar *inspiring-bookchin-quote* "The assumption that what currently exists must necessarily exist is the acid that corrodes all visionary thinking.")
(define-schema *foo-schema*
:segments ((foo :key-value)))
(def-suite format-tests
:description "Parser tests for Netfarm.")
......
(defun test-fuzz-functions (a->b a &key b->a (test #'equal))
(let ((b (funcall a->b a)))
(unless (and (not (null b->a))
(funcall test (funcall b->a b) a))
(error "could not backtrack to A"))
b))
(defvar *chars* "abcdefghijklmnopqrstuvwxyz🆑🅾🆘 :.
")
(defun random-character-generator (&key
(length 32)
(chars *chars*))
(let ((chars-length (length chars)))
(lambda ()
(loop
with str = (make-string length)
for pos below length
do (setf (char str pos)
(char chars (random chars-length)))
finally (return str)))))
(defun fuzz (fn tests input-generator &key reverse-fn (test #'equal))
(let ((errors 0)
(error-cases nil))
(dotimes (test-n tests)
(let ((input (funcall input-generator)))
(handler-case
(test-fuzz-functions fn input :b->a reverse-fn :test test)
(condition (c)
(incf errors)
(push input error-cases)
(format t "BANG! The input ~s raises the condition ~a on test #~d.~%"
input c test-n)))))
(values (zerop errors)
errors
error-cases)))
......@@ -35,5 +35,5 @@ Is necessary for her learning")
(let* ((verifier (readable-verifier *song-about-stuff*))
(bad-string (substitute #\o #\e *song-about-stuff*))
(verifier* (readable-verifier bad-string)))
(is (not (string= verifier verifier*))
(is (string/= verifier verifier*)
"The mutated string and the original string created the same verifier")))
(in-package :netfarm-tests)
(defun run-tests ()
(run! '(format-tests key-tests)))
(run! '(format-tests key-tests schema-tests)))
(defun gitlab-ci-test ()
(let ((fiveam:*on-error* :debug)
(fiveam:*on-failure* :debug)
(*debugger-hook* (lambda (c h)
(declare (ignore c h))
(uiop:quit -1))))
(run-tests)))
(or
(run-tests)
(uiop:quit -1)))
(in-package :netfarm-tests)
(def-suite schema-tests
:description "Schema tests for Netfarm.")
(in-suite schema-tests)
(define-schema *drawing-schema-defined*
:segments ((metadata key-value)
(nodes triple-store)))
(defvar *nice-drawing*
'("SEGMENT metadata"
"name base64:U3ViY2xhc3NlcyBvZiBOVU1CRVI="
"SEGMENT nodes"
"number -> complex"
"number -> real"
"real -> rational"
"real -> float"
"rational -> integer"
"rational -> ratio"
"integer -> fixnum"
"integer -> bignum")
"A graph of most of the subtypes of Common Lisp's NUMBER type.")
(defvar *drawing-schema-text*
'("SEGMENT schema-description"
"segment metadata key-value"
"segment nodes triple-store"
"signing metadata metadata-signature"
"signing nodes nodes-signature"))
(test test-schema
(let* ((drawing-schema (parse-schema *drawing-schema-text*))
(drawing-segments (schema-segments drawing-schema))
(parsed-drawing (parse-block *nice-drawing* drawing-schema)))
(is (eql (gethash "nodes" drawing-segments) :triple-store)
"DEFINE-SCHEMA-SEGMENTS produced a type for the segment NODES that wasn't TRIPLE-STORE")
(is (alexandria:length= (schema-signatures drawing-schema) 2)
"PARSE-SCHEMA did not identify the two SIGNING lines in *DRAWING-SCHEMA-TEXT*")))
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