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

Kind	Covered	All	%
expression	0	676	0.0
branch	0	24	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; ed25519.lisp -- implementation of the ed25519 signature algorithm

2

(in-package :crypto)

3

4

;;; class definitions

5

(defclass ed25519-public-key ()

6

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

7

8

(defclass ed25519-private-key ()

9

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

10

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

11

12

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

13

(defclass ed25519-point ()

14

;; Internally, a point (x, y) is represented in extended homogeneous

15

;; coordinates (X, Y, Z, W), with x = X / Z, y = Y / Z and x * y = W / Z.

16

((x :initarg :x :type integer)

17

(y :initarg :y :type integer)

18

(z :initarg :z :type integer)

19

(w :initarg :w :type integer)))

20

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

21

(declare (ignore env))

22

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

23

24

;;; constant, variable and function definitions

25

(defconstant +ed25519-bits+ 256)

26

(defconstant +ed25519-q+ 57896044618658097711785492504343953926634992332820282019728792003956564819949)

27

(defconstant +ed25519-l+ 7237005577332262213973186563042994240857116359379907606001950938285454250989)

28

(defconstant +ed25519-d+ 37095705934669439343138083508754565189542113879843219016388785533085940283555)

29

(defconstant +ed25519-i+ 19681161376707505956807079304988542015446066515923890162744021073123829784752)

30

31

(defconst +ed25519-b+

32

(make-instance 'ed25519-point

33

:x 15112221349535400772501151409588531511454012693041857206046113283949847762202

34

:y 46316835694926478169428394003475163141307993866256225615783033603165251855960

35

:z 1

36

:w 46827403850823179245072216630277197565144205554125654976674165829533817101731))

37

(defconst +ed25519-point-at-infinity+

38

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

39

40

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

41

(expt-mod n (- +ed25519-q+ 2) +ed25519-q+))

42

43

(defun ed25519-recover-x (y)

44

"Recover the X coordinate of a point on ed25519 curve from the Y coordinate."

45

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

46

(type integer y))

47

(let* ((u (mod (1- (* y y)) +ed25519-q+))

48

(v (mod (1+ (* +ed25519-d+ (1+ u))) +ed25519-q+))

49

(v3 (mod (* v v v) +ed25519-q+))

50

(uv3 (mod (* u v3) +ed25519-q+))

51

(uv7 (mod (* uv3 v3 v) +ed25519-q+))

52

(x (mod (* uv3 (expt-mod uv7 (/ (- +ed25519-q+ 5) 8) +ed25519-q+)) +ed25519-q+)))

53

(declare (type integer u v v3 uv3 uv7 x))

54

(unless (= u (mod (* v x x) +ed25519-q+))

55

(setf x (mod (* x +ed25519-i+) +ed25519-q+)))

56

(unless (evenp x)

57

(setf x (- +ed25519-q+ x)))

58

x))

59

60

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

61

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

62

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

63

(declare (type integer x1 y1 z1 w1))

64

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

65

(declare (type integer x2 y2 z2 w2))

66

(let* ((a (mod (* (- y1 x1) (- y2 x2)) +ed25519-q+))

67

(b (mod (* (+ y1 x1) (+ y2 x2)) +ed25519-q+))

68

(i (mod (* w1 w2) +ed25519-q+))

69

(c (mod (* 2 i +ed25519-d+) +ed25519-q+))

70

(d (mod (* 2 z1 z2) +ed25519-q+))

71

(e (mod (- b a) +ed25519-q+))

72

(f (mod (- d c) +ed25519-q+))

73

(g (mod (+ d c) +ed25519-q+))

74

(h (mod (+ b a) +ed25519-q+))

75

(x3 (mod (* e f) +ed25519-q+))

76

(y3 (mod (* g h) +ed25519-q+))

77

(z3 (mod (* f g) +ed25519-q+))

78

(w3 (mod (* e h) +ed25519-q+)))

79

(declare (type integer a b c d e f g h i x3 y3 z3 w3))

80

(make-instance 'ed25519-point :x x3 :y y3 :z z3 :w w3)))))

81

82

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

83

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

84

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

85

(declare (type integer x1 y1 z1))

86

(let* ((a (mod (* x1 x1) +ed25519-q+))

87

(b (mod (* y1 y1) +ed25519-q+))

88

(c (mod (* 2 z1 z1) +ed25519-q+))

89

(d (mod (+ x1 y1) +ed25519-q+))

90

(i (mod (* d d) +ed25519-q+))

91

(h (mod (+ a b) +ed25519-q+))

92

(e (mod (- h i) +ed25519-q+))

93

(g (mod (- a b) +ed25519-q+))

94

(f (mod (+ c g) +ed25519-q+))

95

(x2 (mod (* e f) +ed25519-q+))

96

(y2 (mod (* g h) +ed25519-q+))

97

(z2 (mod (* f g) +ed25519-q+))

98

(w2 (mod (* e h) +ed25519-q+)))

99

(declare (type integer a b c d e f g h i x2 y2 z2 w2))

100

(make-instance 'ed25519-point :x x2 :y y2 :z z2 :w w2))))

101

102

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

103

;; Point multiplication on ed25519 curve using the Montgomery ladder.

104

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

105

(type integer e))

106

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

107

(r1 p)

108

(i 254 (1- i)))

109

((minusp i) r0)

110

(declare (type ed25519-point r0 r1)

111

(type fixnum i))

112

(if (logbitp i e)

113

(setf r0 (ec-add r0 r1)

114

r1 (ec-double r1))

115

(setf r1 (ec-add r0 r1)

116

r0 (ec-double r0)))))

117

118

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

119

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

120

(with-slots (x y z w) p

121

(declare (type integer x y z w))

122

(let* ((xx (mod (* x x) +ed25519-q+))

123

(yy (mod (* y y) +ed25519-q+))

124

(zz (mod (* z z) +ed25519-q+))

125

(ww (mod (* w w) +ed25519-q+))

126

(a (mod (- yy xx) +ed25519-q+))

127

(b (mod (+ zz (* +ed25519-d+ ww)) +ed25519-q+)))

128

(declare (type integer xx yy zz ww a b))

129

(zerop (mod (- a b) +ed25519-q+)))))

