Further make simplified model work, WIP

prototype.lisp

@@ -92,11 +92,11 @@
 
 (defmethod generate-blind-key ((bl ec-bl)) (random-scalar (ec bl)))
 (defmethod derive-blind-key ((bl ec-bl) ikm)
-  (let ((h2c (make-instance 'h2c :ec (ec bl) :h (h bl) :dst (id bl))))
+  (let ((h2c (make-instance 'h2c :ec (ec bl) :h (hash bl) :dst (id bl))))
     (hash-to-field h2c ikm)))
 (defmethod derive-blinding-factor ((bl ec-bl) bk ctx)
   (let ((h2c (make-instance 'h2c :ec (ec bl) :h (hash bl) :dst (id bl))))
-    (hash-to-field h2c bk '(#x00) ctx)))
+    (hash-to-field h2c (i2osp bk 32) '(#x00) ctx)))
 (defmethod combine ((bl ec-bl-mul) bf1 bf2)
   (mod (* bf1 bf2) (order (ec bl))))
 (defmethod blind-public-key ((bl ec-bl-mul) pk-s bk ctx)
@@ -163,7 +163,7 @@
 (defconstant +sha256+
   (make-instance 'h :id :sha256))
 (defconstant +p256+
-  (make-instance 'ec :n +secp256r1-l+ :g +secp256r1-g+ :id :secp256r1))
+  (make-instance 'ec-kg :n +secp256r1-l+ :g +secp256r1-g+ :id :secp256r1))
 (defconstant +ecdh-p256+
   (make-instance 'ec-dh :n-dh 32 :ec +p256+))
 (defconstant +bl-ecdh-p256+
@@ -189,18 +189,23 @@
                       :kem +dhkem-p256-hkdf-sha256+
                       :n-s 32))
 
-(defmethod fold ((hdk hdk) salt path &optional bf)
-  (cond ((null path) (values bf salt))
+(defmethod fold ((hdk hdk) pk salt path &optional bf seed)
+  (cond ((null path) (values pk bf salt))
 	((typep (car path) 'number)
-         (let ((ctx (create-context hdk (car path))))
-           (fold (derive-salt hdk salt ctx)
+         (let ((ctx (create-context hdk (car path)))
+               (bk (derive-blind-key (bl hdk) salt)))
+           (fold (blind-public-key (bl hdk) pk bk ctx)
+                 (derive-salt hdk salt ctx)
                  (cdr path)
-                 (let* ((bk (derive-blind-key (bl hdk) salt))
-                        (bf2 (derive-blinding-factor (bl hdk) bk ctx)))
-                   (if (null bf) bf2 (combine (bl hdk) bf bf2))))))
-	(t (fold (decap (kem hdk) (car path) (derive-key-pair (kem hdk) salt))
+                 (let ((bf2 (derive-blinding-factor (bl hdk) bk ctx)))
+                   (if (null bf) bf2 (combine (bl hdk) bf bf2)))
+                 (or seed salt))))
+	(t (fold pk
+                 (let ((sk-r (derive-key-pair (kem hdk) (concat (seed salt)))))
+                   (decap (kem hdk) (car path) sk-r))
                  (cdr path)
-                 bf))))
+                 bf
+                 (or seed salt)))))
 
 (defclass document () ((pk :reader pk :initarg :pk)))
 (defun make-document (hdk doc salt index)
@@ -215,41 +220,36 @@
    (device :reader device :initarg :device)
    (seed :reader seed :initarg :seed)))
 (defun make-app (hdk)
-  (make-instance
-   'app
-   :hdk hdk
-   :device (multiple-value-list (generate-key-pair (ec (bl hdk))))
-   :seed (crypto:random-data (seed-length hdk))))
+  (make-instance 'app
+                 :hdk hdk
+                 :device (multiple-value-list (generate-key-pair (ec (bl hdk))))
+                 :seed (crypto:random-data (seed-length hdk))))
 (defun pk-device (app) (car (device app)))
 (defun get-key-info (app hdk)
-  (multiple-value-bind (bf salt) (fold (hdk app) (seed app) hdk)
-    (let ((pk (blind-public-key (bl (hdk app))
-                                (pk-device app)
-                                (derive-blind-key (bl (hdk app))
-                                                  (fold (seed app) hdk))
-                              ;; TODO include pk folding in fold
-  (let ((pk (BL-Blind-Public-Key (pk-device app) (fold (seed app) hdk))))
+  (let ((pk (fold (hdk app) (pk-device app) (seed app) hdk)))
     (values pk '(:agree-key) (make-instance 'document :pk pk))))
-(defun create-shared-secret (app hdk reader-pk)
-  (Authenticate (cadr (device app)) reader-pk (fold (seed app) hdk)))
+(defmethod create-shared-secret (app hdk reader-pk)
+  (blind-dh (bl (hdk app)) (cadr (device app))
+            (nth-value 1 (fold (hdk app) (pk-device app) (seed app) hdk))
+            reader-pk))
 (defun delegate-key-creation (app hdk)
-  (KEM-Derive-Key-Pair (nth-value 1 (fold (seed app) hdk))))
+  (derive-key-pair (kem (hdk app))
+                   (fold (hdk app) (pk-device app) (seed app) hdk)))
 (defun accept-key (app hdk kh index pk-expected)
-  (multiple-value-bind (sk pk) (delegate-key-creation app hdk)
-    (declare (ignore pk))
-    (let ((salt (KEM-Decap kh sk))
-          (pk-bl (get-key-info app hdk)))
-      (assert (EC-Point-Equal
-               pk-expected
-               (BL-Blind-Public-Key pk-bl (HDK salt index))))
-      (append hdk (list kh index)))))
+  (let ((salt (decap (kem (hdk app)) kh (delegate-key-creation app hdk)))
+        (pk-bl (get-key-info app hdk))
+        (ctx (create-context (hdk app) index)))
+    (assert (crypto:ec-point-equal
+             pk-expected
+             (blind-public-key (bl (hdk app)) pk-bl salt ctx)))
+    (append hdk (list kh index))))
 
 (defconstant +hdk-root+ '(0))
 (defclass unit ()
-  ((app :reader app :initform (make-app))
+  ((app :reader app :initarg app)
    (index :reader index :initform (make-hash-table :weakness :key))))
 (defmacro unit-hdk (unit doc) (list 'gethash doc (list 'index unit)))
-(defun make-unit () (make-instance 'unit))
+(defun make-unit (hdk) (make-instance 'unit :app (make-app hdk)))
 (defun activate (unit)
   (multiple-value-bind (pk purposes doc) (get-key-info (app unit) +hdk-root+)
     (declare (ignore pk purposes))
@@ -264,12 +264,17 @@
          (app (app unit)))
     (setf (unit-hdk unit doc) (accept-key app hdk kh index (pk doc)))))
 
-(defclass reader () ((sk :reader sk :initform (EC-Random))))
-(defun make-reader () (make-instance 'reader))
+(defclass reader ()
+  ((sk :reader sk :initarg sk)
+   (kem :reader kem :initarg kem)))
+(defun make-reader (ec-dhkem)
+  (make-instance 'reader :sk (random-scalar (ec ec-dhkem))
+                         :kem ec-dhkem))
 (defun verify (reader doc device-data)
-  (= (OS2IP device-data)
-     (OS2IP (ECDH-Create-Shared-Secret (sk reader) (pk doc)))))
-(defmethod pk ((reader reader)) (EC-Scalar-Base-Mult (sk reader)))
+  (= (os2ip device-data)
+     (os2ip (create-shared-secret (kem reader) (sk reader) (pk doc)))))
+(defmethod pk ((reader reader))
+  (scalar-base-mult (ec (kem reader)) (sk reader)))
 
 (loop with vectors =
       `((""
@@ -289,38 +294,45 @@
 	   "c541708d3491184472c2c29bb749d4286b004ceb5ee6b9a7fa5b646c993f0ced"
            )))
       for (msg dst len result) in vectors
-      do (assert (= (OS2IP (expand_message_xmd (ASCII msg) (ASCII dst) len))
-                    result)))
+      do (assert
+          (= (let ((h2c (make-instance 'h2c :ec +p256+
+                                            :h +sha256+
+                                            :dst dst)))
+               (os2ip (expand-message-xmd h2c (ASCII msg) (ASCII dst) len))
+               result))))
 
 (assert
  (let* ((prk
-          (HKDF-Extract
-           (I2OSP #x000102030405060708090a0b0c 13)
-           (I2OSP #x0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b 22)))
-        (okm (HKDF-Expand prk (I2OSP #xf0f1f2f3f4f5f6f7f8f9 10) 42)))
+          (extract +hkdf-sha256+
+           (i2osp #x000102030405060708090a0b0c 13)
+           (i2osp #x0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b 22)))
+        (okm (expand +hkdf-sha256+ prk (i2osp #xf0f1f2f3f4f5f6f7f8f9 10) 42)))
    (and
-    (= (OS2IP prk)
+    (= (os2ip prk)
        #x077709362c2e32df0ddc3f0dc47bba6390b6c73bb50f9c3122ec844ad7c2b3e5)
-    (= (OS2IP okm)
+    (= (os2ip okm)
        (read-bytes
         "3cb25f25faacd57a90434f64d0362f2a2d2d0a90cf1a5a4c5db02d56ecc4c5bf34"
         "007208d5b887185865")))))
 
 (assert
- (= (KEM-Derive-Key-Pair
-     (I2OSP
+ (= (derive-key-pair +dhkem-p256-hkdf-sha256+
+     (i2osp
       #x4270e54ffd08d79d5928020af4686d8f6b7d35dbe470265f1f5aa22816ce860e 32))
     #x4995788ef4b9d6132b249ce59a77281493eb39af373d236a1fe415cb0c2d7beb))
 
-(assert (multiple-value-bind (sk pk) (KEM-Derive-Key-Pair (I2OSP #x01 4))
-	  (multiple-value-bind (k c) (KEM-Encap pk)
-	    (= (OS2IP k) (OS2IP (KEM-Decap c sk))))))
+(assert (let ((kem +dhkem-p256-hkdf-sha256+))
+          (multiple-value-bind (sk pk) (derive-key-pair kem (i2osp #x01 4))
+	  (multiple-value-bind (k c) (encap kem pk)
+	    (= (os2ip k) (os2ip (decap kem c sk)))))))
 
-(let* ((app (make-app))
+(let* ((app (make-app +hdk-ecdh-p256+))
        (pk-bl (get-key-info app +hdk-root+))
        (pk-kem (nth-value 1 (delegate-key-creation app +hdk-root+))))
-  (multiple-value-bind (salt kh) (KEM-Encap pk-kem)
-    (let ((pk-expected (BL-Blind-Public-Key pk-bl (HDK salt 0))))
+  (multiple-value-bind (salt kh) (encap (kem (hdk app)) pk-kem)
+    (let* ((ctx (create-context (hdk app) 0))
+           (salt-prime (derive-salt (hdk app) salt ctx))
+           (pk-expected (blind-public-key (bl (hdk app)) pk-bl salt-prime)))
       (accept-key app +hdk-root+ kh 0 pk-expected))))
 
 (let* ((unit (make-unit))