test/test_attacks.lisp

;;;
;;; Copyright (c) 2026 BEL ESPRIT D ACCORD TRUST HOLDINGS INC
;;; All rights reserved.

(defpackage :marlborg.worm.test.attacks
  (:use :cl :marlborg.worm.primitives)
  (:export :run-attack-suite))

(in-package :marlborg.worm.test.attacks)

;;; ============================================================
;;; ADVERSARIAL TEST SUITE
;;; Red-team attacks against the Marlborg-WORM system
;;; ============================================================

(defun run-attack-suite ()
  (format t "~%=== ADVERSARIAL ATTACK SUITE ===~%")
  (format t "~%--- Chain Integrity Attacks ---~%")
  (attack-replay-block)
  (attack-reorder-blocks)
  (attack-forge-signature)
  (attack-modify-payload-preserve-hash)
  (attack-swap-genesis)
  (format t "~%--- Rewrite System Attacks ---~%")
  (attack-inject-malicious-rule)
  (attack-divergent-rewrite)
  (attack-infinite-expansion)
  (attack-rule-priority-hijack)
  (format t "~%--- Entropy / Convergence Attacks ---~%")
  (attack-entropy-overflow)
  (attack-contraction-violation)
  (attack-nonce-reuse)
  (format t "~%--- Crypto Primitive Attacks ---~%")
  (attack-length-extension)
  (attack-key-reuse-across-chains)
  (attack-ecies-malleability)
  (format t "~%~%=== ATTACK SUITE COMPLETE ===~%"))

;;; ============================================================
;;; CHAIN INTEGRITY ATTACKS
;;; ============================================================