130

131

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

132

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

133

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

134

(declare (type integer x1 y1 z1))

135

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

136

(declare (type integer x2 y2 z2))

137

(and (zerop (mod (- (* x1 z2) (* x2 z1)) +ed25519-q+))

138

(zerop (mod (- (* y1 z2) (* y2 z1)) +ed25519-q+))))))

139

140

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

141

(unless x

142

(error 'missing-point-parameter

143

:kind 'ed25519

144

:parameter 'x

145

:description "coordinate"))

146

(unless y

147

(error 'missing-point-parameter

148

:kind 'ed25519

149

:parameter 'y

150

:description "coordinate"))

151

(let* ((w (mod (* x y) +ed25519-q+))

152

(p (make-instance 'ed25519-point :x x :y y :z 1 :w w)))

153

(declare (type integer w)

154

(type ed25519-point p))

155

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

156

p

157

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

158

159

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

160

(with-slots (x y z) p

161

(declare (type integer x y z))

162

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

163

(x (mod (* x invz) +ed25519-q+))

164

(y (mod (* y invz) +ed25519-q+)))

165

(declare (type integer x y invz))

166

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

167

168

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

169

(integer-to-octets n :n-bits +ed25519-bits+ :big-endian nil))

170

171

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

172

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

173

174

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

175

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

176

(x (getf coordinates :x))

177

(y (getf coordinates :y)))

178

(declare (type integer x y))

179

(setf (ldb (byte 1 (- +ed25519-bits+ 1)) y) (ldb (byte 1 0) x))

180

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

181

182

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

183

(let* ((y (ec-decode-scalar :ed25519 octets))

184

(b (ldb (byte 1 (- +ed25519-bits+ 1)) y)))

185

(declare (type integer y)

186

(type fixnum b))

187

(setf (ldb (byte 1 (- +ed25519-bits+ 1)) y) 0)

188

(let ((x (ed25519-recover-x y)))

189

(declare (type integer x))

190

(unless (= (ldb (byte 1 0) x) b)

191

(setf x (- +ed25519-q+ x)))

192

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

193

194

(defun ed25519-hash (&rest messages)

195

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

196

(let ((digest (make-digest :sha512)))

197

(dolist (m messages)

198

(update-digest digest m))

199

(produce-digest digest)))

200

201

(defun ed25519-public-key (sk)

202

"Compute the public key associated to the private key SK."

203

(declare (type (simple-array (unsigned-byte 8) (*)) sk)

204

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

205

(let ((h (ed25519-hash sk)))

206

(setf h (subseq h 0 (/ +ed25519-bits+ 8)))

207

(setf (ldb (byte 3 0) (elt h 0)) 0)

208

(setf (ldb (byte 2 6) (elt h (- (/ +ed25519-bits+ 8) 1))) 1)

209

(let ((a (ec-decode-scalar :ed25519 h)))

210

(ec-encode-point (ec-scalar-mult +ed25519-b+ a)))))

211

212

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

213

(unless r

214

(error 'missing-signature-parameter

215

:kind 'ed25519

216

:parameter 'r

217

:description "first signature element"))

218

(unless s

219

(error 'missing-signature-parameter

220

:kind 'ed25519

221

:parameter 's

222

:description "second signature element"))

223

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

224

225

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

226

(let ((length (length signature)))

227

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

228

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

229

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

230

(r (subseq signature 0 middle))

231

(s (subseq signature middle)))

232

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

233

234

(defun ed25519-sign (m sk pk)

235

(declare (type (simple-array (unsigned-byte 8) (*)) m sk pk)

236

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

237

(let ((h (ed25519-hash sk)))

238

(setf (ldb (byte 3 0) (elt h 0)) 0)

239

(setf (ldb (byte 2 6) (elt h (- (/ +ed25519-bits+ 8) 1))) 1)

240

(let* ((a (ec-decode-scalar :ed25519 (subseq h 0 (/ +ed25519-bits+ 8))))

241

(rh (ed25519-hash (subseq h (/ +ed25519-bits+ 8) (/ +ed25519-bits+ 4)) m))

242

(ri (mod (ec-decode-scalar :ed25519 rh) +ed25519-l+))

243

(r (ec-scalar-mult +ed25519-b+ ri))

244

(rp (ec-encode-point r))

245

(k (mod (ec-decode-scalar :ed25519 (ed25519-hash rp pk m)) +ed25519-l+))

246

(s (mod (+ (* k a) ri) +ed25519-l+)))

247

(declare (type integer a ri k s)

248

(type (simple-array (unsigned-byte 8) (*)) rh)

249

(type ed25519-point r))

250

(make-signature :ed25519 :r rp :s (ec-encode-scalar :ed25519 s)))))

251

252

(defun ed25519-verify (s m pk)

253

(declare (type (simple-array (unsigned-byte 8) (*)) s m pk)

254

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

255

(unless (= (length s) (/ +ed25519-bits+ 4))

256

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

257

(unless (= (length pk) (/ +ed25519-bits+ 8))

258

(error 'invalid-public-key-length :kind 'ed25519))

259

(let* ((signature-elements (destructure-signature :ed25519 s))

260

(r (getf signature-elements :r))

261

(rp (ec-decode-point :ed25519 r))

262

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

263

(a (ec-decode-point :ed25519 pk))

264

(h (mod (ec-decode-scalar :ed25519 (ed25519-hash r pk m)) +ed25519-l+))

265

(res1 (ec-scalar-mult +ed25519-b+ s))

266

(res2 (ec-add rp (ec-scalar-mult a h))))

267

(declare (type (simple-array (unsigned-byte 8) (*)) r)

268

(type integer s h)

269

(type ed25519-point rp a res1 res2))

270

(and (< s +ed25519-l+)

271

(ec-point-equal res1 res2))))

272

273

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

274

(unless y

275

(error 'missing-key-parameter

276

:kind 'ed25519

277

:parameter 'y

278

:description "public key"))

279

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

280

281

(defmethod destructure-public-key ((public-key ed25519-public-key))

282

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

283

284

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

285

(unless x

286

(error 'missing-key-parameter

287

:kind 'ed25519

288

:parameter 'x

289

:description "private key"))

290

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

291

292

(defmethod destructure-private-key ((private-key ed25519-private-key))

293

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

294

:y (ed25519-key-y private-key)))

295

296

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

297

(let ((end (or end (length message)))

298

(sk (ed25519-key-x key))

299

(pk (ed25519-key-y key)))

300

(ed25519-sign (subseq message start end) sk pk)))

301

302

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

303

(let ((end (or end (length message)))

304

(pk (ed25519-key-y key)))

305

(ed25519-verify signature (subseq message start end) pk)))

306

307

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

308

(let* ((sk (random-data (/ +ed25519-bits+ 8)))

309

(pk (ed25519-public-key sk)))

310

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

311

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