Fix bug in accept-key

prototype.lisp

@@ -91,7 +91,7 @@
   (i2osp (getf (crypto:ec-destructure-point (scalar-mult (ec dh) pk-y sk-x)) :x)
          (output-length dh)))
 
-(defmethod generate-blind-key ((bl ec-bl)) (random-scalar (ec bl)))
+;;(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 (hash bl) :dst (id bl))))
     (i2osp (hash-to-field h2c ikm) 32)))
@@ -106,7 +106,7 @@
   (create-shared-secret (ec-dh bl) sk-x (scalar-mult (ec bl) pk-y bf)))
 
 (defmethod create-context ((hdk hdk) index) (concat (id hdk) (i2osp index 4)))
-(defmethod derive-salt ((hdk hdk) salt ctx) (h (hash hdk) salt ctx))
+(defmethod derive-salt ((hdk hdk) salt ctx) (h (hash hdk) (id hdk) salt ctx))
 
 (defmethod mac ((hmac hmac) key &rest bs)
   (loop with mac = (crypto:make-mac :hmac key (id hmac))
@@ -191,27 +191,27 @@
                       :n-s 32
 		      :h +sha256+))
 
-(defmethod fold ((hdk hdk) pk salt path &optional bf seed)
-  (let ((seed (or seed salt)))
+(defmethod fold ((hdk hdk) pk seed path &optional bf salt)
+  (let ((salt (or salt seed)))
     (cond ((null path) (values pk bf salt))
 	  ((typep (car path) 'number)
            (let ((ctx (create-context hdk (car path)))
 		 (bk (derive-blind-key (bl hdk) salt)))
              (fold hdk
 		   (blind-public-key (bl hdk) pk bk ctx)
-                   (derive-salt hdk salt ctx)
+		   seed
                    (cdr path)
                    (let ((bf2 (derive-blinding-factor (bl hdk) bk ctx)))
                      (if (null bf) bf2 (combine (bl hdk) bf bf2)))
-                   seed)))
+                   (derive-salt hdk salt ctx))))
 	  (t (fold hdk
 		   pk
+		   seed
+		   (cdr path)
+		   bf
                    (let ((sk-r (derive-key-pair (kem hdk)
 						(concat seed salt))))
-                     (decap (kem hdk) (car path) sk-r))
-                   (cdr path)
-                   bf
-                   seed)))))
+                     (decap (kem hdk) (car path) sk-r)))))))
 
 (defclass document () ((pk :reader pk :initarg :pk)))
 (defun make-document (hdk doc salt index)
@@ -232,26 +232,26 @@
                  :seed (crypto:random-data (seed-length hdk))))
 (defun sk-device (app) (car (device app)))
 (defun pk-device (app) (cadr (device app)))
+(defun fold-hdk (app hdk) (fold (hdk app) (pk-device app) (seed app) hdk))
 (defun get-key-info (app hdk)
-  (let ((pk (fold (hdk app) (pk-device app) (seed app) hdk)))
+  (let ((pk (fold-hdk app hdk)))
     (values pk '(:agree-key) (make-instance 'document :pk pk))))
 (defmethod create-shared-secret (app hdk reader-pk)
-  (blind-dh (bl (hdk app)) (sk-device app)
-            (nth-value 1 (fold (hdk app) (pk-device app) (seed app) hdk))
+  (blind-dh (bl (hdk app))
+	    (sk-device app)
+            (nth-value 1 (fold-hdk app hdk))
             reader-pk))
 (defun delegate-key-creation (app hdk)
   (derive-key-pair (kem (hdk app))
 		   (concat (seed app)
-			   (nth-value 2
-				      (fold (hdk app) (pk-device app)
-					    (seed app) hdk)))))
+			   (nth-value 2 (fold-hdk app hdk)))))
 (defun accept-key (app hdk kh index pk-expected)
   (let ((salt (decap (kem (hdk app)) kh (delegate-key-creation app hdk)))
         (pk-bl (get-key-info app hdk))
+	(bk (derive-blind-key (bl (hdk app)) salt))
         (ctx (create-context (hdk app) index)))
-    (assert (crypto:ec-point-equal
-             pk-expected
-             (blind-public-key (bl (hdk app)) pk-bl salt ctx)))
+    (let ((pk-blinded (blind-public-key (bl (hdk app)) pk-bl bk ctx)))
+      (assert (crypto:ec-point-equal pk-expected pk-blinded)))
     (append hdk (list kh index))))
 
 (defconstant +hdk-root+ '(0))
@@ -336,15 +336,49 @@
 	  (multiple-value-bind (k c) (encap kem pk)
 	    (= (os2ip k) (os2ip (decap kem c sk)))))))
 
+(let* ((bl +bl-ecdh-p256+)
+       (ikm #(1 2 3))
+       (bk (derive-blind-key bl ikm))
+       (ctx #(4 5 6))
+       (bf (derive-blinding-factor bl bk ctx)))
+  (multiple-value-bind (sk-x pk-x) (generate-key-pair (ec bl))
+    (multiple-value-bind (sk-y pk-y) (generate-key-pair (ec bl))
+      (assert (= (os2ip (blind-dh bl sk-x bf pk-y))
+		 (let ((pk-blinded (blind-public-key bl pk-x bk ctx)))
+		   (os2ip (create-shared-secret
+			   (ec-dh bl) sk-y pk-blinded))))))))
+
+(let* ((bl +bl-ecdh-p256+)
+       (ikm #(1 2 3))
+       (bk (derive-blind-key bl ikm))
+       (ctx1 #(4 5 6))
+       (ctx2 #(7 8 9))
+       (bf1 (derive-blinding-factor bl bk ctx1))
+       (bf2 (derive-blinding-factor bl bk ctx2)))
+  (multiple-value-bind (sk pk) (generate-key-pair (ec bl))
+    (assert (= (os2ip
+		(create-shared-secret
+		 (ec-dh bl) 1
+		 (blind-public-key bl
+				   (blind-public-key bl pk bk ctx1)
+				   bk ctx2)))
+	       (os2ip
+		(blind-dh
+		 bl sk
+		 (combine bl bf1 bf2)
+		 +secp256r1-g+))))))
+
 (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+))))
+       (hdk +hdk-root+)
+       (pk-bl (get-key-info app hdk))
+       (pk-kem (nth-value 1 (delegate-key-creation app hdk))))
   (multiple-value-bind (salt kh) (encap (kem (hdk app)) pk-kem)
-    (let* ((bf (derive-blind-key (bl (hdk app)) salt))
-	   (index 0)
+    (let* ((bk (derive-blind-key (bl (hdk app)) salt))
+	   (index 42)
 	   (ctx (create-context (hdk app) index))
-           (pk-expected (blind-public-key (bl (hdk app)) pk-bl bf ctx)))
-      (accept-key app +hdk-root+ kh index pk-expected))))
+           (pk-expected (blind-public-key (bl (hdk app)) pk-bl bk ctx)))
+      (accept-key app hdk kh index pk-expected))))
+;; TODO haal seed er weer uit
 
 (let* ((unit (make-unit))
        (doc (activate unit)))