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

redo format, implement object signing, add loads of tests

parent 752b57a0
Pipeline #801 passed with stage
in 1 minute and 20 seconds
......@@ -2,13 +2,12 @@ image: daewok/lisp-devel
- test
- build
- apt-get update -qy
- apt-get install -y git-core
- git clone ~/quicklisp/local-projects/cl-decentralise
- git clone ~/quicklisp/local-projects/netfarm
- ln -s "${CI_PROJECT_DIR}" ~/quicklisp/local-projects/netfarm
stage: test
cl-decentralise: a decentralisation library
netfarm: a distributed object representation and verifier
Copyright 2018
# NB: The examples/ namespace doesn't exist in Netfarm.
# You will probably use the hashspace namespace when I decide on what it will
# be named.
schema examples/a-schema
name base64:SSdsbCBDb21lIFJ1bm5pbmc=
artist base64:QnJpYW4gRW5v
musician drums base64:UGF1bCBSdWRvbHBo
musician bass base64:UGF1bCBSdWRvbHBo
musician guitar base64:Um9iZXJ0IEZyaXBw
musician piano base64:Um9kIE1lbHZpbg==
musician vocals base64:QnJpYW4gRW5v
\ No newline at end of file
# This is a schema for a song.
# We have the syntax for defining a slot: `slot <slot-name> <type>`
# A `single`-typed slot only holds one value.
slot name single
# A `lists`-typed slot holds each line of atoms in its own list.
slot musician lists
slot link lists
# A `list`-typed slot holds one list of all the atoms.
slot artist lists
(ql:quickload '(:drakma :jsown))
(defvar *bad-countries*
'((("Australia") "Your node may be subject to the `Telecommunications Assistance and Access Bill 2018` bill; Please don't elect dumbasses who say `the laws of mathematics are very commendable, but the only law that applies in Australia is the law of Australia`.")
(("Australia" "Canada" "United States" "United Kingdom" "New Zealand") "Your country is part of the Five Eyes surveillance alliance. These countries can and do share metadata about their citizens to circumvent privacy laws, and your node may be monitored.")
(("United Kingdom") "Your node may be subject to the `Investigatory Powers Act 2016` act; you may be threatened with a prison sentence if you don't hand over keys you don't have.")))
(defvar *english-list*
"~{~#[~;~a~;~a and ~a~:;~@{~a~#[~;, and ~:;, ~]~}~]~}")
(pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)
(defun test-node-for-legalese ()
(let* ((response (jsown:parse (drakma:http-request "")))
(country (jsown:val response "country"))
(issues-p nil))
(format t "I think you are in ~a.~%===~%" country)
(loop for (problematic-countries problem) in *bad-countries*
when (member country problematic-countries :test #'string=)
do (format t "Issue for ~a: ~a~%"
(format nil *english-list* problematic-countries)
(setf issues-p t))
(write-line "===")
(if issues-p
(write-line "You and your node may run into legal and/or surveillance issues.
There are a few things you could do, in order of preference:
- clear up any issues with a lawyer or legal representative,
- set up your node as a Tor hidden service (,
- give it a go; you may be protected as you are only hosting law-violating content and did not create or curate it,
- refrain from running a node (sorry!)")
(write-line "Congratulations! You should be able to run a Netfarm node."))
(not issues-p)))
(write-line "You have loaded the Netfarm location tester; evaluate `(test-node-for-legalese)` to check the legal status of running a Netfarm node where you are currently. Please note:
- this program will connect to an external server ( to fetch your IP and geolocate it, and
- this is not an adequate substitute for legal advice; it may not have enough information about laws in your jurisdiction to make a correct statement.")
......@@ -2,7 +2,8 @@
:depends-on (:netfarm :fiveam)
:components ((:module tests
:components ((:file "package")
(:file "formats")
(:file "fuzzing")
(:file "keys")
(:file "schema")
(:file "new-parser")
(:file "new-renderer")
(:file "run-tests")))))
(defsystem :netfarm
:depends-on (:ironclad :decentralise :s-base64 :split-sequence :alexandria :flexi-streams)
(asdf:defsystem :netfarm
:depends-on (:ironclad :decentralise :s-base64
:split-sequence :alexandria :flexi-streams
:components ((:module src
:components ((:file "package")
(:file "macros")
(:file "keys")
(:file "codecs")
(:file "conditions")
(:file "formats")
(:file "objects")
(:file "new-parser")
(:file "new-renderer")
(:file "keys")
(:file "schema")))))
(in-package :netfarm)
(defclass event-handler ()
((name :initarg :name :reader event-handler-name)
(callback :initarg :callback :reader event-handler-callback))
(:documentation "A basic event handler. Runs only once and matches
events where (event-name event) is string= to (event-handler-name handler)."))
(defclass multiple-event-handler (event-handler)
((lifespan :initarg :lifespan :initform nil :reader event-handler-lifespan))
(:documentation "An event handler which can continue to live matching multiple
events. If (event-handler-lifespan handler) is non-NIL, each matched event
decrements the lifespan until the lifespan is zero; if NIL, live forever."))
(defun add-handler (handler)
"Add a handler to the current handler list."
(declare (ignore handler))
(error "ADD-EVENT can only be called in a WITH-EVENTS-FROM-NETFARM-STREAM block"))
(defgeneric handle-event-with-handler (handler event)
(:documentation "Runs the handler HANDLER's callback with EVENT passed to it."))
(defgeneric event-handler-matches-p (handler event)
(:documentation "Predicate that tests if HANDLER matches EVENT."))
(defmethod event-handler-matches-p ((handler event-handler) event)
(string= (event-handler-name handler)
(event-name event)))
(defmethod handle-event-with-handler ((handler event-handler) event)
(funcall (event-handler-callback handler) event)
(defmethod handle-event-with-handler ((handler multiple-event-handler) event)
(if (event-handler-lifespan handler)
(plusp (decf (event-handler-lifespan handler)))
(defmacro async-get-object-from-stream (object-name stream &key on-object on-error)
(let ((object-gensym (gensym "OBJECT")))
(decentralise:get-block ,object-name)
(make-instance 'event-handler
:name ,object-name
:callback (lambda (,object-gensym)
(typecase ,object-gensym
(netfarm-instance (funcall ,on-object ,object-gensym))
(netfarm-protocol-error (funcall ,on-error ,object-gensym)))))))))
(defmacro with-events-from-netfarm-stream ((block-name stream event-name &key stop-when-no-events)
&body setup-body)
`(block ,block-name
(let ((*handlers* nil))
(flet ((add-handler (handler) (push handler *handlers*)))
for ,event-name = (read-netfarm-event-from-stream stream)
,@(when stop-when-no-events
`(until (null *handlers*)))
;; Pull out the matching handlers and call them.
for matching-handlers = (remove-if-not (lambda (handler)
(event-handler-matches-p handler ,event-name))
for handler in matching-handlers
for result = (handle-event-with-handler handler ,event-name)
;; Handlers return if they should be preserved or not.
when (null result)
do (setf *events* (delete handler *handlers* :test #'eq)))))))
......@@ -32,6 +32,21 @@
(octets-to-string (decode-base64-bytes input)
:external-format *encoding*))))
(define-codec base64-data
(lambda (vector)
(with-output-to-string (output)
(encode-base64-bytes vector output)))
(lambda (base64)
(with-input-from-string (input base64)
(decode-base64-bytes input))))
(define-codec ref
(lambda (reference)
(check-type reference reference)
(format nil (reference-hash reference)))
(lambda (string)
(make-instance 'reference :hash string)))
(defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*)))
(when (null codec-definition)
......@@ -44,3 +59,33 @@
(defun decode-codecs (codec-list data)
(dolist (codec codec-list data)
(setf data (funcall (find-codec codec :decode) data))))
(declaim (inline split-line))
(defun split-line (line)
(split-sequence #\Space line :remove-empty-subseqs t))
(defun parse-atom (atom &key (allow-codecs t))
(case (count #\Colon atom :test #'char=)
(0 atom)
(1 (destructuring-bind (codecs data)
(split-sequence #\Colon atom)
(if allow-codecs
(decode-codecs (split-sequence #\Comma codecs) data)
(error 'netfarm-parser-codecs-in-key :atom atom))))
(otherwise (error "Too many colons in ~a" atom))))
(defun handle-rendering-string (string)
(if (or (find #\Space string)
(find #\Colon string)
(find #\Newline string))
(format nil "base64:~a"
(funcall (find-codec "base64" :encode) string))
(defun render-atom (atom)
(etypecase atom
(integer (format nil "integer:~d" atom))
(string (handle-rendering-string atom))
(vector (format nil "base64-data:~a"
(funcall (find-codec "base64-data" :encode) atom)))))
(in-package :netfarm)
(define-condition netfarm-parser-error (error)
((value :initarg :value
:reader netfarm-parser-error-value))
(define-condition parser-error (error)
((name :initarg :name
:reader parser-error-name))
(:report (lambda (condition stream)
(format stream "The value ~s could not be parsed"
(netfarm-parser-error-value condition)))))
(format stream "~s could not be parsed"
(parser-error-name condition)))))
(define-condition netfarm-schema-error (netfarm-parser-error)
(define-condition parser-bad-segment-count (parser-error)
((count :initarg :count :reader parser-error-segment-count))
(:report (lambda (condition stream)
(format stream "~a segment~:p ~:*~[were~;was~;were~] provided, not 3 or 4"
(parser-error-segment-count condition)))))
(define-condition netfarm-parser-unknown-descriptor (netfarm-schema-error)
(define-condition parser-empty-line (parser-error)
((key :initarg :key :reader parser-error-key))
(:report (lambda (condition stream)
(format stream "~s is not a known schema descriptor"
(netfarm-parser-error-value condition)))))
(format stream "The key ~a was provided with no values"
(render-atom (parser-error-key condition))))))
(define-condition netfarm-parser-unknown-descriptor (netfarm-schema-error)
(define-condition parser-bad-signature (parser-error)
((signature :initarg :signature :reader parser-bad-signature-signature))
(:report (lambda (condition stream)
(format stream "~s is not a known schema descriptor"
(netfarm-parser-error-value condition)))))
(format stream "The signature given is invalid: ~s"
(parser-bad-signature-signature condition)))))
(define-condition netfarm-parser-unexpected-segment (netfarm-schema-error)
(define-condition parser-codecs-in-key (parser-error)
((atom :initarg :atom :reader parser-error-key))
(:report (lambda (condition stream)
(format stream "~s was not an expected segment name"
(netfarm-parser-error-value condition)))))
(format stream "A codec was encountered in a slot name: ~s"
(parser-error-key condition)))))
(define-condition netfarm-decentralise-error (error)
((erroneous-block :initarg :block-name
:reader netfarm-decentralise-error-block-name)))
(define-condition schema-error ()
(define-condition schema-slot-missing (schema-error)
((instance :initarg :instance :reader schema-slot-missing-instance)
(slot-name :initarg :slot-name :reader schema-slot-missing-slot-name))
(:report (lambda (condition stream)
(format stream "The slot ~s is missing in ~s"
(render-atom (schema-slot-missing-slot-name condition))
(schema-slot-missing-instance condition)))))
(define-condition netfarm-decentralise-missing-slash (netfarm-decentralise-error)
(define-condition schema-bad-reader-type (schema-error)
((reader-type :initarg :type :reader schema-bad-reader-type-type))
(:report (lambda (condition stream)
(format stream "~s does not contain a slash in its name" condition))))
(format stream "The name ~s is not a reader type"
(schema-bad-reader-type-type condition)))))
......@@ -9,6 +9,10 @@
(subseq name 0 slash-pos))))
(defun stop-put-p (name data version channels)
(multiple-value-bind (name schema-name)
(declare (ignore data version channels))
(parse-tagged-name name)
(condition (c)
(princ-to-string c))
(:no-error (name type) nil)))
(in-package :netfarm)
;;;; A schema data type.
(defstruct schema
segments signatures pushers)
;;;; Parsing atoms
(declaim (inline split-line))
(defun split-line (line)
(split-sequence #\Space line :remove-empty-subseqs t))
(defun parse-atom (atom)
(case (count #\Colon atom :test #'char=)
(0 atom)
(1 (destructuring-bind (codecs data)
(split-sequence #\Colon atom)
(decode-codecs (split-sequence #\Comma codecs) data)))
(otherwise (error "Too many colons in ~a" atom))))
(defun handle-rendering-string (string)
(if (or (find #\Space string)
(find #\Colon string)
(find #\Newline string))
(format nil "base64:~a"
(funcall (find-codec "base64" :encode) string))
(defun render-atom (atom)
(etypecase atom
(integer (format nil "integer:~d" atom))
(string (handle-rendering-string atom))))
;;;; Data storage creation and manipulation
(defun initialize-format (format-name)
"Initialize the data storage object for format-name."
(ecase format-name
:key-values) (make-hash-table :test 'equal))
: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),
may not be (eg lists)."
(ecase format-name
(:key-value (setf (gethash (first data) store)
(nconc (gethash (first data) store)
(rest data)))
(:key-values (push (rest data)
(gethash (first data) store))
(:triple-store (assert (alexandria:length= 3 data) (data)
"Triple-store requires 3 items, got ~d" (length data))
(cons data store))
(:n-store (cons data store))))
;;;; Utility functions for hash-tables
(defun reverse-table (table)
"Reverse every list in a table."
for key being the hash-keys of table
for value being the hash-values of table
do (setf (gethash key table) (nreverse value)))
(defun maphash* (function 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)))
;;;; Deserialization
(defun parse-segment (segment type)
(let ((store (initialize-format type)))
(dolist (line segment)
(setf store (augment-data-storage store type line)))
(defun split-block (parts)
"Split a Netfarm block into a hash-table of segments."
(when (stringp parts)
(setf parts (split-sequence #\Newline parts)))
with segments = (make-hash-table :test 'equal)
with current-segment = nil
for line in parts
for line-number from 1
for split-line = (mapcar #'parse-atom (split-line line))
for (key . value) = split-line
for segment-name = (first value)
unless (null split-line)
do (if (string= key "SEGMENT")
(setf current-segment segment-name)
(push split-line (gethash current-segment segments)))
finally (return (reverse-table segments))))
(defun parse-block (text schema)
(maphash* (lambda (k v)
(parse-segment v (or (gethash k (schema-segments schema))
(error 'netfarm-parser-unexpected-segment :value k))))
(split-block text)))
;;;; Serialization
(defun render-segment (segment type)
(format nil "~{~a~^~%~}"
(ecase type
for key being the hash-keys of segment
for values being the hash-values of segment
collecting (format nil "~a ~{~a~^ ~a~}"
key (mapcar #'render-atom values))))
for key being the hash-keys of segment
for values being the hash-values of segment
collecting (format nil "~{~a~^ ~}"
(loop for value in values collecting
(format nil "~a ~{~a~^ ~a~}"
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~^ ~}"
for key being the hash-keys of block
for value being the hash-values of block
collect (format nil "SEGMENT ~a~%~a" key
(render-segment value (or (gethash key schema)
(error "Unexpected segment ~a" key)))))))
(defun verify-signature-for (segment-name key key-owner table)
"Verify key-owner's signature for segment-name in table with key."
(never-null-let* ((signatures
(gethash (format nil "sign ~a" segment-name) table))
(gethash segment-name table))
(format nil "~{~a~^ ~}" original-segment))
(assoc key-owner signatures :test #'equal)))
(base64-string-to-usb8-array owners-base64)))
(verify-text key joined-segment owners-signature)))
......@@ -2,28 +2,32 @@
;;; A base type for holding partial and full keys.
(defstruct netfarm-keys
(defstruct (keys (:constructor make-keys))
(defun make-keys ()
(defun generate-keys ()
(multiple-value-bind (s-pri s-pub)
(generate-key-pair :ed25519)
(multiple-value-bind (e-pri e-pub)
(generate-key-pair :curve25519)
(make-netfarm-keys :signature-public s-pub
:signature-private s-pri
:exchange-public e-pub
:exchange-private e-pri))))
(make-keys :signature-public s-pub
:signature-private s-pri
:exchange-public e-pub
:exchange-private e-pri))))
(defun keys-from-public (signature exchange)
(make-keys :signature-public signature
:exchange-public exchange))
;;; Elliptic Curve Diffie-Hellman helpers
(defun shared-key (ours theirs)
(netfarm-keys-exchange-private ours)
(netfarm-keys-exchange-public theirs)))
(keys-exchange-private ours)
(keys-exchange-public theirs)))
(defun symmetric-cipher (key)
(make-cipher :aes
......@@ -42,19 +46,28 @@
;;; Elliptic Curve Digital Signing Algorithm helpers
(defun hash-text (text)
(digest-sequence :sha256
(ascii-string-to-byte-array text)))
(digest-sequence :sha256 (ascii-string-to-byte-array text)))
(defun sign-text (key text)
(sign-message (netfarm-keys-signature-private key)
(sign-message (keys-signature-private key)
(hash-text text)))
(defun verify-text (key signature text)
(verify-signature (netfarm-keys-signature-public key)
(verify-signature (keys-signature-public key)
(hash-text text)
(defun generate-master-hash (signatures)
(digest-sequence :sha256
;; digest-sequence REALLY wants a vector of unsigned bytes.
;; Ironclad must be doing something when it takes so long to
;; compile...
(reduce (lambda (x y) (concatenate 'vector x y))
signatures :initial-value #())
'(vector (unsigned-byte 8)))))
;;; Pronounceable verification codes.
;; Not dissimilar to
;; Not awfully similar, either.
......@@ -83,3 +96,15 @@
(ldb (byte 2 10) v))
(aref *consonants*
(ldb (byte 4 12) v))))))
(defun sign-object (object key)
(sign-text key
(render-object object
:emit-computed-values nil
:emit-signatures nil)))
(defun verify-object (object key signature)
(verify-text key signature
(render-object object
:emit-computed-values nil
:emit-signatures nil)))
(in-package :netfarm)
;;; These are some macros I thought would be handy over time.
;;; So far define-tuple is only used, but they're all very nice
;;; and useful.
(defmacro never-null-let* (lets &body body)
;; This is a strange form of anaphora, similar to ANAPHORA-BASIC:AAND).
;; When one bound form evaluates to NIL, the chain is discarded and
;; evaluation stops. The body is also not evaluated, that'd be weird.
;; For example, (never-null-let* ((a (print :a)) (b nil) (c (print :c))))
;; will print :A but not :C. Variables are also bound in subsequent
;; computations, hence the name "never-null-let*". Enough explanation?
"A let* which never binds NILs, and instead returns NIL."
"This is a strange form of anaphora, similar to ANAPHORA-BASIC:AAND).
When one bound form evaluates to NIL, the chain is discarded and
evaluation stops. The body is also not evaluated, that'd be weird.
For example, (never-null-let* ((a (print :a)) (b nil) (c (print :c))))
will print :A but not :C. Variables are also bound in subsequent
computations, hence the name \"never-null-let*\". Enough explanation?"
(let ((failed (gensym "FAILED")))
`(catch ',failed
(let* ,(loop for (var bind) in lets
......@@ -30,3 +33,59 @@ No lookup tables or constant folding/pointer magic though."
collect `((funcall ,actual-test ,test-value ,actual-value)
(t ,fall-through)))))
(defmacro define-tuple (class-name parents slots &optional documentation)
"This is just to save my hands, since Netfarm class slots are mostly disjoint
and have the same printer basically.
CLASS-NAME is the name of the slot, PARENTS should be called
DIRECT-SUPERCLASSES to be accurate, SLOTS are a modified slot description list,
and DOCUMENTATION is the docstring.
SLOTS takes the form (name . plist), where plist contains:
- :READER, the reader/setter of the slot (defaults to CLASS-SLOT like DEFSTRUCT),
- :READ-ONLY, truthy if the slot should be read-only,
- :INITARG, the keyword argument,
- :INITFORM, the default value.
This generates the DEFCLASS form, and a method on PRINT-OBJECT."
(let ((not-found (gensym "NOT-FOUND"))
(slot-alist nil))
(flet ((getf-or-default (list value &optional default)
(let ((value (getf list value not-found)))
(if (eql value not-found)
(defclass ,class-name ,parents
for (name . arguments) in slots
for reader-name = (or (getf arguments :reader)
(intern (format nil "~a-~a" class-name name)))
do (push (cons name reader-name) slot-alist)
collect `(,name :initarg ,(getf-or-default arguments :initarg
(intern (symbol-name name) 'keyword))
:initform ,(getf-or-default arguments :initform
,(format nil "~a is required" name)))
,(if (getf arguments :read-only)
:reader :accessor)
,@(unless (null documentation)
(list (list :documentation documentation))))
(defmethod print-object ((object ,class-name) stream)
(print-unreadable-object (object stream :type t :identity t)
(pprint-logical-block (stream nil)
,@(loop for ((name . reader) . continuep) on (reverse slot-alist)
collect `(progn
(write-char #\: stream)
(write-string ,(symbol-name name) stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (,reader object) stream)
(write-char #\Space stream)
(pprint-newline :linear stream))))))))))
(defmacro aif (test then &optional else)
`(let ((it ,test))
(if it ,then ,else)))
(in-package :netfarm)
;; Our goal is to parse something like:
section foo
(defun make-class-from-schema (schema-name schema-parts)
(make-instance 'standard-class
:name schema-name
(loop for (name) in schema-parts
collect `(:name ,name
:initargs (,(intern (string name)
(find-package "KEYWORD")))))))
(defun make-instance-of-schema (schema-parts class netfarm-object)
(let ((instance (make-instance class)))
(in-package :netfarm)
(defun decode-base64-string (string)
(with-input-from-string (stream string)
(decode-base64-bytes stream)))
(defun parse-signatures (lines)
(loop for line in lines
collect (destructuring-bind (owner* signature*) (split-sequence #\Space line)
(let ((owner (decode-base64-string owner*))
(signature (decode-base64-string signature*)))
(assert (= (length owner) (length signature) 32))
(cons owner signature)))))
(defun parse-hash-table (lines)
(loop with value-table = (make-hash-table :test 'equal)
for line in lines
for (key* . values*) = (split-sequence #\Space line)
for key = (parse-atom key* :allow-codecs nil)
for values = (mapcar #'parse-atom values*)
unless (string= key "#")
do (push values (gethash key value-table))
finally (return value-table)))
(defun parse-segments (segments &key source)
"Parse the Netfarm block in TEXT. If SOURCE is provided, it is the source of
the generated VAGUE-OBJECT."
(when (not (member (length segments) '(3 4)))
(error 'netfarm-parser-bad-segment-count
:count (length segments)))
(destructuring-bind (signatures metadata values
&optional computed-values)
(make-instance 'vague-object
:source source
:signatures (parse-signatures signatures)
:metadata (parse-hash-table metadata)