Common Lisp Blockchain - Scheme Coin
Burton Samograd
busfactor1 at icloud.com
Sun Dec 17 05:57:12 UTC 2017
Here’s a little ditty I decided to share. A Common Lisp Blockchain implementation of a coin that has a useful Proof of Work: Scheme Evaluation.
Incomplete, but still interesting per the previous week’s discussion.
;;
;; scheme coin - a common lisp blockchain
;;
;; Burton Samograd
;; 2017
(load "~/quicklisp/setup.lisp")
(defconstant *coin-name* "Scheme Coin")
(eval-when (compile load)
(ql:quickload "ironclad"))
(defun rest2 (l)
(cddr l))
(defun interp (x &optional env)
"Interpret (evaluate) the expression x in the environment env."
(cond
((symbolp x) (get-var x env))
((atom x) x)
((scheme-macro (first x))
(interp (scheme-macro-expand x) env))
((case (first x)
(QUOTE (second x))
(BEGIN (last1 (mapcar #'(lambda (y) (interp y env))
(rest x))))
(SET! (set-var! (second x) (interp (third x) env) env))
(if (if (interp (second x) env)
(interp (third x) env)
(interp (fourth x) env)))
(LAMBDA (let ((parms (second x))
(code (maybe-add 'begin (rest2 x))))
#'(lambda (&rest args)
(interp code (extend-env parms args env)))))
(t ;; a procedure application
(apply (interp (first x) env)
(mapcar #'(lambda (v) (interp v env))
(rest x))))))))
(defun scheme-macro (symbol)
(and (symbolp symbol) (get symbol 'scheme-macro)))
(defmacro def-scheme-macro (name parmlist &body body)
`(setf (get ',name 'scheme-macro)
#'(lambda ,parmlist .,body)))
(defun scheme-macro-expand (x)
(if (and (listp x) (scheme-macro (first x)))
(scheme-macro-expand
(apply (scheme-macro (first x)) (rest x)))
x))
(defun set-var! (var val env)
"Set a variable to a value, in the given or global environment."
(if (assoc var env)
(setf (second (assoc var env)) val)
(set-global-var! var val))
val)
(defun get-var (var env)
(if (assoc var env)
(second (assoc var env))
(get-global-var var)))
(defun set-global-var! (var val)
(setf (get var 'global-val) val))
(defun get-global-var (var)
(let* ((default "unbound")
(val (get var 'global-val default)))
(if (eq val default)
(error "Unbound scheme variable: ~A" var)
val)))
(defun extend-env (vars vals env)
"Add some variables and values to and environment."
(nconc (mapcar #'list vars vals) env))
(defparameter *scheme-procs*
'(+ - * / = < > <= >= cons car cdr not append list read member
(null? null) (eq? eq) (equal? equal) (eqv? eql)
(write prin1) (display princ) (newline terpri)))
(defun init-scheme-interp ()
(mapc #'init-scheme-proc *scheme-procs*)
(set-global-var! t t)
(set-global-var! nil nil))
(defun init-scheme-proc (f)
(if (listp f)
(set-global-var! (first f) (symbol-function (second f)))
(set-global-var! f (symbol-function f))))
(defun maybe-add (op exps &optional if-nil)
(cond ((null exps) if-nil)
((length=1 exps) (first exps))
(t (cons op exps))))
(defun length=1 (x)
(and (consp x) (null (cdr x))))
(defun last1 (list)
(first (last list)))
(defun scheme ()
(init-scheme-interp)
(loop (format t "~&==> ")
(print (interp (read) nil))))
(def-scheme-macro let (bindings &rest body)
`((lambda ,(mapcar #'first bindings) . ,body)
.,(mapcar #'second bindings)))
(def-scheme-macro let* (bindings &rest body)
(if (null bindings)
`(begin . ,body)
`(let (,(first bindings))
(let* ,(rest bindings) . ,body))))
(def-scheme-macro and (&rest args)
(cond ((null args) 'T)
((length=1 args) (first args))
(t `(if ,(first args)
(and . ,(rest args))))))
(def-scheme-macro or (&rest args)
(cond ((null args) 'nil)
((length=1 args) (first args))
(t (let ((var (gensym)))
`(let ((,var ,(first args)))
(if ,var ,var (or . ,(rest args))))))))
(init-scheme-interp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; and there we have a scheme interpreter with macros. ;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct block
(index 0) (timestamp 0) data (previous-hash "") hash)
(defstruct transaction
from to (value 0) (accuracy 1)
(duration 0)
data hash previous-hash)
(defun to-byte-array (x)
(let ((retval (make-array 0 :adjustable t
:fill-pointer t
:element-type '(unsigned-byte 8))))
(map 'nil (lambda (c) (vector-push-extend (char-code c) retval))
(format nil "~A" x)) ;
(coerce retval 'ironclad::simple-octet-vector)))
(defun make-address (x)
(let ((digester (ironclad:make-digest :sha3)))
(ironclad:update-digest digester
(to-byte-array x))
(ironclad:produce-digest digester)))
(defun hash-block (block)
(let ((digester (ironclad:make-digest :sha3)))
(ironclad:update-digest digester
(to-byte-array (block-index block)))
(ironclad:update-digest digester
(to-byte-array (block-timestamp block)))
(ironclad:update-digest digester
(to-byte-array (block-data block)))
(ironclad:update-digest digester
(to-byte-array (block-previous-hash block)))
(ironclad:produce-digest digester)))
(defun hash-transaction (block)
(let ((digester (ironclad:make-digest :sha3)))
(ironclad:update-digest digester
(to-byte-array (transaction-from block)))
(ironclad:update-digest digester
(to-byte-array (transaction-to block)))
(ironclad:update-digest digester
(to-byte-array (transaction-value block)))
(ironclad:update-digest digester
(to-byte-array (transaction-accuracy block)))
(ironclad:update-digest digester
(to-byte-array (transaction-duration block)))
(ironclad:update-digest digester
(to-byte-array (transaction-data block)))
(ironclad:produce-digest digester)))
(defun make-genesis-block (data time)
(let* ((block (make-block
:index 0
:timestamp time
:data data
:hash 0))
(hash (hash-block block)))
(setf (block-hash block) hash)
block))
(defmacro create-genesis-block (data)
`(let ((time (get-universal-time)))
(make-genesis-block ,data time)))
(defun next-block (last-block data)
(let ((block (make-block :index (1+ (block-index last-block))
:timestamp (get-universal-time)
:data data
:previous-hash (hash-block last-block))))
(setf (block-hash block) (hash-block block))
(push block *blockchain*)
block))
(setf *print-base* 16)
(defconstant *base-code* '(set! x 0))
(defparameter *network-address* (make-address *coin-name*))
(defparameter *quester-address* (make-address "quester"))
(defparameter *miner-address* (make-address "miner"))
(defparameter *contract-address* (make-address "contract"))
(defparameter *block-transactions*
(let ((transaction (make-transaction :from *network-address*
:to *quester-address*
:value (* 10000 10000 10000)
:data *base-code*)))
(setf (transaction-hash transaction)
(hash-transaction transaction))
(list transaction)))
(defparameter *blockchain*
(list (create-genesis-block *block-transactions*)))
(defparameter *previous-block* (car *blockchain*))
(defparameter *solved-transactions* (make-hash-table :test #'equalp
:weak-kind t))
(eval-when (compile load)
(defun new-transaction (&key from to (value 0) accuracy data
previous-hash duration)
(let ((transaction (make-transaction :from from :to to :value value
:accuracy accuracy :data data
:previous-hash previous-hash
:duration duration)))
(setf (transaction-hash transaction)
(hash-transaction transaction))
(when previous-hash
(setf (gethash
(transaction-hash transaction)
*solved-transactions*)
t))
transaction)))
(defmacro submit-answer (from transaction data)
`(push (new-transaction :from ,from :to *contract-address*
:previous-hash (transaction-hash transaction)
:data ,data)
*block-transactions*))
(defun has-transaction-not-been-solved (transaction)
(if (gethash (transaction-hash transaction)
*solved-transactions*)
(not (setf (gethash (transaction-hash transaction)
*solved-transactions*)
transaction))
t))
(defun viable-transaction (transaction)
(and (has-transaction-not-been-solved transaction)
(<= (block-index (car *blockchain*))
(or (transaction-duration transaction)
(get-universal-time))))) ;; can still submit
(defun verify-transaction (transaction)
(handler-case
(interp (transaction-data transaction))
(error (e) e)))
(defun execute-transactions (miner-address)
(dolist (transaction *block-transactions*)
(when (viable-transaction transaction)
(print :submitting-answer)
(submit-answer miner-address transaction
(verify-transaction transaction))
)))
(defun mine ()
(when *block-transactions*
(execute-transactions *miner-address*)
(transfer *network-address* *miner-address* 1)
(setf *previous-block*
(next-block *previous-block* *block-transactions*))
(setf *block-transactions* nil)))
(defmacro transfer (from to value)
`(push (new-transaction :from ,from :to ,to
:value ,value)
*block-transactions*))
(defmacro execute (from value code &key (accuracy value)
(duration (+ 2 (block-index (car *blockchain*)))))
`(push (new-transaction :from ,from :to *contract-address*
:value ,value
:accuracy ,accuracy :data ',code
:duration ,duration)
*block-transactions*))
(defun process-transfer-request (request stream)
(destructuring-bind (from to value)
request
(transfer from to value)))
(defun process-execute-request (request stream)
(destructuring-bind (from value data &key (accuracy value)
(duration (+ 2 (block-index (car *blockchain*)))))
request
(execute from value data :accuracy accuracy :duration duration)))
(defun process-blocks-request (request stream)
(print *blockchain* stream))
(defun process-coin-server-request (stream)
(let ((request (read stream)))
(case request
(transfer (process-transfer-request (cdr request) stream))
(execute (process-execute-request (cdr request) stream))
(blocks (process-blocks-request (cdr request) stream)))))
(defun coin-server (handle)
(let ((stream (make-instance 'comm:socket-stream
:socket handle
:direction :io
:element-type
'base-char)))
(process-coin-server-request stream)))
(defvar *server* (comm:start-up-server :function #'coin-server
:service 9999
:process-name
(format nil "~A server" *coin-name*)))
(loop
(mine)
(sleep 1))
Enjoy! If you have any questions, feel free to ask.
Made with LispWorks, but it really only uses the function comm:start-up-server I think.
—
Burton Samograd
BusFactor1 Inc.
http://busfactor1.ca/ <http://busfactor1.ca/>
Check out my software in the macOS App Store.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/pro/attachments/20171216/c6d56de4/attachment-0001.html>
More information about the pro
mailing list