|
|
|
|
|
|
|
|
| (defpackage :marlborg.worm.test.worm
|
| (:use :cl :marlborg.worm.primitives)
|
| (:export :run-worm-tests))
|
|
|
| (in-package :marlborg.worm.test.worm)
|
|
|
| (defun run-worm-tests ()
|
| (format t "~%=== WORM Chain Tests ===~%")
|
| (test-genesis)
|
| (test-append-and-verify)
|
| (test-tamper-detection)
|
| (test-chain-growth)
|
| (format t "All WORM tests passed.~%"))
|
|
|
| (defun test-genesis ()
|
| (let ((chain (make-chain)))
|
| (assert (= 1 (length (worm-chain-blocks chain))) ()
|
| "Genesis chain must have exactly 1 block")
|
| (assert (= 0 (worm-block-index (car (worm-chain-blocks chain)))) ()
|
| "Genesis block index must be 0")
|
| (format t " genesis: PASS~%")))
|
|
|
| (defun test-append-and-verify ()
|
| (multiple-value-bind (sk pk) (ed25519-keypair)
|
| (let* ((chain (make-chain))
|
| (payload (sha3-256 (make-array 4 :element-type '(unsigned-byte 8)
|
| :initial-contents '(1 2 3 4))))
|
| (chain2 (append-block chain
|
| (ecies-encrypt pk payload)
|
| sk)))
|
| (assert (= 2 (length (worm-chain-blocks chain2))) ()
|
| "Chain must grow by 1")
|
| (assert (= 1 (worm-block-index (car (worm-chain-blocks chain2)))) ()
|
| "New block index must be 1")
|
| (assert (verify-chain chain2 pk) ()
|
| "Chain must verify after append")
|
| (format t " append + verify: PASS~%"))))
|
|
|
| (defun test-tamper-detection ()
|
| (multiple-value-bind (sk pk) (ed25519-keypair)
|
| (let* ((chain (make-chain))
|
| (payload (sha3-256 (make-array 2 :element-type '(unsigned-byte 8)
|
| :initial-contents '(99 100))))
|
| (chain2 (append-block chain (ecies-encrypt pk payload) sk))
|
| (tampered-blocks (copy-list (worm-chain-blocks chain2)))
|
| (tampered-block (copy-structure (car tampered-blocks))))
|
| (setf (worm-block-payload-hash tampered-block)
|
| (make-array 64 :element-type '(unsigned-byte 8) :initial-element 255))
|
| (setf (car tampered-blocks) tampered-block)
|
| (let ((tampered-chain (%make-chain :blocks tampered-blocks
|
| :genesis-hash (worm-chain-genesis-hash chain2))))
|
| (assert (not (verify-chain tampered-chain pk)) ()
|
| "Tampered chain must not verify")
|
| (format t " tamper detection: PASS~%")))))
|
|
|
| (defun test-chain-growth ()
|
| (multiple-value-bind (sk pk) (ed25519-keypair)
|
| (let ((chain (make-chain)))
|
| (dotimes (i 10)
|
| (let ((payload (sha3-256 (encode-uint64 i))))
|
| (setf chain (append-block chain (ecies-encrypt pk payload) sk))))
|
| (assert (= 11 (length (worm-chain-blocks chain))) ()
|
| "Chain must have genesis + 10 blocks")
|
| (assert (verify-chain chain pk) ()
|
| "10-block chain must verify")
|
| (format t " chain growth (10 blocks): PASS~%"))))
|
|
|
