Skip to content

Commit cf6e9ac

Browse files
sandersander
committed
Prototype in Lisp matching spec 03
1 parent 3248ef6 commit cf6e9ac

File tree

5 files changed

+280
-311
lines changed

5 files changed

+280
-311
lines changed

‎Makefile

+12
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,18 @@ else
1010
-b main https://github.com/martinthomson/i-d-template $(LIBDIR)
1111
endif
1212

13+
demo:
14+
sbcl --non-interactive \
15+
--eval '(ql:quickload "ironclad")' \
16+
--load prototype.lisp \
17+
--load prototype.demo.lisp
18+
19+
repl:
20+
rlwrap sbcl \
21+
--eval '(ql:quickload "ironclad")' \
22+
--load prototype.lisp \
23+
--eval "(use-package 'prototype)"
24+
1325
hdk.pdf:
1426
mkdir -p build
1527
cp -r media build

‎README.md

+1-1
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,7 @@ Expert participants from Potential:
4747

4848
To address challenges 5 and 6, this repository contains a freely accessible, unencumbered specification of **[Hierarchical Deterministic Keys](draft-dijkhuis-cfrg-hdkeys.md)**. This enables an EU Digital Identity Wallet deployment that distributes key management efficiently:
4949

50-
To illustrate and validate the specifications, this repository contains a **[Prototype worksheet](prototype.worksheet.sc)**. This is easiest to run in [Visual Studio Code](https://code.visualstudio.com) with [Scala (Metals)](https://marketplace.visualstudio.com/items?itemName=scalameta.metals).
50+
To illustrate and validate the specifications, this repository contains a **[Prototype implementation](prototype.lisp)** and **[demo](prototype.demo.lisp)** to run with [Common Lisp](https://lisp-lang.org/learn/getting-started/) using `make demo` and `make repl`.
5151

5252
To inform further standardisation and legislation, this repository contains **[Feedback to enable Hierarchical Deterministic Keys in the Wallet Toolbox](feedback.md)**. It also contains **[Feedback to resolve HDK and PoA issues in the ARF](feedback-poa.md)**.
5353

‎prototype.demo.lisp

+35
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
(defpackage #:demo (:use #:common-lisp #:prototype))
2+
(in-package #:demo)
3+
4+
(defvar *wallet* (make-unit))
5+
(defvar *evidence* (activate *wallet*))
6+
7+
;; Present wallet trust evidence to the PID provider
8+
(let* ((reader (make-reader))
9+
(device-data (prove-possession *wallet* *evidence* (pk reader))))
10+
(assert (verify reader *evidence* device-data)))
11+
12+
;; Request issuance using remote key derivation
13+
(defvar *pk-kem* (request *wallet* *evidence*))
14+
15+
;; Create a key handle and issue a first batch of PID
16+
(defvar *kh*)
17+
(defvar *pid*)
18+
(multiple-value-bind (salt kh) (KEM-Encaps *pk-kem* *ID*)
19+
(setf *kh* kh)
20+
(setf *pid* (loop for i in '(0 1 2 3)
21+
collect (make-document *evidence* salt i))))
22+
23+
;; Accept the first batch of PID, using synchronised indices
24+
;; (synchronisation is implicit: easy upon first batch)
25+
(loop for i in '(0 1 2 3)
26+
for doc in *pid*
27+
do (accept *wallet* *evidence* *kh* i doc))
28+
29+
;; Present PID to various readers
30+
(loop for doc in *pid* do
31+
(let* ((reader (make-reader))
32+
(device-data (prove-possession *wallet* doc (pk reader))))
33+
(assert (verify reader doc device-data))))
34+
35+
(format t "Demo finished~%")

‎prototype.lisp

+232
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,232 @@
1+
(defpackage #:prototype
2+
(:export #:KEM-Encaps
3+
#:HDK #:*ID*
4+
#:make-unit #:activate #:prove-possession #:request #:accept
5+
#:make-reader #:pk #:verify
6+
#:make-document)
7+
(:use #:common-lisp)
8+
(:import-from #:crypto
9+
#:+secp256r1-l+ #:+secp256r1-g+ #:EC-Scalar-Mult #:EC-Point-Equal))
10+
11+
(in-package #:prototype)
12+
13+
(defun || (&rest bs) (apply #'concatenate '(vector (unsigned-byte 8)) bs))
14+
(defun I2OSP (i n) (crypto:integer-to-octets i :n-bits (* n 8)))
15+
(defun OS2IP (os) (crypto:octets-to-integer os))
16+
(defun strxor (s1 s2) (map 'crypto::simple-octet-vector #'logxor s1 s2))
17+
(defun ASCII (s) (crypto:ascii-string-to-byte-array s))
18+
(defun read-bytes (&rest hex-strings)
19+
(read-from-string (apply #'concatenate 'string "#x" hex-strings)))
20+
21+
(defun H (&rest bs) (loop with hash = (crypto:make-digest :sha256)
22+
for b in bs do (crypto:update-digest hash b)
23+
finally (return (crypto:produce-digest hash))))
24+
(defun expand_message_xmd (msg dst len)
25+
(loop with dst = (|| dst (I2OSP (length dst) 1))
26+
with b = (make-array len :fill-pointer 0)
27+
with b0 = (H (I2OSP 0 64) msg (I2OSP len 2) (I2OSP 0 1) dst)
28+
for i from 1 upto (ceiling (/ len 32))
29+
for bi = (H b0 (I2OSP 1 1) dst) then (H (strxor b0 bi) (I2OSP i 1) dst)
30+
do (loop for j across bi do (vector-push j b))
31+
finally (return (coerce b 'crypto::simple-octet-vector))))
32+
33+
(defparameter *q* nil)
34+
(defparameter *DST* nil)
35+
(defun hash_to_field (msg) (mod (OS2IP (expand_message_xmd msg *DST* 48)) *q*))
36+
37+
(defparameter *ID* (ASCII "HDK-ECDH-P256-v1"))
38+
39+
(defparameter *EC* :secp256r1)
40+
(defun EC-Order () +secp256r1-l+)
41+
(defun EC-Random () (1+ (crypto:strong-random (1- (EC-Order)))))
42+
(defun EC-Scalar-Base-Mult (k) (EC-Scalar-Mult +secp256r1-g+ k))
43+
44+
(defun BL-Generate-Blinding-Key-Pair ()
45+
(let ((sk (EC-Random))) (values (EC-Scalar-Base-Mult sk) sk)))
46+
(defun BL-Derive-Blinding-Factor (msg ctx)
47+
(let ((*DST* (|| *ID* ctx)) (*q* (EC-Order))) (hash_to_field msg)))
48+
(defun BL-Blind-Public-Key (pk bf) (EC-Scalar-Mult pk bf))
49+
(defun BL-Blind-Private-Key (sk bf) (mod (* sk bf) (EC-Order)))
50+
(defun BL-Combine-Blinding-Factors (bf1 bf2) (mod (* bf1 bf2) (EC-Order)))
51+
52+
(defun ECDH-Create-Shared-Secret (sk pk)
53+
(I2OSP (getf (crypto:ec-destructure-point (EC-Scalar-Mult pk sk)) :x) 32))
54+
55+
(defun HMAC-SHA256 (key &rest bs)
56+
(loop with mac = (crypto:make-mac :hmac key :sha256)
57+
for b in bs do (crypto:update-mac mac b)
58+
finally (return (crypto:produce-mac mac))))
59+
60+
(defun HKDF-Extract (salt ikm) (HMAC-SHA256 salt ikm))
61+
(defun HKDF-Expand (prk info len)
62+
(loop with tb = (make-array len :fill-pointer 0)
63+
for i from 1 upto (ceiling (/ len 32))
64+
for ti = (HMAC-SHA256 prk (|| info (I2OSP i 1)))
65+
then (HMAC-SHA256 prk (|| ti info (I2OSP i 1)))
66+
do (loop for j across ti do (vector-push j tb))
67+
finally (return (coerce tb '(vector (unsigned-byte 8))))))
68+
69+
(defun ECP2OS (point)
70+
(|| (I2OSP (getf (crypto:ec-destructure-point point) :x) 32)
71+
(I2OSP (getf (crypto:ec-destructure-point point) :y) 32)))
72+
(defun OS2ECP (b)
73+
(crypto:ec-make-point
74+
*EC* :x (OS2IP (subseq b 0 32)) :y (OS2IP (subseq b 32))))
75+
76+
(defun KEM-Derive-Key-Pair (msg ctx) ; TODO #80
77+
(let* ((*DST* (|| *ID* '(#x01) ctx))
78+
(*q* (EC-Order))
79+
(sk (hash_to_field msg)))
80+
(values (EC-Scalar-Base-Mult sk) sk)))
81+
(defun KEM-Encaps (pk ctx)
82+
(let* ((sk-prime (EC-Random))
83+
(pk-prime (EC-Scalar-Base-Mult sk-prime))
84+
(k-prime (ECDH-Create-Shared-Secret sk-prime pk))
85+
(prk (HKDF-Extract (I2OSP 0 32) k-prime)))
86+
(values (HKDF-Expand prk (|| (ASCII "TMPKEM") ctx) 32) (ECP2OS pk-prime))))
87+
(defun KEM-Decaps (sk c ctx)
88+
(let* ((pk-prime (OS2ECP c))
89+
(k-prime (ECDH-Create-Shared-Secret sk pk-prime))
90+
(prk (HKDF-Extract (I2OSP 0 32) k-prime)))
91+
(HKDF-Expand prk (|| (ASCII "TMPKEM") ctx) 32)))
92+
93+
(defun Authenticate (sk_device reader_data bf)
94+
(ECDH-Create-Shared-Secret sk_device (EC-Scalar-Mult reader_data bf)))
95+
96+
(defun H1 (msg) (H *ID* msg))
97+
(defparameter *Ns* 32)
98+
(defun HDK (salt index)
99+
(let ((msg (|| salt (I2OSP index 4))))
100+
(values (BL-Derive-Blinding-Factor msg *ID*) (H1 msg))))
101+
102+
(defun fold (salt path &optional bf)
103+
(cond ((null path) (values bf salt))
104+
((typep (car path) 'number)
105+
(multiple-value-bind (bf-prime salt) (HDK salt (car path))
106+
(if (null bf) (fold salt (cdr path) bf-prime)
107+
(fold salt (cdr path)
108+
(BL-Combine-Blinding-Factors bf bf-prime)))))
109+
(t (multiple-value-bind (pk sk) (KEM-Derive-Key-Pair salt *ID*)
110+
(declare (ignore pk))
111+
(fold (KEM-Decaps sk (car path) *ID*) (cdr path) bf)))))
112+
113+
(defclass document () ((pk :reader pk :initarg :pk)))
114+
(defun make-document (doc salt index)
115+
(make-instance 'document
116+
:pk (BL-Blind-Public-Key (pk doc) (HDK salt index))))
117+
118+
(defclass app ()
119+
((device :reader device
120+
:initform (multiple-value-list (BL-Generate-Blinding-Key-Pair)))
121+
(seed :reader seed :initform (crypto:random-data *Ns*))))
122+
(defun make-app () (make-instance 'app))
123+
(defun pk-device (app) (car (device app)))
124+
(defun get-key-info (app hdk)
125+
(let ((pk (BL-Blind-Public-Key (pk-device app) (fold (seed app) hdk))))
126+
(values pk '(:agree-key) (make-instance 'document :pk pk))))
127+
(defun create-shared-secret (app hdk reader-pk)
128+
(Authenticate (cadr (device app)) reader-pk (fold (seed app) hdk)))
129+
(defun delegate-key-creation (app hdk)
130+
(KEM-Derive-Key-Pair (nth-value 1 (fold (seed app) hdk)) *ID*))
131+
(defun accept-key (app hdk kh index pk-expected)
132+
(multiple-value-bind (pk sk) (delegate-key-creation app hdk)
133+
(declare (ignore pk))
134+
(let ((salt (KEM-Decaps sk kh *ID*))
135+
(pk-bl (get-key-info app hdk)))
136+
(assert (EC-Point-Equal
137+
pk-expected
138+
(BL-Blind-Public-Key pk-bl (HDK salt index))))
139+
(append hdk (list kh index)))))
140+
141+
(defconstant +hdk-root+ '(0))
142+
(defclass unit ()
143+
((app :reader app :initform (make-app))
144+
(index :reader index :initform (make-hash-table :weakness :key))))
145+
(defmacro unit-hdk (unit doc) (list 'gethash doc (list 'index unit)))
146+
(defun make-unit () (make-instance 'unit))
147+
(defun activate (unit)
148+
(multiple-value-bind (pk purposes doc) (get-key-info (app unit) +hdk-root+)
149+
(declare (ignore pk purposes))
150+
(setf (unit-hdk unit doc) +hdk-root+)
151+
doc))
152+
(defun prove-possession (unit doc reader-data)
153+
(create-shared-secret (app unit) (unit-hdk unit doc) reader-data))
154+
(defun request (unit doc-parent)
155+
(delegate-key-creation (app unit) (unit-hdk unit doc-parent)))
156+
(defun accept (unit doc-parent kh index doc)
157+
(let* ((hdk (unit-hdk unit doc-parent))
158+
(app (app unit)))
159+
(setf (unit-hdk unit doc) (accept-key app hdk kh index (pk doc)))))
160+
161+
(defclass reader () ((sk :reader sk :initform (EC-Random))))
162+
(defun make-reader () (make-instance 'reader))
163+
(defun verify (reader doc device-data)
164+
(= (OS2IP device-data)
165+
(OS2IP (ECDH-Create-Shared-Secret (sk reader) (pk doc)))))
166+
(defmethod pk ((reader reader)) (EC-Scalar-Base-Mult (sk reader)))
167+
168+
(loop with vectors =
169+
`((""
170+
"QUUX-V01-CS02-with-expander-SHA256-128" #x20
171+
,(read-bytes
172+
"68a985b87eb6b46952128911f2a4412bbc302a9d759667f87f7a21d803f07235"))
173+
("abc"
174+
"QUUX-V01-CS02-with-expander-SHA256-128" #x20
175+
,(read-bytes
176+
"d8ccab23b5985ccea865c6c97b6e5b8350e794e603b4b97902f53a8a0d605615"))
177+
(""
178+
"QUUX-V01-CS02-with-expander-SHA256-128" #x80
179+
,(read-bytes
180+
"af84c27ccfd45d41914fdff5df25293e221afc53d8ad2ac06d5e3e29485dadbe"
181+
"e0d121587713a3e0dd4d5e69e93eb7cd4f5df4cd103e188cf60cb02edc3edf18"
182+
"eda8576c412b18ffb658e3dd6ec849469b979d444cf7b26911a08e63cf31f9dc"
183+
"c541708d3491184472c2c29bb749d4286b004ceb5ee6b9a7fa5b646c993f0ced"
184+
)))
185+
for (msg dst len result) in vectors
186+
do (assert (= (OS2IP (expand_message_xmd (ASCII msg) (ASCII dst) len))
187+
result)))
188+
189+
(assert
190+
(let* ((prk
191+
(HKDF-Extract
192+
(I2OSP #x000102030405060708090a0b0c 13)
193+
(I2OSP #x0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b 22)))
194+
(okm (HKDF-Expand prk (I2OSP #xf0f1f2f3f4f5f6f7f8f9 10) 42)))
195+
(and
196+
(= (OS2IP prk)
197+
#x077709362c2e32df0ddc3f0dc47bba6390b6c73bb50f9c3122ec844ad7c2b3e5)
198+
(= (OS2IP okm)
199+
(read-bytes
200+
"3cb25f25faacd57a90434f64d0362f2a2d2d0a90cf1a5a4c5db02d56ecc4c5bf34"
201+
"007208d5b887185865")))))
202+
203+
(assert (multiple-value-bind (pk sk) (KEM-Derive-Key-Pair
204+
(I2OSP #x01 4)
205+
(I2OSP #x02 4))
206+
(multiple-value-bind (k c) (KEM-Encaps pk (ASCII "info"))
207+
(= (OS2IP k) (OS2IP (KEM-Decaps sk c (ASCII "info")))))))
208+
209+
(let* ((app (make-app))
210+
(pk-bl (get-key-info app +hdk-root+))
211+
(pk-kem (delegate-key-creation app +hdk-root+)))
212+
(multiple-value-bind (salt kh) (KEM-Encaps pk-kem *ID*)
213+
(let ((pk-expected (BL-Blind-Public-Key pk-bl (HDK salt 0))))
214+
(accept-key app +hdk-root+ kh 0 pk-expected))))
215+
216+
(let* ((unit (make-unit))
217+
(doc (activate unit)))
218+
(let* ((reader (make-reader))
219+
(device-data (prove-possession unit doc (pk reader))))
220+
(assert (verify reader doc device-data)))
221+
(let ((pk-kem (request unit doc)))
222+
(multiple-value-bind (salt kh) (KEM-Encaps pk-kem *ID*)
223+
(let* ((range '(0 1 2 3 4 5 6 7 8))
224+
(docs (loop for i in range collect (make-document doc salt i))))
225+
(loop for i in range for d in docs do (accept unit doc kh i d))
226+
(assert (= 9 (length docs)))
227+
(loop for doc in docs do
228+
(let* ((reader (make-reader))
229+
(device-data (prove-possession unit doc (pk reader))))
230+
(assert (verify reader doc device-data))))))))
231+
232+
(format t "Tests ran successfully~%")

0 commit comments

Comments
 (0)