1;;;; -*- mode: lisp; indent-tabs-mode: nil -*-
2;;;; ed448.lisp -- implementation of the ed448 signature algorithm
3
4(in-package :crypto)
5
6
7;;; class definitions
8
9(defclass ed448-public-key ()
10  ((y :initarg :y :reader ed448-key-y :type (simple-array (unsigned-byte 8) (*)))))
11
12(defclass ed448-private-key ()
13  ((x :initarg :x :reader ed448-key-x :type (simple-array (unsigned-byte 8) (*)))
14   (y :initarg :y :reader ed448-key-y :type (simple-array (unsigned-byte 8) (*)))))
15
16(eval-when (:compile-toplevel :load-toplevel :execute)
17  (defclass ed448-point ()
18    ;; Internally, a point (x, y) is represented using the projective
19    ;; coordinates (X, Y, Z), with x = X / Z and y = Y / Z.
20    ((x :initarg :x :type integer)
21     (y :initarg :y :type integer)
22     (z :initarg :z :type integer)))
23  (defmethod make-load-form ((p ed448-point) &optional env)
24    (declare (ignore env))
25    (make-load-form-saving-slots p)))
26
27
28;;; constant and function definitions
29
30(defconstant +ed448-bits+ 456)
31(defconstant +ed448-q+ 726838724295606890549323807888004534353641360687318060281490199180612328166730772686396383698676545930088884461843637361053498018365439)
32(defconstant +ed448-l+ 181709681073901722637330951972001133588410340171829515070372549795146003961539585716195755291692375963310293709091662304773755859649779)
33(defconstant +ed448-d+ -39081)
34
35(defconst +ed448-b+
36  (make-instance 'ed448-point
37                 :x 224580040295924300187604334099896036246789641632564134246125461686950415467406032909029192869357953282578032075146446173674602635247710
38                 :y 298819210078481492676017930443930673437544040154080242095928241372331506189835876003536878655418784733982303233503462500531545062832660
39                 :z 1))
40(defconst +ed448-point-at-infinity+
41  (make-instance 'ed448-point :x 0 :y 1 :z 1))
42
43
44(eval-when (:compile-toplevel :load-toplevel :execute)
45  (defun ed448-dom (x y)
46    (declare (type (unsigned-byte 8) x)
47             (type (simple-array (unsigned-byte 8) (*)) y)
48             (optimize (speed 3) (safety 0) (space 0) (debug 0)))
49    (when (> (length y) 255)
50      (error 'ironclad-error
51             :format-control "The Y array is to big."))
52    (concatenate '(simple-array (unsigned-byte 8) (*))
53                 (map 'vector #'char-code "SigEd448")
54                 (vector x)
55                 (vector (length y))
56                 y)))
57;; Ed448 (x = 0), no context (y = #())
58(defconst +ed448-dom+ (ed448-dom 0 (make-array 0 :element-type '(unsigned-byte 8))))
59
60(defmethod ec-scalar-inv ((kind (eql :ed448)) n)
61  (expt-mod n (- +ed448-q+ 2) +ed448-q+))
62
63(defun ed448-recover-x (y)
64  "Recover the X coordinate of a point on ed448 curve from the Y coordinate."
65  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
66           (type integer y))
67  (let* ((u (mod (1- (* y y)) +ed448-q+))
68         (v (mod (1- (* +ed448-d+ (1+ u))) +ed448-q+))
69         (uv (mod (* u v) +ed448-q+))
70         (u3v (mod (* u u uv) +ed448-q+))
71         (u5v3 (mod (* u3v uv uv) +ed448-q+))
72         (x (mod (* u3v (expt-mod u5v3 (/ (- +ed448-q+ 3) 4) +ed448-q+)) +ed448-q+)))
73    (declare (type integer u v uv u3v u5v3 x))
74    (unless (evenp x)
75      (setf x (- +ed448-q+ x)))
76    x))
77
78(defmethod ec-add ((p ed448-point) (q ed448-point))
79  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
80  (with-slots ((x1 x) (y1 y) (z1 z)) p
81    (declare (type integer x1 y1 z1))
82    (with-slots ((x2 x) (y2 y) (z2 z)) q
83      (declare (type integer x2 y2 z2))
84      (let* ((a (mod (* z1 z2) +ed448-q+))
85             (b (mod (* a a) +ed448-q+))
86             (c (mod (* x1 x2) +ed448-q+))
87             (d (mod (* y1 y2) +ed448-q+))
88             (k (mod (* c d) +ed448-q+))
89             (e (mod (* +ed448-d+ k) +ed448-q+))
90             (f (mod (- b e) +ed448-q+))
91             (g (mod (+ b e) +ed448-q+))
92             (h (mod (* (+ x1 y1) (+ x2 y2)) +ed448-q+))
93             (i (mod (* a f) +ed448-q+))
94             (j (mod (* a g) +ed448-q+))
95             (x3 (mod (* i (- h c d)) +ed448-q+))
96             (y3 (mod (* j (- d c)) +ed448-q+))
97             (z3 (mod (* f g) +ed448-q+)))
98        (declare (type integer a b c d e f g h i j k x3 y3 z3))
99        (make-instance 'ed448-point :x x3 :y y3 :z z3)))))
100
101(defmethod ec-double ((p ed448-point))
102  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
103  (with-slots ((x1 x) (y1 y) (z1 z)) p
104    (declare (type integer x1 y1 z1))
105    (let* ((a (mod (+ x1 y1) +ed448-q+))
106           (b (mod (* a a) +ed448-q+))
107           (c (mod (* x1 x1) +ed448-q+))
108           (d (mod (* y1 y1) +ed448-q+))
109           (e (mod (+ c d) +ed448-q+))
110           (f (mod (* z1 z1) +ed448-q+))
111           (g (mod (- e (* 2 f)) +ed448-q+))
112           (x2 (mod (* (- b e) g) +ed448-q+))
113           (y2 (mod (* (- c d) e) +ed448-q+))
114           (z2 (mod (* e g) +ed448-q+)))
115      (declare (type integer a b c d e f g x2 y2 z2))
116      (make-instance 'ed448-point :x x2 :y y2 :z z2))))
117
118(defmethod ec-scalar-mult ((p ed448-point) e)
119  ;; Point multiplication on ed448 curve using the Montgomery ladder.
120  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
121           (type integer e))
122  (do ((r0 +ed448-point-at-infinity+)
123       (r1 p)
124       (i 447 (1- i)))
125      ((minusp i) r0)
126    (declare (type ed448-point r0 r1)
127             (type fixnum i))
128    (if (logbitp i e)
129        (setf r0 (ec-add r0 r1)
130              r1 (ec-double r1))
131        (setf r1 (ec-add r0 r1)
132              r0 (ec-double r0)))))
133
134(defmethod ec-point-on-curve-p ((p ed448-point))
135  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
136  (with-slots (x y z) p
137    (declare (type integer x y z))
138    (let* ((xx (mod (* x x) +ed448-q+))
139           (yy (mod (* y y) +ed448-q+))
140           (zz (mod (* z z) +ed448-q+))
141           (zzzz (mod (* zz zz) +ed448-q+))
142           (a (mod (* zz (+ yy xx)) +ed448-q+))
143           (b (mod (+ zzzz (* +ed448-d+ xx yy)) +ed448-q+)))
144      (declare (type integer xx yy zz zzzz a b))
145      (zerop (mod (- a b) +ed448-q+)))))
146
147(defmethod ec-point-equal ((p ed448-point) (q ed448-point))
148  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
149  (with-slots ((x1 x) (y1 y) (z1 z)) p
150    (declare (type integer x1 y1 z1))
151    (with-slots ((x2 x) (y2 y) (z2 z)) q
152      (declare (type integer x2 y2 z2))
153      (and (zerop (mod (- (* x1 z2) (* x2 z1)) +ed448-q+))
154           (zerop (mod (- (* y1 z2) (* y2 z1)) +ed448-q+))))))
155
156(defmethod ec-encode-scalar ((kind (eql :ed448)) n)
157  (integer-to-octets n :n-bits +ed448-bits+ :big-endian nil))
158
159(defmethod ec-decode-scalar ((kind (eql :ed448)) octets)
160  (octets-to-integer octets :big-endian nil))
161
162(defmethod ec-encode-point ((p ed448-point))
163  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
164  (with-slots (x y z) p
165    (declare (type integer x y z))
166    (let* ((invz (ec-scalar-inv :ed448 z))
167           (x (mod (* x invz) +ed448-q+))
168           (y (mod (* y invz) +ed448-q+)))
169      (declare (type integer x y))
170      (setf (ldb (byte 1 (- +ed448-bits+ 1)) y) (ldb (byte 1 0) x))
171      (ec-encode-scalar :ed448 y))))
172
173(defmethod ec-decode-point ((kind (eql :ed448)) octets)
174  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
175  (let* ((y (ec-decode-scalar :ed448 octets))
176         (b (ldb (byte 1 (- +ed448-bits+ 1)) y)))
177    (setf (ldb (byte 1 (- +ed448-bits+ 1)) y) 0)
178    (let ((x (ed448-recover-x y)))
179      (declare (type integer x))
180      (unless (= (ldb (byte 1 0) x) b)
181        (setf x (- +ed448-q+ x)))
182      (let ((p (make-instance 'ed448-point :x x :y y :z 1)))
183        (if (ec-point-on-curve-p p)
184            p
185            (error 'invalid-curve-point :kind 'ed448))))))
186
187(defun ed448-hash (&rest messages)
188  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
189  (let ((digest (make-digest :shake256 :output-length 114)))
190    (dolist (m messages)
191      (update-digest digest m))
192    (produce-digest digest)))
193
194(defun ed448-public-key (sk)
195  "Compute the public key associated to the private key SK."
196  (let ((h (ed448-hash sk)))
197    (setf h (subseq h 0 (ceiling +ed448-bits+ 8)))
198    (setf (ldb (byte 2 0) (elt h 0)) 0)
199    (setf (ldb (byte 1 7) (elt h (- (ceiling +ed448-bits+ 8) 2))) 1)
200    (setf (elt h (- (ceiling +ed448-bits+ 8) 1)) 0)
201    (let ((a (ec-decode-scalar :ed448 h)))
202      (ec-encode-point (ec-scalar-mult +ed448-b+ a)))))
203
204(defmethod make-signature ((kind (eql :ed448)) &key r s &allow-other-keys)
205  (unless r
206    (error 'missing-signature-parameter
207           :kind 'ed448
208           :parameter 'r
209           :description "first signature element"))
210  (unless s
211    (error 'missing-signature-parameter
212           :kind 'ed448
213           :parameter 's
214           :description "second signature element"))
215  (concatenate '(simple-array (unsigned-byte 8) (*)) r s))
216
217(defmethod destructure-signature ((kind (eql :ed448)) signature)
218  (let ((length (length signature)))
219    (if (/= length (/ +ed448-bits+ 4))
220        (error 'invalid-signature-length :kind 'ed448)
221        (let* ((middle (/ length 2))
222               (r (subseq signature 0 middle))
223               (s (subseq signature middle)))
224          (list :r r :s s)))))
225
226(defun ed448-sign (m sk pk)
227  (declare (type (simple-array (unsigned-byte 8) (*)) m sk pk)
228           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
229  (let ((h (ed448-hash sk)))
230    (setf (ldb (byte 2 0) (elt h 0)) 0)
231    (setf (ldb (byte 1 7) (elt h (- (ceiling +ed448-bits+ 8) 2))) 1)
232    (setf (elt h (- (ceiling +ed448-bits+ 8) 1)) 0)
233    (let* ((a (ec-decode-scalar :ed448 (subseq h 0 (ceiling +ed448-bits+ 8))))
234           (rh (ed448-hash +ed448-dom+ (subseq h (ceiling +ed448-bits+ 8) (ceiling +ed448-bits+ 4)) m))
235           (ri (mod (ec-decode-scalar :ed448 rh) +ed448-l+))
236           (r (ec-scalar-mult +ed448-b+ ri))
237           (rp (ec-encode-point r))
238           (k (mod (ec-decode-scalar :ed448 (ed448-hash +ed448-dom+ rp pk m)) +ed448-l+))
239           (s (mod (+ (* k a) ri) +ed448-l+)))
240      (make-signature :ed448 :r rp :s (ec-encode-scalar :ed448 s)))))
241
242(defun ed448-verify (s m pk)
243  (declare (type (simple-array (unsigned-byte 8) (*)) s m pk)
244           (optimize (speed 3) (safety 0) (space 0) (debug 0)))
245  (unless (= (length s) (ceiling +ed448-bits+ 4))
246    (error 'invalid-signature-length :kind 'ed448))
247  (unless (= (length pk) (ceiling +ed448-bits+ 8))
248    (error 'invalid-public-key-length :kind 'ed448))
249  (let* ((signature-elements (destructure-signature :ed448 s))
250         (r (getf signature-elements :r))
251         (rp (ec-decode-point :ed448 r))
252         (s (ec-decode-scalar :ed448 (getf signature-elements :s)))
253         (a (ec-decode-point :ed448 pk))
254         (h (mod (ec-decode-scalar :ed448 (ed448-hash +ed448-dom+ r pk m)) +ed448-l+))
255         (res1 (ec-scalar-mult +ed448-b+ s))
256         (res2 (ec-add rp (ec-scalar-mult a h))))
257    (declare (type (simple-array (unsigned-byte 8) (*)) r)
258             (type integer s h)
259             (type ed448-point rp a res1 res2))
260    (and (< s +ed448-l+)
261         (ec-point-equal res1 res2))))
262
263(defmethod make-public-key ((kind (eql :ed448)) &key y &allow-other-keys)
264  (unless y
265    (error 'missing-key-parameter
266           :kind 'ed448
267           :parameter 'y
268           :description "public key"))
269  (make-instance 'ed448-public-key :y y))
270
271(defmethod destructure-public-key ((public-key ed448-public-key))
272  (list :y (ed448-key-y public-key)))
273
274(defmethod make-private-key ((kind (eql :ed448)) &key x y &allow-other-keys)
275  (unless x
276    (error 'missing-key-parameter
277           :kind 'ed448
278           :parameter 'x
279           :description "private key"))
280  (make-instance 'ed448-private-key :x x :y (or y (ed448-public-key x))))
281
282(defmethod destructure-private-key ((private-key ed448-private-key))
283  (list :x (ed448-key-x private-key)
284        :y (ed448-key-y private-key)))
285
286(defmethod sign-message ((key ed448-private-key) message &key (start 0) end &allow-other-keys)
287  (let ((end (or end (length message)))
288        (sk (ed448-key-x key))
289        (pk (ed448-key-y key)))
290    (ed448-sign (subseq message start end) sk pk)))
291
292(defmethod verify-signature ((key ed448-public-key) message signature &key (start 0) end &allow-other-keys)
293  (let ((end (or end (length message)))
294        (pk (ed448-key-y key)))
295    (ed448-verify signature (subseq message start end) pk)))
296
297(defmethod generate-key-pair ((kind (eql :ed448)) &key &allow-other-keys)
298  (let* ((sk (random-data (ceiling +ed448-bits+ 8)))
299         (pk (ed448-public-key sk)))
300    (values (make-private-key :ed448 :x sk :y pk)
301            (make-public-key :ed448 :y pk))))
302