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

use babel for byte array <-> string conversion, include CCL in CI, more stuff I forgot about

parent 57f59f99
Pipeline #998 passed with stage
in 3 minutes and 37 seconds
......@@ -13,3 +13,4 @@ test:
stage: test
- sbcl --load tests.lisp --disable-debugger --quit
- ccl -l tests.lisp -e '(quit)'
......@@ -80,18 +80,18 @@
(split-sequence #\Space line :remove-empty-subseqs t))
(defun parse-atom (atom &key (allow-codecs t))
(case (count #\Colon atom :test #'char=)
(case (count #\: atom :test #'char=)
(0 atom)
(1 (destructuring-bind (codecs data)
(split-sequence #\Colon atom)
(split-sequence #\: atom)
(if allow-codecs
(decode-codecs (split-sequence #\Comma codecs) data)
(decode-codecs (split-sequence #\, codecs) data)
(error 'parser-codecs-in-key :atom atom))))
(otherwise (error "Too many colons in ~a" atom))))
(defun render-string (string)
(if (or (find #\Space string)
(find #\Colon string)
(find #\: string)
(find #\Newline string))
(with-output-to-string (acc)
(write-char #\" acc)
......@@ -24,9 +24,9 @@
(defun object->keys (object)
(make-keys :signature-public (make-public-key :ed25519
:y (object-value object 'sign-key))
:y (user-sign-key object))
:exchange-public (make-public-key :curve25519
:y (object-value object 'ecdh-key))))
:y (user-ecdh-key object))))
(defun keys->object (keys)
(make-instance 'user
......@@ -49,16 +49,17 @@
(digest-sequence :ripemd-128 key)))
(defun symmetric-encrypt (key text)
(encrypt-message key (string-to-octets text)))
(encrypt-message key (babel:string-to-octets text :encoding :utf-8)))
(defun symmetric-decrypt (key text)
(encrypt-message key text)))
(encrypt-message key text)
:encoding :utf-8))
;;; Elliptic Curve Digital Signing Algorithm helpers
(defun hash-text (text)
(digest-sequence :sha256 (ascii-string-to-byte-array text)))
(digest-sequence :sha256 (babel:string-to-octets text :encoding :utf-8)))
(defun sign-text (key text)
(sign-message (keys-signature-private key)
......@@ -93,7 +94,7 @@
(defun readable-verifier (key)
(when (stringp key)
(setf key (string-to-octets key)))
(setf key (babel:string-to-octets key :encoding :utf-8)))
(format nil "~{~a ~(~a ~a ~a~)~^,~%~}"
with digest = (digest-sequence :sha256 key)
......@@ -10,7 +10,9 @@
(:schema-names "inbuilt/schema"))
(defclass user ()
(sign-key ecdh-key map)
((sign-key :initarg :sign-key :reader user-sign-key)
(ecdh-key :initarg :ecdh-key :reader user-ecdh-key)
(map :initarg :map :initform nil :reader user-map))
(:metaclass netfarm-class)
(:schema-names "inbuilt/user"))
......@@ -3,9 +3,9 @@
;;; The new, MOP-backed, Netfarm object implementation.
(defclass netfarm-class (standard-class)
((schema-names :initform '() :initarg :schema-names :reader netfarm-class-schema-names)
(scripts :initform '() :initarg :scripts :reader netfarm-class-scripts)
((scripts :initform '() :initarg :scripts :reader netfarm-class-scripts)
(allowed-scripts :initform '() :initarg :allowed-scripts :reader netfarm-class-allowed-scripts)
(schema-names :initform '() :initarg :schema-names :reader netfarm-class-schema-names)
(slot-table :reader netfarm-class-slot-table)))
(defmethod netfarm-class-slot-table :before ((class netfarm-class))
......@@ -14,7 +14,7 @@
(defmethod netfarm-class-name ((class netfarm-class))
(if (null (netfarm-class-schema-names class))
(slot-missing (class-of class) class 'netfarm-name 'slot-value)
(byte-array-to-hex-string (hash-object (class->schema class)))
(first (netfarm-class-schema-names class))))
(defclass netfarm-slot (closer-mop:standard-direct-slot-definition)
......@@ -67,6 +67,7 @@
(labels ((recur (class)
;; Find every netfarm-slot in the class and its superclasses.
(unless (gethash class checked-classes)
(setf (gethash class checked-classes) t)
(dolist (slot (closer-mop:class-direct-slots class))
(when (typep slot 'netfarm-slot)
(let ((name (slot-netfarm-name slot)))
......@@ -74,7 +75,6 @@
(error "duplicate slot name: ~s" name)
(setf (gethash name slot-table)
(closer-mop:slot-definition-name slot))))))
(setf (gethash class checked-classes) t)
(mapc #'recur (closer-mop:class-direct-superclasses class)))))
(recur class))
(setf (slot-value class 'slot-table) slot-table)))
......@@ -46,8 +46,7 @@ keys in the vague-object's values table."
(defun class->schema (class)
(let ((schema (make-instance 'schema
:scripts (netfarm-class-scripts class)
:allowed-scripts (netfarm-class-allowed-scripts class)
:name (netfarm-class-name class))))
:allowed-scripts (netfarm-class-allowed-scripts class))))
(setf (schema-slots schema)
(loop for name being the hash-keys of (netfarm-class-slot-table class)
collect name))
(in-package :netfarm-scripts)
(declaim ((simple-array function (*)) *operators*))
(defvar *operators* (make-array 256
(#-sbcl defvar
#+sbcl sb-ext:defglobal *operators* (make-array 256
:initial-element (lambda (interpreter opcode)
(error "illegal opcode ~d on ~s" opcode interpreter))
:element-type 'function))
(defpackage :netfarm-scripts
(:use :cl :netfarm)
(:export #:assemble #:define-script #:script #:opcode-information
#:run-interpreter #:setup-interpreter
......@@ -47,7 +47,8 @@
#:symmetric-encrypt #:symmetric-decrypt
#:hash-text #:sign-text #:sign-object
#:hash-text #:sign-text
#:hash-object #:sign-object
#:verify-text #:verify-object
#:object->keys #:keys->object
......@@ -12,12 +12,20 @@ Here's why we think it's right:
- 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.
- it isn't a pain to program for. This implementation uses Common Lisp's
meta-object protocol to perform introspection on classes and instances, so
that there is as little of an impedance mismatch between Netfarm-land and
Lisp-land code.
- it's portable. This library defines a portable text format for describing
objects and schemas, but doesn't handle any networking or connectivity; so
Netfarm can be partially used over other protocols like HTTP or IPFS.
- 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.
- objects can have scripts executed on them to provide mutability. Netfarm, like
most distributed hash tables, is effectively immutable, but using a
deterministic script interpreter and a separate computed value system allows us
to perform a decent amount of things that require mutation.
- 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
......@@ -40,10 +48,13 @@ It's not too hard to install, let's give that a go.
great if you [created an issue](
detailing what went wrong.
## Examples
Cool, what can you do now?
- Write out a random Lisp object to its Netfarm form then parse it back into Lisp.
We can take lists, strings, integers and booleans (encoded as `:true` or `:false`).
We can take lists, strings, integers, byte vectors and booleans (encoded as
`:true` or `:false`).
CL-USER> (netfarm:render 42)
......@@ -52,51 +63,58 @@ CL-USER> (netfarm:parse *)
- Create a schema and render it:
- Create a class and render an instance of it:
As mentioned previously, this implementation of Netfarm hooks into the
meta-object protocol by providing a metaclass `netfarm:netfarm-class`. A hash
of the class will be used to identify the schema, but other names can be provided
using the class initarg `:schema-names`.
CL-USER> (netfarm:define-schema *example-schema* "example/schema"
(a b c))
CL-USER> (netfarm:render-object (netfarm:schema->object *example-schema*))
CL-USER> (defclass foo-class ()
((a :initarg :a)
(b :initarg :b)
(c :initarg :c))
(:metaclass netfarm:netfarm-class)
(:schema-names "foo-class"))
CL-USER> (netfarm:render-object (make-instance 'foo-class :a "This is A" :b '("This" "is" 2) :c #(1 2 3 4 5)))
schema inbuilt/schema
schema foo-class
slots (a b c)
traits ()
a \"This is A\"
b (This is integer:2)
c base64-data:AQIDBAU=
- Create an instance of that schema:
- Parse it back in:
CL-USER> (netfarm:make-object *example-schema* :a 1 :b :true :c '("Hello" "world!"))
CL-USER> (netfarm:parse-block *)
CL-USER> (netfarm:apply-class * (find-class 'foo-class))
#<FOO-CLASS {100DF985E3}>
CL-USER> (describe *)
#<FOO-CLASS {100DF985E3}>
CL-USER> (netfarm:render-object *)
schema example/schema
a integer:1
b boolean:true
c (Hello world!)
Slots with :INSTANCE allocation:
A = "This is A"
B = ("This" "is" 2)
C = #(1 2 3 4 5)
## Todo
......@@ -105,11 +123,8 @@ In no particular order:
- Connect the code to a database (initially SQL, then we should create our own
as there is likely to be plenty of duplication in Netfarm) and
cl-decentralise2 to allow Netfarm data to be distributed
- Write a "script"/"trait" interpreter to handle a reproducable form of
side-effects (such as forward references and updating objects)
- A CLIM-based object viewer, possibly using the forementioned interpreter to
- A CLIM-based object viewer, possibly using the script interpreter to
generate presentations
- Flesh out the environment model, which handles providing subjective
- Flesh out the environment/map model, which handles providing subjective
human-friendly names to objects and a weighted voting system which makes use
of locality of human trust and opinion (also todo: explain this idea better!)
- Add (multiple) inheritance to schemas.
of locality of human trust and opinion
(asdf:defsystem :netfarm-server
:depends-on (:netfarm :decentralise2)
:components ((:module "Code"
:components ((:file "package")))))
(defpackage :netfarm-tests
(:use :cl :fiveam :netfarm)
(:export :run-tests :gitlab-ci-test))
(:export #:run-tests #:gitlab-ci-test))
(defsystem :netfarm-tests
:depends-on (:netfarm :fiveam :the-cost-of-nothing)
:depends-on (:netfarm :fiveam :the-cost-of-nothing :uiop)
:components ((:module "Tests"
:components ((:file "package")
(:file "fuzzing")
(asdf:defsystem :netfarm
:depends-on (:ironclad :s-base64 :closer-mop
:depends-on (:ironclad :s-base64 :closer-mop :babel
:split-sequence :alexandria :flexi-streams)
:components ((:module "Code"
:components ((:file "package")
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