Lispchain - a blockchain implementation (sketch) in Common Lisp

lispchain.lisp

;;
;; scheme coin - a lispchain (aka blockchain) implementation
;;
;; Burton Samograd
;; burton.samograd@gmail.com
;; Copyright - 2017
;;
;; Interested in helping out with the code? Email me.
;;
;; Bitcoin: 1HzWXjoQjzdLBm1eKeuWFrZx96kiop5GGy
;;

(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 lisp
  (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-lisp (lisp)
  (let ((digester (ironclad:make-digest :sha3)))
    (ironclad:update-digest digester
                            (to-byte-array (lisp-index lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (lisp-timestamp lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (lisp-data lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (lisp-previous-hash lisp)))
    (ironclad:produce-digest digester)))

(defun hash-transaction (lisp)
  (let ((digester (ironclad:make-digest :sha3)))
    (ironclad:update-digest digester
                            (to-byte-array (transaction-from lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (transaction-to lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (transaction-value lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (transaction-accuracy lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (transaction-duration lisp)))
    (ironclad:update-digest digester
                            (to-byte-array (transaction-data lisp)))
    (ironclad:produce-digest digester)))

(defun make-genesis-lisp (data time)
  (let* ((lisp (make-lisp 
                 :index 0
                 :timestamp time
                 :data data
                 :hash 0))
         (hash (hash-lisp lisp)))
    (setf (lisp-hash lisp) hash)
    lisp))

(defmacro create-genesis-lisp (data)
  `(let ((time (get-universal-time)))
     (make-genesis-lisp ,data time)))

(defun next-lisp (last-lisp data)
  (let ((lisp (make-lisp :index (1+ (lisp-index last-lisp))
                           :timestamp (get-universal-time)
                           :data data
                           :previous-hash (hash-lisp last-lisp))))
    (setf (lisp-hash lisp) (hash-lisp lisp))
    (push  lisp *lispchain*)
    lisp))
                            
(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 *lisp-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 *lispchain* 
  (list (create-genesis-lisp *lisp-transactions*)))

(defparameter *previous-lisp* (car *lispchain*))

(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)
         *lisp-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)
       (<= (lisp-index (car *lispchain*))
           (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 *lisp-transactions*)
    (when (viable-transaction transaction)
      (print :submitting-answer)
      (submit-answer miner-address transaction     
                     (verify-transaction transaction))
      )))

(defmacro transfer (from to value)
  `(push (new-transaction :from ,from :to ,to
                          :value ,value)
         *lisp-transactions*))

(defmacro execute (from value code &key (accuracy value) 
                        (duration (+ 2 (lisp-index (car *lispchain*)))))
  `(push (new-transaction :from ,from :to *contract-address*
                          :value ,value
                          :accuracy ,accuracy :data ',code 
                          :duration ,duration)
         *lisp-transactions*))

(defun mine ()
  (when *lisp-transactions*
    (execute-transactions *miner-address*)
    (transfer *network-address* *miner-address* 1)
    (setf *previous-lisp* 
          (next-lisp *previous-lisp* *lisp-transactions*))
    (setf *lisp-transactions* nil)))
  
(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 (lisp-index (car *lispchain*))))) 
        request
      (execute from value data :accuracy accuracy :duration duration)))

(defun process-lisps-request (request stream)
  (print *lispchain* 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))
      (lisps (process-lisps-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))