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