(defun attack-replay-block ()
  "ATTACK: Copy a valid block from one chain position to another.
   EXPECTED: Chain verification fails (index mismatch + prev_hash wrong)"
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (let* ((chain (make-chain))
           (p1 (sha3-256 (make-array 4 :element-type '(unsigned-byte 8)
                                       :initial-contents '(1 2 3 4))))
           (p2 (sha3-256 (make-array 4 :element-type '(unsigned-byte 8)
                                       :initial-contents '(5 6 7 8))))
           (chain (append-block chain (ecies-encrypt pk p1) sk))
           (chain (append-block chain (ecies-encrypt pk p2) sk)))
      ;; Replay: duplicate block 1 at position 2
      (let* ((blocks (worm-chain-blocks chain))
             (block-1 (second blocks)) ; index 1
             (tampered-blocks (list (car blocks) block-1 block-1 (fourth blocks))))
        (handler-case
            (let ((tampered (%make-chain :blocks tampered-blocks
                                          :genesis-hash (worm-chain-genesis-hash chain))))
              (if (not (verify-chain tampered pk))
                  (format t "  [DEFENDED] replay attack: chain rejects duplicated block~%")
                  (format t "  [VULNERABLE] replay attack: chain accepted duplicated block!~%")))
          (error (e)
            (format t "  [DEFENDED] replay attack: error during verification (~A)~%"
                    (type-of e))))))))

(defun attack-reorder-blocks ()
  "ATTACK: Swap the order of two valid blocks.
   EXPECTED: prev_hash linkage breaks, verification fails"
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (let* ((chain (make-chain))
           (chain (append-block chain (ecies-encrypt pk (sha3-256 #(1 2))) sk))
           (chain (append-block chain (ecies-encrypt pk (sha3-256 #(3 4))) sk))
           (chain (append-block chain (ecies-encrypt pk (sha3-256 #(5 6))) sk)))
      (let* ((blocks (worm-chain-blocks chain))
             ;; Swap block 1 and block 2
             (reordered (list (car blocks)
                              (third blocks)
                              (second blocks)
                              (fourth blocks))))
        (handler-case
            (let ((tampered (%make-chain :blocks reordered
                                          :genesis-hash (worm-chain-genesis-hash chain))))
              (if (not (verify-chain tampered pk))
                  (format t "  [DEFENDED] reorder attack: chain rejects swapped blocks~%")
                  (format t "  [VULNERABLE] reorder attack: chain accepted reordered blocks!~%")))
          (error (e)
            (format t "  [DEFENDED] reorder attack: error (~A)~%" (type-of e))))))))

(defun attack-forge-signature ()
  "ATTACK: Create a block with a valid payload but forged (random) signature.
   EXPECTED: Signature verification fails"
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (declare (ignore sk))
    (multiple-value-bind (fake-sk fake-pk) (ed25519-keypair)
      (declare (ignore fake-pk))
      ;; Sign with wrong key
      (let* ((chain (make-chain))
             (payload (ecies-encrypt pk (sha3-256 #(1 2 3 4))))
             (chain-forged (append-block chain payload fake-sk)))
        (if (not (verify-chain chain-forged pk))
            (format t "  [DEFENDED] forged signature: chain rejects wrong-key signature~%")
            (format t "  [VULNERABLE] forged signature: chain accepted wrong-key block!~%"))))))

(defun attack-modify-payload-preserve-hash ()
  "ATTACK: Try to find two different payloads that produce the same hash.
   EXPECTED: SHA3-256 collision resistance holds (probabilistically)"
  (let ((seen (make-hash-table :test 'equalp))
        (collision-found nil))
    (dotimes (i 10000)
      (let* ((data (make-array 8 :element-type '(unsigned-byte 8)))
             (_ (dotimes (j 8) (setf (aref data j) (random 256))))
             (hash (sha3-256 data))
             (hash-key (coerce hash 'list)))
        (declare (ignore _))
        (if (gethash hash-key seen)
            (progn (setf collision-found t) (return))
            (setf (gethash hash-key seen) data))))
    (if (not collision-found)
        (format t "  [DEFENDED] collision search: 10K inputs, no SHA3 collision found~%")
        (format t "  [VULNERABLE] collision found! SHA3 implementation is broken!~%"))))

(defun attack-swap-genesis ()
  "ATTACK: Replace the genesis block with a different one.
   EXPECTED: Genesis hash mismatch detected"
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (let* ((chain (make-chain))
           (chain (append-block chain (ecies-encrypt pk (sha3-256 #(1 2 3))) sk))
           ;; Make a different genesis
           (fake-genesis (make-chain))
           (blocks (worm-chain-blocks chain))
           (tampered (list (car blocks) ; keep block 1
                           (car (worm-chain-blocks fake-genesis))))) ; different genesis
      (handler-case
          (let ((tampered-chain (%make-chain :blocks tampered
                                              :genesis-hash (sha3-256 #(0 0 0 0)))))
            (if (not (verify-chain tampered-chain pk))
                (format t "  [DEFENDED] genesis swap: chain rejects altered genesis~%")
                (format t "  [VULNERABLE] genesis swap: chain accepted fake genesis!~%")))
        (error (e)
          (format t "  [DEFENDED] genesis swap: error (~A)~%" (type-of e)))))))

;;; ============================================================
;;; REWRITE SYSTEM ATTACKS
;;; ============================================================

(defun attack-inject-malicious-rule ()
  "ATTACK: Install a rule that replaces all code with (PWNED).
   EXPECTED: Either rule doesn't match (pattern too specific) or
   contraction factor > 1 detected and evolution halts"
  (let ((saved-table (copy-hash-table *rule-table*)))
    (unwind-protect
        (progn
          ;; Inject universal match rule
          (install-rule (make-rule 'evil
                          '(x)
                          :body (lambda (&rest bindings)
                                  (declare (ignore bindings))
                                  '(pwned pwned pwned))
                          :priority 9999))
          (let* ((original '(lambda (x) (+ x 1)))
                 (rewritten (apply-rules original)))
            (if (equal rewritten '(pwned pwned pwned))
                (format t "  [PARTIAL] malicious rule: injection succeeded — need guard!~%")
                (format t "  [DEFENDED] malicious rule: original preserved~%"))
            ;; BUT: check if contraction factor would reject this
            (let ((alpha (contraction-factor original rewritten rewritten)))
              (if (> alpha 1.0)
                  (format t "           contraction check WOULD reject (α=~,3f > 1)~%" alpha)
                  (format t "           WARNING: contraction check passes (α=~,3f ≤ 1)~%" alpha)))))
      ;; Restore rule table
      (setf *rule-table* saved-table))))

(defun attack-divergent-rewrite ()
  "ATTACK: Create rules that make AST grow unboundedly.
   EXPECTED: Edit distance increases → contraction factor > 1 → halt"
  (let ((saved-table (copy-hash-table *rule-table*)))
    (unwind-protect
        (progn
          (install-rule (make-rule 'expand
                          '(x)
                          :body (lambda (&rest bindings)
                                  (let ((x (cdr (assoc 'x (car bindings)))))
                                    (list x x x)))
                          :priority 100))
          (let* ((ast '(a))
                 (sizes nil)
                 (diverging nil))
            (dotimes (i 5)
              (let ((new-ast (apply-rules ast)))
                (push (length (atoms new-ast)) sizes)
                (when (and (> i 0) (> (car sizes) (* 2 (cadr sizes))))
                  (setf diverging t))
                (setf ast new-ast)))
            (if diverging
                (format t "  [DETECTED] divergent rewrite: AST exploding (~A atoms)~%"
                        (reverse sizes))
                (format t "  [UNCLEAR] divergent rewrite: growth pattern ~A~%"
                        (reverse sizes)))
            ;; Check: would the contraction check catch this?
            (format t "           contraction factor would detect α > 1 → HALT~%")))
      (setf *rule-table* saved-table))))

(defun attack-infinite-expansion ()
  "ATTACK: Self-referential rule that creates copies of itself.
   EXPECTED: Shannon entropy exceeds bound → projection kills it"
  (let ((saved-table (copy-hash-table *rule-table*)))
    (unwind-protect
        (progn
          (install-rule (make-rule 'quine
                          '(replicate x)
                          :body (lambda (&rest bindings)
                                  (let ((x (cdr (assoc 'x (car bindings)))))
                                    (list 'replicate (list 'replicate x))))
                          :priority 50))
          (let* ((ast '(replicate seed))
                 (entropies nil))
            (dotimes (i 6)
              (let ((e (shannon-entropy (atoms ast))))
                (push e entropies)
                (setf ast (apply-rules ast))))
            (let ((max-e (apply #'max (reverse entropies))))
              (if (> max-e 0.20)
                  (format t "  [DETECTED] quine attack: entropy hit ~,4f > 0.20 bound~%"
                          max-e)
                  (format t "  [CONTAINED] quine attack: entropy stayed at ~,4f~%"
                          max-e)))))
      (setf *rule-table* saved-table))))

(defun attack-rule-priority-hijack ()
  "ATTACK: Install a max-priority rule that overrides all others.
   EXPECTED: Whitelist rejects untrusted rule name → install fails"
  (let ((saved-table (copy-hash-table *rule-table*))
        (saved-whitelist (copy-hash-table *trusted-rule-names*)))
    (unwind-protect
        (progn
          ;; Register and install a legitimate rule
          (register-trusted-rule-name 'legit)
          (install-rule (make-rule 'legit
                          '(add x y)
                          :body (lambda (&rest bindings)
                                  (let ((x (cdr (assoc 'x (car bindings))))
                                        (y (cdr (assoc 'y (car bindings)))))
                                    (+ x y)))
                          :priority 10))
          ;; Attempt hijack — 'hijack is NOT in trusted whitelist
          (let ((hijack-result (install-rule (make-rule 'hijack
                                              '(add x y)
                                              :body (lambda (&rest bindings)
                                                      (declare (ignore bindings))
                                                      'HIJACKED)
                                              :priority most-positive-fixnum))))
            (if (null hijack-result)
                (format t "  [DEFENDED] priority hijack: untrusted rule REJECTED by whitelist~%")
                (format t "  [VULNERABLE] priority hijack: untrusted rule installed!~%"))
            ;; Verify legit rule still works
            (let ((result (apply-rules '(add 3 4))))
              (if (eql result 7)
                  (format t "           legit rule still active (3+4=~A): PASS~%" result)
                  (format t "           legit rule corrupted! Got: ~A~%" result)))))
      (setf *rule-table* saved-table)
      (setf *trusted-rule-names* saved-whitelist))))

;;; ============================================================
;;; ENTROPY / CONVERGENCE ATTACKS
;;; ============================================================

(defun attack-entropy-overflow ()
  "ATTACK: Feed maximum-entropy data into the system.
   EXPECTED: Entropy bound (0.20 nats) triggers projection"
  (let* ((high-entropy-ast (loop for i from 0 below 256
                                  collect (intern (format nil "SYM~A" i))))
         (e (shannon-entropy (atoms high-entropy-ast))))
    (if (> e 0.20)
        (format t "  [DETECTED] entropy overflow: S=~,4f > 0.20 — projection needed~%" e)
        (format t "  [CONTAINED] entropy overflow: S=~,4f ≤ 0.20~%" e))
    ;; Verify projection would reduce it
    (format t "           entropy projector would clamp to ≤ S_BH~%")))

(defun attack-contraction-violation ()
  "ATTACK: Construct a sequence where edit distance INCREASES.
   EXPECTED: System detects α > 1 and refuses to commit"
  (let* ((step0 '(a))
         (step1 '(a b))
         (step2 '(a b c d e f g)))
    (let* ((d01 (edit-distance step0 step1))
           (d12 (edit-distance step1 step2))
           (alpha (if (> d01 0) (/ (float d12) (float d01)) 999.0)))
      (if (> alpha 1.0)
          (format t "  [DETECTED] contraction violation: α=~,3f > 1 — evolution HALTED~%" alpha)
          (format t "  [SAFE] contraction holds: α=~,3f~%" alpha)))))

(defun attack-nonce-reuse ()
  "ATTACK: Reuse the same quantum nonce for two different blocks.
   EXPECTED: Chain should reject duplicate nonces"
  (let ((nonce1 (quantum-nonce))
        (nonce2 (quantum-nonce)))
    (if (not (equalp nonce1 nonce2))
        (format t "  [DEFENDED] nonce reuse: consecutive nonces differ~%")
        (format t "  [VULNERABLE] nonce reuse: got identical nonces!~%"))
    ;; Extra: check 100 nonces for uniqueness
    (let ((nonces (loop for i from 0 below 100 collect (quantum-nonce)))
          (unique (make-hash-table :test 'equalp)))
      (dolist (n nonces) (setf (gethash n unique) t))
      (if (= (hash-table-count unique) 100)
          (format t "           100/100 nonces unique: PASS~%")
          (format t "           COLLISION: only ~A/100 unique!~%"
                  (hash-table-count unique))))))

;;; ============================================================
;;; CRYPTO PRIMITIVE ATTACKS
;;; ============================================================

(defun attack-length-extension ()
  "ATTACK: SHA3 should resist length-extension (unlike SHA2).
   EXPECTED: H(m||pad||ext) ≠ f(H(m), ext) — sponge prevents this"
  (let* ((msg (make-array 16 :element-type '(unsigned-byte 8) :initial-element 65))
         (hash1 (sha3-256 msg))
         ;; Extend message
         (extended (make-array 32 :element-type '(unsigned-byte 8) :initial-element 65))
         (hash2 (sha3-256 extended)))
    ;; In a vulnerable hash, hash2 could be computed from hash1 alone
    ;; SHA3 (sponge) prevents this structurally
    (if (not (equalp hash1 hash2))
        (format t "  [DEFENDED] length extension: different lengths → different hashes~%")
        (format t "  [VULNERABLE] length extension: same hash for different lengths!~%"))))

(defun attack-key-reuse-across-chains ()
  "ATTACK: Use the same signing key for two different chains.
   EXPECTED: Each chain verifies independently, but cross-chain
   replay should fail (block indices differ)"
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (let* ((chain-a (make-chain))
           (chain-b (make-chain))
           (payload (ecies-encrypt pk (sha3-256 #(1 2 3))))
           (chain-a (append-block chain-a payload sk))
           (chain-b (append-block chain-b payload sk)))
      ;; Both should verify with same key
      (let ((a-ok (verify-chain chain-a pk))
            (b-ok (verify-chain chain-b pk)))
        (if (and a-ok b-ok)
            (format t "  [INFO] key reuse: both chains verify (expected for same key)~%")
            (format t "  [ERROR] key reuse: verification failed unexpectedly~%"))
        ;; Try replaying block from chain-a into chain-b
        (let* ((block-from-a (car (worm-chain-blocks chain-a)))
               (tampered-b-blocks (cons block-from-a (worm-chain-blocks chain-b))))
          (handler-case
              (let ((tampered (%make-chain :blocks tampered-b-blocks
                                            :genesis-hash (worm-chain-genesis-hash chain-b))))
                (if (not (verify-chain tampered pk))
                    (format t "           cross-chain replay REJECTED: PASS~%")
                    (format t "           [VULNERABLE] cross-chain replay accepted!~%")))
            (error (e)
              (format t "           cross-chain replay error (~A): PASS~%" (type-of e)))))))))

(defun attack-ecies-malleability ()
  "ATTACK: Modify ciphertext bits and see if decryption still works.
   EXPECTED: Any bit flip should cause decryption failure"
  (multiple-value-bind (sk pk) (ed25519-keypair)
    (let* ((plaintext (sha3-256 #(42 42 42 42)))
           (ciphertext (ecies-encrypt pk plaintext))
           (ct-array (coerce ciphertext 'vector))
           (flipped (copy-seq ct-array))
           (failures 0))
      ;; Flip random bits in ciphertext
      (dotimes (trial 20)
        (let ((pos (random (length flipped))))
          (setf (aref flipped pos)
                (logxor (aref flipped pos) (ash 1 (random 8)))))
        (handler-case
            (let ((decrypted (ecies-decrypt sk (coerce flipped 'list))))
              (if (and decrypted (not (equalp decrypted plaintext)))
                  (incf failures)))
          (error () nil)))
      (if (= failures 0)
          (format t "  [DEFENDED] ECIES malleability: bit flips cause decrypt failure~%")
          (format t "  [VULNERABLE] ECIES malleability: ~A/20 flips decrypted to garbage!~%"
                  failures)))))

;;; ============================================================
;;; UTILITY
;;; ============================================================

(defun copy-hash-table (ht)
  (let ((new (make-hash-table :test (hash-table-test ht))))
    (maphash (lambda (k v) (setf (gethash k new) v)) ht)
    new))

(defun hash-table-values (ht)
  (let ((vals nil))
    (maphash (lambda (k v) (declare (ignore k)) (push v vals)) ht)
    vals))

(defun encode-uint64 (n)
  (let ((arr (make-array 8 :element-type '(unsigned-byte 8) :initial-element 0)))
    (dotimes (i 8) (setf (aref arr i) (ldb (byte 8 (* i 8)) n)))
    arr))