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