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 ...@@ -2,13 +2,12 @@ image: daewok/lisp-devel
stages: stages:
- test - test
- build
before_script: before_script:
- apt-get update -qy - apt-get update -qy
- apt-get install -y git-core - apt-get install -y git-core
- git clone ~/quicklisp/local-projects/cl-decentralise - git clone ~/quicklisp/local-projects/cl-decentralise
- git clone ~/quicklisp/local-projects/netfarm - ln -s "${CI_PROJECT_DIR}" ~/quicklisp/local-projects/netfarm
test: test:
stage: test stage: test
cl-decentralise: a decentralisation library netfarm: a distributed object representation and verifier
Copyright 2018 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 @@ ...@@ -2,7 +2,8 @@
:depends-on (:netfarm :fiveam) :depends-on (:netfarm :fiveam)
:components ((:module tests :components ((:module tests
:components ((:file "package") :components ((:file "package")
(:file "formats") (:file "fuzzing")
(:file "keys") (:file "keys")
(:file "schema") (:file "new-parser")
(:file "new-renderer")
(:file "run-tests"))))) (:file "run-tests")))))
(defsystem :netfarm (asdf:defsystem :netfarm
:depends-on (:ironclad :decentralise :s-base64 :split-sequence :alexandria :flexi-streams) :depends-on (:ironclad :decentralise :s-base64
:split-sequence :alexandria :flexi-streams
:components ((:module src :components ((:module src
:components ((:file "package") :components ((:file "package")
(:file "macros") (:file "macros")
(:file "keys")
(:file "codecs") (:file "codecs")
(:file "conditions") (:file "conditions")
(:file "formats") (:file "objects")
(:file "new-parser")
(:file "new-renderer")
(:file "keys")
(:file "schema"))))) (: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 @@ ...@@ -32,6 +32,21 @@
(octets-to-string (decode-base64-bytes input) (octets-to-string (decode-base64-bytes input)
:external-format *encoding*)))) :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) (defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*))) (let ((codec-definition (gethash name *codecs*)))
(when (null codec-definition) (when (null codec-definition)
...@@ -44,3 +59,33 @@ ...@@ -44,3 +59,33 @@
(defun decode-codecs (codec-list data) (defun decode-codecs (codec-list data)
(dolist (codec codec-list data) (dolist (codec codec-list data)
(setf data (funcall (find-codec codec :decode) 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) (in-package :netfarm)
(define-condition netfarm-parser-error (error) (define-condition parser-error (error)
((value :initarg :value ((name :initarg :name
:reader netfarm-parser-error-value)) :reader parser-error-name))
(:report (lambda (condition stream) (:report (lambda (condition stream)
(format stream "The value ~s could not be parsed" (format stream "~s could not be parsed"
(netfarm-parser-error-value condition))))) (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) (:report (lambda (condition stream)
(format stream "~s is not a known schema descriptor" (format stream "The key ~a was provided with no values"
(netfarm-parser-error-value condition))))) (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) (:report (lambda (condition stream)
(format stream "~s is not a known schema descriptor" (format stream "The signature given is invalid: ~s"
(netfarm-parser-error-value condition))))) (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) (:report (lambda (condition stream)
(format stream "~s was not an expected segment name" (format stream "A codec was encountered in a slot name: ~s"
(netfarm-parser-error-value condition))))) (parser-error-key condition)))))
(define-condition netfarm-decentralise-error (error) (define-condition schema-error ()
((erroneous-block :initarg :block-name ())
:reader netfarm-decentralise-error-block-name)))
(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) (: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 @@ ...@@ -9,6 +9,10 @@
(subseq name 0 slash-pos)))) (subseq name 0 slash-pos))))
(defun stop-put-p (name data version channels) (defun stop-put-p (name data version channels)
(multiple-value-bind (name schema-name) (declare (ignore data version channels))
(parse-tagged-name name) (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 @@ ...@@ -2,28 +2,32 @@
;;; A base type for holding partial and full keys. ;;; A base type for holding partial and full keys.
(defstruct netfarm-keys (defstruct (keys (:constructor make-keys))
signature-public signature-public
signature-private signature-private
exchange-public exchange-public
exchange-private) exchange-private)
(defun make-keys () (defun generate-keys ()
(multiple-value-bind (s-pri s-pub) (multiple-value-bind (s-pri s-pub)
(generate-key-pair :ed25519) (generate-key-pair :ed25519)
(multiple-value-bind (e-pri e-pub) (multiple-value-bind (e-pri e-pub)
(generate-key-pair :curve25519) (generate-key-pair :curve25519)
(make-netfarm-keys :signature-public s-pub (make-keys :signature-public s-pub
:signature-private s-pri :signature-private s-pri
:exchange-public e-pub :exchange-public e-pub
:exchange-private e-pri)))) :exchange-private e-pri))))
(defun keys-from-public (signature exchange)
(make-keys :signature-public signature
:exchange-public exchange))
;;; Elliptic Curve Diffie-Hellman helpers ;;; Elliptic Curve Diffie-Hellman helpers
(defun shared-key (ours theirs) (defun shared-key (ours theirs)
(diffie-hellman (diffie-hellman
(netfarm-keys-exchange-private ours) (keys-exchange-private ours)
(netfarm-keys-exchange-public theirs))) (keys-exchange-public theirs)))
(defun symmetric-cipher (key) (defun symmetric-cipher (key)
(make-cipher :aes (make-cipher :aes
...@@ -42,19 +46,28 @@ ...@@ -42,19 +46,28 @@
;;; Elliptic Curve Digital Signing Algorithm helpers ;;; Elliptic Curve Digital Signing Algorithm helpers
(defun hash-text (text) (defun hash-text (text)
(digest-sequence :sha256 (digest-sequence :sha256 (ascii-string-to-byte-array text)))
(ascii-string-to-byte-array text)))
(defun sign-text (key text) (defun sign-text (key text)
(sign-message (netfarm-keys-signature-private key) (sign-message (keys-signature-private key)
(hash-text text))) (hash-text text)))
(defun verify-text (key signature text) (defun verify-text (key signature text)
(verify-signature (netfarm-keys-signature-public key) (verify-signature (keys-signature-public key)
(hash-text text) (hash-text text)
signature)) signature))
(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. ;;; Pronounceable verification codes.
;; Not dissimilar to ;; Not dissimilar to
;; Not awfully similar, either. ;; Not awfully similar, either.
...@@ -83,3 +96,15 @@ ...@@ -83,3 +96,15 @@
(ldb (byte 2 10) v)) (ldb (byte 2 10) v))
(aref *consonants* (aref *consonants*
(ldb (byte 4 12) v)))))) (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) (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) (defmacro never-null-let* (lets &body body)
;; This is a strange form of anaphora, similar to ANAPHORA-BASIC:AAND). "This is a strange form of anaphora, similar to ANAPHORA-BASIC:AAND).
;; When one bound form evaluates to NIL, the chain is discarded and When one bound form evaluates to NIL, the chain is discarded and
;; evaluation stops. The body is also not evaluated, that'd be weird. 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)))) 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 will print :A but not :C. Variables are also bound in subsequent
;; computations, hence the name "never-null-let*". Enough explanation? computations, hence the name \"never-null-let*\". Enough explanation?"
"A let* which never binds NILs, and instead returns NIL."
(let ((failed (gensym "FAILED"))) (let ((failed (gensym "FAILED")))
`(catch ',failed `(catch ',failed
(let* ,(loop for (var bind) in lets (let* ,(loop for (var bind) in lets
...@@ -30,3 +33,59 @@ No lookup tables or constant folding/pointer magic though." ...@@ -30,3 +33,59 @@ No lookup tables or constant folding/pointer magic though."
collect `((funcall ,actual-test ,test-value ,actual-value) collect `((funcall ,actual-test ,test-value ,actual-value)
,@body)) ,@body))
(t ,fall-through))))) (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)))