Coverage report: /home/ellis/comp/ext/ironclad/src/public-key/secp384r1.lisp

Kind	Covered	All	%
expression	0	751	0.0
branch	0	38	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; secp384r1.lisp -- secp384r1 (a.k.a. NIST P-384) elliptic curve

2

3

(in-package :crypto)

4

5

;;; class definitions

6

(defclass secp384r1-public-key ()

7

((y :initarg :y :reader secp384r1-key-y :type (simple-array (unsigned-byte 8) (*)))))

8

9

(defclass secp384r1-private-key ()

10

((x :initarg :x :reader secp384r1-key-x :type (simple-array (unsigned-byte 8) (*)))

11

(y :initarg :y :reader secp384r1-key-y :type (simple-array (unsigned-byte 8) (*)))))

12

13

(eval-when (:compile-toplevel :load-toplevel :execute)

14

(defclass secp384r1-point ()

15

;; Internally, a point (x, y) is represented using the Jacobian projective

16

;; coordinates (X, Y, Z), with x = X / Z^2 and y = Y / Z^3.

17

((x :initarg :x :type integer)

18

(y :initarg :y :type integer)

19

(z :initarg :z :type integer)))

20

(defmethod make-load-form ((p secp384r1-point) &optional env)

21

(declare (ignore env))

22

(make-load-form-saving-slots p)))

23

24

;;; constant and function definitions

25

(defconstant +secp384r1-bits+ 384)

26

 (defconstant +secp384r1-p+ 39402006196394479212279040100143613805079739270465446667948293404245721771496870329047266088258938001861606973112319)

27

 (defconstant +secp384r1-b+ 27580193559959705877849011840389048093056905856361568521428707301988689241309860865136260764883745107765439761230575)

28

 (defconstant +secp384r1-l+ 39402006196394479212279040100143613805079739270465446667946905279627659399113263569398956308152294913554433653942643)

29

 (defconstant +secp384r1-i+ 29551504647295859409209280075107710353809804452849085000961220053184291328622652746785449566194203501396205229834239)

30

31

(defconst +secp384r1-g+

32

(make-instance 'secp384r1-point

33

     :x 26247035095799689268623156744566981891852923491109213387815615900925518854738050089022388053975719786650872476732087

34

     :y 8325710961489029985546751289520108179287853048861315594709205902480503199884419224438643760392947333078086511627871

35

:z 1))

36

(defconst +secp384r1-point-at-infinity+

37

(make-instance 'secp384r1-point :x 1 :y 1 :z 0))

38

39

(defmethod ec-scalar-inv ((kind (eql :secp384r1)) n)

40

(expt-mod n (- +secp384r1-p+ 2) +secp384r1-p+))

41

42

(defmethod ec-point-equal ((p secp384r1-point) (q secp384r1-point))

43

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))

44

(with-slots ((x1 x) (y1 y) (z1 z)) p

45

(declare (type integer x1 y1 z1))

46

(with-slots ((x2 x) (y2 y) (z2 z)) q

47

(declare (type integer x2 y2 z2))

48

(let ((z1z1 (mod (* z1 z1) +secp384r1-p+))

49

(z2z2 (mod (* z2 z2) +secp384r1-p+)))

50

(and (zerop (mod (- (* x1 z2z2) (* x2 z1z1)) +secp384r1-p+))

51

(zerop (mod (- (* y1 z2z2 z2) (* y2 z1z1 z1)) +secp384r1-p+)))))))

52

53

(defmethod ec-double ((p secp384r1-point))

54

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))

55

