Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/rsa.lisp

Kind	Covered	All	%
expression	0	445	0.0
branch	0	30	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;

2

;; rsa.lisp - THe RSA Encryption Algorithm in Common Lisp

3

;;

4

;;

5

;; adapted from git@github.com:burtonsamograd/rsa.git

6

;; - operate on just the data without respect to key owner

7

;; - presume everything is loaded via system build

8

(in-package :spocq.i)

9

10

(defconstant +E+ 17)

11

12

(defun expt-mod (n exponent modulus)

13

"As (mod (expt n exponent) modulus), but more efficient. From Cliki"

14

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

15

(integer n exponent modulus)

16

(sb-ext:muffle-conditions sb-ext:compiler-note)) ; too many optimization notes here

17

(loop with result = 1

18

for i of-type fixnum from 0 below (integer-length exponent)

19

for sqr = n then (mod (* sqr sqr) modulus)

20

when (logbitp i exponent) do

21

(setf result (mod (* result sqr) modulus))

22

finally (return result)))

23

24

(defun is-prime (n k)

25

"Miller Rabin primailty test implemented using the algorithm from

26

http://en.wikipedia.org/wiki/Miller%E2%80%93Rabin_primality_test"

27

(let* ((n-1 (1- n))

28

(n-4 (- n 4))

29

(s 0) d

30

(tmp n-1))

31

;; write n − 1 as 2s·d with d odd by factoring powers of 2 from n − 1

32

(loop

33

(multiple-value-bind (q r)

34

(floor tmp 2)

35

(if (= r 0)

36

(progn

37

(setf tmp q)

38

(incf s))

39

(progn

40

(setf d tmp)

41

(return)))))

42

;(format t "s: ~A d: ~A~%" s d)

43

(dotimes (i k)

44

(let* ((a (+ 2 (random n-4)))

45

(x (expt-mod a d n)))

46

;(format t "a: ~A~%" a)

47

;(format t "x: ~A~%" x)

48

(when (or (= x 1) (= x n-1))

49

(go end))

50

(dotimes (r s)

51

(setf x (expt-mod x 2 n))

52

;(format t "*x: ~A~%" x)

53

(when (= x 1)

54

(return-from is-prime nil))

55

(when (= x n-1)

56

(go end)))

57

(return-from is-prime nil))

58

end))

59

t)

60

61

(defun gen-prime (&optional (num-bits 1024) (strength 128))

62

"generate a probably random prime number of the given number of bits

63

using strength iterations to verify primality using the miller-rabin

64

primality test"

65

(let ((ndigits (/ num-bits 4))

66

(nstr (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))

67

(*print-base* 16))

68

(with-output-to-string (s nstr)

69

(let ((first-digit (random 16)))

70

;; ensure the 2 highest bits are set on first digit

71

(setf first-digit (logior first-digit 12))

72

(format s "~A" first-digit))

73

;; generate the rest of the digits

74

(dotimes (i (- ndigits 2))

75

(format s "~A" (random 16)))

76

;; ensure number is odd

77

(format s "~A" (logior (random 16) 1)))

78

(let ((n (parse-integer nstr :radix 16)))

79

(declare (integer n))

80

(loop

81

(if (and (/= (mod n +E+) 1)

82

(is-prime n strength))

83

(return-from gen-prime n)

84

(incf n 2))))))

85

86

(defun modular-inverse (u v)

87

"compute the multiplicative inverse of u modulo v, u-1 (mod v), and

88

returns either the inverse as a positive integer less than v, or zero

89

if no inverse exists."

90

(let ((u1 1)

91

(u3 u)

92

(v1 0)

93

(v3 v)

94

(iter 1))

95

(loop

96

(when (= v3 0) (return))

97

(let* ((q (floor u3 v3))

98

(t3 (mod u3 v3))

99

(t1 (+ u1 (* q v1))))

100

(setf u1 v1

101

v1 t1

102

u3 v3

103

v3 t3

104

iter (* iter -1))))

105

(when (/= u3 1)

106

(return-from modular-inverse 0))

107

(when (< iter 0)

108

(return-from modular-inverse (- v u1)))

109

(return-from modular-inverse u1)))

110

111

(defun octets-to-integer (octet-vec &key (start 0) end (big-endian t) n-bits)

112

(declare (type (simple-array (unsigned-byte 8) (*)) octet-vec))

113

(let ((end (or end (length octet-vec))))

114

(multiple-value-bind (complete-bytes extra-bits)

115

(if n-bits

116

(truncate n-bits 8)

117

(values (- end start) 0))

118

(declare (ignorable complete-bytes extra-bits))

119

(if big-endian

120

(do ((j start (1+ j))

121

(sum 0))

122

((>= j end) sum)

123

(setf sum (+ (aref octet-vec j) (ash sum 8))))

124

(loop for i from (- end start 1) downto 0

125

for j from (1- end) downto start

126

sum (ash (aref octet-vec j) (* i 8)))))))

127

128