(with-slots ((x1 x) (y1 y) (z1 z)) p

56

(declare (type integer x1 y1 z1))

57

(if (zerop z1)

58

+secp384r1-point-at-infinity+

59

(let* ((xx (mod (* x1 x1) +secp384r1-p+))

60

(yy (mod (* y1 y1) +secp384r1-p+))

61

(yyyy (mod (* yy yy) +secp384r1-p+))

62

(zz (mod (* z1 z1) +secp384r1-p+))

63

(x1+yy (mod (+ x1 yy) +secp384r1-p+))

64

(y1+z1 (mod (+ y1 z1) +secp384r1-p+))

65

(s (mod (* 2 (- (* x1+yy x1+yy) xx yyyy)) +secp384r1-p+))

66

(m (mod (* 3 (- xx (* zz zz))) +secp384r1-p+))

67

(u (mod (- (* m m) (* 2 s)) +secp384r1-p+))

68

(x2 u)

69

(y2 (mod (- (* m (- s u)) (* 8 yyyy)) +secp384r1-p+))

70

(z2 (mod (- (* y1+z1 y1+z1) yy zz) +secp384r1-p+)))

71

(make-instance 'secp384r1-point :x x2 :y y2 :z z2)))))

72

73

(defmethod ec-add ((p secp384r1-point) (q secp384r1-point))

74

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))

75

(with-slots ((x1 x) (y1 y) (z1 z)) p

76

(declare (type integer x1 y1 z1))

77

(with-slots ((x2 x) (y2 y) (z2 z)) q

78

(declare (type integer x2 y2 z2))

79

(cond

80

((zerop z1)

81

q)

82

((zerop z2)

83

p)

84

(t

85

(let* ((z1z1 (mod (* z1 z1) +secp384r1-p+))

86

(z2z2 (mod (* z2 z2) +secp384r1-p+))

87

(u1 (mod (* x1 z2z2) +secp384r1-p+))

88

(u2 (mod (* x2 z1z1) +secp384r1-p+))

89

(s1 (mod (* y1 z2 z2z2) +secp384r1-p+))

90

(s2 (mod (* y2 z1 z1z1) +secp384r1-p+)))

91

(if (= u1 u2)

92

(if (= s1 s2)

93

(ec-double p)

94

+secp384r1-point-at-infinity+)

95

(let* ((h (mod (- u2 u1) +secp384r1-p+))

96

(i (mod (* 4 h h) +secp384r1-p+))

97

(j (mod (* h i) +secp384r1-p+))

98

(r (mod (* 2 (- s2 s1)) +secp384r1-p+))

99

(v (mod (* u1 i) +secp384r1-p+))

100

(x3 (mod (- (* r r) j (* 2 v)) +secp384r1-p+))

101

(y3 (mod (- (* r (- v x3)) (* 2 s1 j)) +secp384r1-p+))

102

(z1+z2 (mod (+ z1 z2) +secp384r1-p+))

103

(z3 (mod (* (- (* z1+z2 z1+z2) z1z1 z2z2) h) +secp384r1-p+)))

104

(make-instance 'secp384r1-point :x x3 :y y3 :z z3)))))))))

105

106

(defmethod ec-scalar-mult ((p secp384r1-point) e)

107

;; Point multiplication on NIST P-384 curve using the Montgomery ladder.

108

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0))

109

(type integer e))

110

(do ((r0 +secp384r1-point-at-infinity+)

111

(r1 p)

112

(i (1- +secp384r1-bits+) (1- i)))

113

((minusp i) r0)

114

(declare (type secp384r1-point r0 r1)

115

(type fixnum i))

116

(if (logbitp i e)

117

(setf r0 (ec-add r0 r1)

118

r1 (ec-double r1))

119

(setf r1 (ec-add r0 r1)

120

r0 (ec-double r0)))))

121

122

(defmethod ec-point-on-curve-p ((p secp384r1-point))

123

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))

124

(with-slots (x y z) p

125

(declare (type integer x y z))

126

(let* ((y2 (mod (* y y) +secp384r1-p+))

127

(x3 (mod (* x x x) +secp384r1-p+))

128

(z2 (mod (* z z) +secp384r1-p+))

129

(z4 (mod (* z2 z2) +secp384r1-p+))

130

(z6 (mod (* z4 z2) +secp384r1-p+))

131

(a (mod (+ x3 (* -3 x z4) (* +secp384r1-b+ z6)) +secp384r1-p+)))

132

(declare (type integer y2 x3 z2 z4 z6 a))

133

(zerop (mod (- y2 a) +secp384r1-p+)))))

134

135

(defmethod ec-make-point ((kind (eql :secp384r1)) &key x y)

136

(unless x

137

(error 'missing-point-parameter

138

:kind 'secp384r1

139

:parameter 'x

140

:description "coordinate"))

141

(unless y

142

(error 'missing-point-parameter

143

:kind 'secp384r1

144

:parameter 'y

145

:description "coordinate"))

146

(let ((p (make-instance 'secp384r1-point :x x :y y :z 1)))

147

(if (ec-point-on-curve-p p)

148

p

149

(error 'invalid-curve-point :kind 'secp384r1))))

150

151

(defmethod ec-destructure-point ((p secp384r1-point))

152

(with-slots (x y z) p

153

(declare (type integer x y z))

154

(when (zerop z)

155

(error 'ironclad-error

156

:format-control "The point at infinity can't be encoded."))

157

(let* ((invz (ec-scalar-inv :secp384r1 z))

158

(invz2 (mod (* invz invz) +secp384r1-p+))

159

(invz3 (mod (* invz2 invz) +secp384r1-p+))

160

(x (mod (* x invz2) +secp384r1-p+))

161

(y (mod (* y invz3) +secp384r1-p+)))

162

(list :x x :y y))))

163

164

(defmethod ec-encode-scalar ((kind (eql :secp384r1)) n)

165

(integer-to-octets n :n-bits +secp384r1-bits+ :big-endian t))

166

167

(defmethod ec-decode-scalar ((kind (eql :secp384r1)) octets)

168

(octets-to-integer octets :big-endian t))

169

170

(defmethod ec-encode-point ((p secp384r1-point))

171

(let* ((coordinates (ec-destructure-point p))

172

(x (getf coordinates :x))

173

(y (getf coordinates :y)))

174

(concatenate '(simple-array (unsigned-byte 8) (*))

175

(vector 4)

176

(ec-encode-scalar :secp384r1 x)

177

(ec-encode-scalar :secp384r1 y))))

178

179

(defmethod ec-decode-point ((kind (eql :secp384r1)) octets)

180

(case (aref octets 0)

181

((2 3)

182

;; Compressed point

183

(if (= (length octets) (1+ (/ +secp384r1-bits+ 8)))

184

(let* ((x-bytes (subseq octets 1 (1+ (/ +secp384r1-bits+ 8))))

185

(x (ec-decode-scalar :secp384r1 x-bytes))

186

(y-sign (- (aref octets 0) 2))

187

(y2 (mod (+ (* x x x) (* -3 x) +secp384r1-b+) +secp384r1-p+))

188

(y (expt-mod y2 +secp384r1-i+ +secp384r1-p+))

189

(y (if (= (logand y 1) y-sign) y (- +secp384r1-p+ y))))

190

(ec-make-point :secp384r1 :x x :y y))

191

(error 'invalid-curve-point :kind 'secp384r1)))

192

((4)

193

;; Uncompressed point

194

(if (= (length octets) (1+ (/ +secp384r1-bits+ 4)))

195

(let* ((x-bytes (subseq octets 1 (1+ (/ +secp384r1-bits+ 8))))

196

(x (ec-decode-scalar :secp384r1 x-bytes))

197

(y-bytes (subseq octets (1+ (/ +secp384r1-bits+ 8))))

198

(y (ec-decode-scalar :secp384r1 y-bytes)))

199

(ec-make-point :secp384r1 :x x :y y))

200

(error 'invalid-curve-point :kind 'secp384r1)))

201

(t

202

(error 'invalid-curve-point :kind 'secp384r1))))

203

204

(defun secp384r1-public-key (sk)

205

(let ((a (ec-decode-scalar :secp384r1 sk)))

206

(ec-encode-point (ec-scalar-mult +secp384r1-g+ a))))

207

208

(defmethod make-signature ((kind (eql :secp384r1)) &key r s &allow-other-keys)

209

(unless r

210

(error 'missing-signature-parameter

211

:kind 'secp384r1

212

:parameter 'r

213

:description "first signature element"))

214

(unless s

215

(error 'missing-signature-parameter

216

:kind 'secp384r1

217

:parameter 's

218

:description "second signature element"))

219

(concatenate '(simple-array (unsigned-byte 8) (*)) r s))

220

221

(defmethod destructure-signature ((kind (eql :secp384r1)) signature)

222

(let ((length (length signature)))

223

(if (/= length (/ +secp384r1-bits+ 4))

224

(error 'invalid-signature-length :kind 'secp384r1)

225

(let* ((middle (/ length 2))

226

(r (subseq signature 0 middle))

227

(s (subseq signature middle)))

228

(list :r r :s s)))))

229

230

(defmethod generate-signature-nonce ((key secp384r1-private-key) message &optional parameters)

231

(declare (ignore key message parameters))

232

(or *signature-nonce-for-test*

233

(1+ (strong-random (1- +secp384r1-l+)))))

234

235

;;; Note that hashing is not performed here.

236

(defmethod sign-message ((key secp384r1-private-key) message &key (start 0) end &allow-other-keys)

237

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))

238

(let* ((end (min (or end (length message)) (/ +secp384r1-bits+ 8)))

239

(sk (ec-decode-scalar :secp384r1 (secp384r1-key-x key)))

240

(k (generate-signature-nonce key message))

241

(invk (modular-inverse-with-blinding k +secp384r1-l+))

242

(r (ec-scalar-mult +secp384r1-g+ k))

243

(x (subseq (ec-encode-point r) 1 (1+ (/ +secp384r1-bits+ 8))))

244

(r (ec-decode-scalar :secp384r1 x))

245

(r (mod r +secp384r1-l+))

246

(h (subseq message start end))

247

(e (ec-decode-scalar :secp384r1 h))

248

(s (mod (* invk (+ e (* sk r))) +secp384r1-l+)))

249

(if (not (or (zerop r) (zerop s)))

250

(make-signature :secp384r1

251

:r (ec-encode-scalar :secp384r1 r)

252

:s (ec-encode-scalar :secp384r1 s))

253

(sign-message key message :start start :end end))))

254

255

 (defmethod verify-signature ((key secp384r1-public-key) message signature &key (start 0) end &allow-other-keys)

256

(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))

257

(unless (= (length signature) (/ +secp384r1-bits+ 4))

258

(error 'invalid-signature-length :kind 'secp384r1))

259

(let* ((end (min (or end (length message)) (/ +secp384r1-bits+ 8)))

260

(pk (ec-decode-point :secp384r1 (secp384r1-key-y key)))

261

(signature-elements (destructure-signature :secp384r1 signature))

262

(r (ec-decode-scalar :secp384r1 (getf signature-elements :r)))

263

(s (ec-decode-scalar :secp384r1 (getf signature-elements :s)))

264

(h (subseq message start end))

265

(e (ec-decode-scalar :secp384r1 h))

266

(w (modular-inverse-with-blinding s +secp384r1-l+))

267

(u1 (mod (* e w) +secp384r1-l+))

268

(u2 (mod (* r w) +secp384r1-l+))

269

(rp (ec-add (ec-scalar-mult +secp384r1-g+ u1)

270

(ec-scalar-mult pk u2)))

271

(x (subseq (ec-encode-point rp) 1 (1+ (/ +secp384r1-bits+ 8))))

272

(v (ec-decode-scalar :secp384r1 x))

273

(v (mod v +secp384r1-l+)))

274

(and (< r +secp384r1-l+)

275

(< s +secp384r1-l+)

276

(= v r))))

277

278

(defmethod make-public-key ((kind (eql :secp384r1)) &key y &allow-other-keys)

279

(unless y

280

(error 'missing-key-parameter

281

:kind 'secp384r1

282

:parameter 'y

283

:description "public key"))

284

(make-instance 'secp384r1-public-key :y y))

285

286

(defmethod destructure-public-key ((public-key secp384r1-public-key))

287

(list :y (secp384r1-key-y public-key)))

288

289

(defmethod make-private-key ((kind (eql :secp384r1)) &key x y &allow-other-keys)

290

(unless x

291

(error 'missing-key-parameter

292

:kind 'secp384r1

293

:parameter 'x

294

:description "private key"))

295

(make-instance 'secp384r1-private-key :x x :y (or y (secp384r1-public-key x))))

296

297

(defmethod destructure-private-key ((private-key secp384r1-private-key))

298

(list :x (secp384r1-key-x private-key)

299

:y (secp384r1-key-y private-key)))

300

301

(defmethod generate-key-pair ((kind (eql :secp384r1)) &key &allow-other-keys)

302

(let* ((sk (ec-encode-scalar :secp384r1 (1+ (strong-random (1- +secp384r1-l+)))))

303

(pk (secp384r1-public-key sk)))

304

(values (make-private-key :secp384r1 :x sk :y pk)

305

(make-public-key :secp384r1 :y pk))))

306

307

(defmethod diffie-hellman ((private-key secp384r1-private-key) (public-key secp384r1-public-key))

308

(let ((s (ec-decode-scalar :secp384r1 (secp384r1-key-x private-key)))

309

(p (ec-decode-point :secp384r1 (secp384r1-key-y public-key))))

310

(ec-encode-point (ec-scalar-mult p s))))