(defun integer-to-octets (bignum &key (n-bits (integer-length bignum))

129

(big-endian t))

130

(let* ((n-bytes (ceiling n-bits 8))

131

(octet-vec (make-array n-bytes :element-type '(unsigned-byte 8))))

132

(declare (type (simple-array (unsigned-byte 8) (*)) octet-vec))

133

(if big-endian

134

(loop for i from (1- n-bytes) downto 0

135

for index from 0

136

do (setf (aref octet-vec index) (ldb (byte 8 (* i 8)) bignum))

137

finally (return octet-vec))

138

(loop for i from 0 below n-bytes

139

for byte from 0 by 8

140

do (setf (aref octet-vec i) (ldb (byte 8 byte) bignum))

141

finally (return octet-vec)))))

142

143

(defmacro sha256 (msg)

144

`(ironclad:digest-sequence :sha256 ,msg))

145

(defmacro base64enc (string)

146

`(base64:string-to-base64-string ,string))

147

(defmacro base64dec (base64-string)

148

`(base64:base64-string-to-string ,base64-string))

149

150

(defstruct rsa-key

151

name name-base64 length n e d)

152

153

(defvar *rsa-key-db* (make-hash-table :test #'equal))

154

155

(defun rsa-gen-key (name &optional (length 2048))

156

"generate n, e and d for use with make-rsa-keys"

157

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

158

(p (gen-prime length/2))

159

(q (gen-prime length/2))

160

(n (* p q))

161

(phi (* (1- p) (1- q)))

162

(d (modular-inverse +E+ phi))

163

(base64-name (base64enc name)))

164

(setf (gethash base64-name *rsa-key-db*)

165

             (make-rsa-key :name name :name-base64 base64-name :length length :n n :e +E+ :d d))))

166

167

(defun rsa-save-key (key filename)

168

(with-open-file (s filename :direction :output)

169

(format s "~S" key)))

170

171

(defun rsa-load-key (filename)

172

(with-open-file (s filename)

173

(let ((key (read s)))

174

(setf (gethash (rsa-key-name-base64 key) *rsa-key-db*) key))))

175

176

(defun rsa-list-keys ()

177

(maphash (lambda (key value)

178

(declare (ignore key))

179

(format t

180

"Name: ~A~%Name (Base64): ~A~%Length: ~A~%~%"

181

(rsa-key-name value)

182

(rsa-key-name-base64 value)

183

(rsa-key-length value)))

184

*rsa-key-db*))

185

186

(defun rsa-find-key (name)

187

(maphash (lambda (key value)

188

(declare (ignore key))

189

(when (string= name (rsa-key-name value))

190

(return-from rsa-find-key value)))

191

*rsa-key-db*))

192

193

(defconstant rsa-num-random-padding-bytes 16)

194

195

(defun rsa-encrypt-text (rsa-key msg)

196

(when (> (+ (length msg) 2)

197

(/ (rsa-key-length rsa-key) 8))

198

(error "rsa-encrypt-text: message to is too long to encrypt with given key length"))

199

(let* ((n (rsa-key-n rsa-key))

200

(e (rsa-key-e rsa-key))

201

(d (rsa-key-d rsa-key))

202

(random-bytes (let (x)

203

(dotimes (i rsa-num-random-padding-bytes)

204

(push (random 256) x))

205

(coerce x '(simple-array (unsigned-byte 8) (*)))))

206

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

207

random-bytes

208

(sb-ext:string-to-octets (base64enc msg))))

209

(sig (integer-to-octets

210

(expt-mod (octets-to-integer (sha256 msg-octets)) d n))) ; s = m^d mod n.

211

msg-length msg-length-octets)

212

(setf msg-octets (integer-to-octets (expt-mod (octets-to-integer msg-octets) e n)))

213

(setf msg-length (length msg-octets))

214

(setf msg-length-octets (integer-to-octets msg-length))

215

(if (= (length msg-length-octets) 1) ; make msg length 2 bytes

216

(setf msg-length-octets (concatenate '(simple-array (unsigned-byte 8) (*))

217

#(0) msg-length-octets)))

218

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

219

msg-length-octets

220

msg-octets

221

sig)))

222

223

(defun rsa-decrypt-text (rsa-key msg+sig)

224

(let* ((n (rsa-key-n rsa-key))

225

(d (rsa-key-d rsa-key))

226

(msg-len (octets-to-integer (subseq msg+sig 0 2)))

227

(msg (sb-ext:octets-to-string

228

(subseq (integer-to-octets

229

                         (expt-mod (octets-to-integer (subseq msg+sig 2 (+ 2 msg-len))) d n))

230

rsa-num-random-padding-bytes)))

231

(msg-text (base64dec msg)))

232

msg-text))

233

234

;;; the authentication information is not that of the request agent, but that which

235

;;; belongs to a user with the name of the request url authority.

236

;;; if an auth token is present it is decrypted and used, otherwise,

237

;;; the password is retrieved, decrypted and added to the url

238

239

(defun decrypt-character-data (data)

240

(assert (evenp (length data)) () "Invalid encrypted authentication data: ~a" (type-of data))

241

(let ((data-bytes (make-array (/ (length data) 2) :element-type '(unsigned-byte 8))))

242

(loop for from from 0 by 2 for to from 0 below (length data-bytes)

243

do (setf (aref data-bytes to) (parse-integer data :start from :end (+ from 2) :radix 16)))

244

(rsa-decrypt-text *authentication-data-key* data-bytes)))

245

(defun decrypt-authentication-data (data) (decrypt-character-data data))

246

247

(defun encrypt-character-data (data)

248

(with-output-to-string (stream)

249

(loop for byte across (rsa-encrypt-text *authentication-data-key* data)

250

do (format stream "~2,'0x" byte))))

251

(defun encrypt-authentication-data (data) (encrypt-character-data data))

252

253

#|

254

(defparameter *k* (rsa-gen-key "test"))

255

(rsa-encrypt-text *k* "this is a test")

256

(rsa-decrypt-text *k* *)

257

|#

258

��