Coverage report: /home/ellis/comp/ext/ironclad/src/digests/sha1.lisp

Kind	Covered	All	%
expression	1	147	0.7
branch	0	4	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; This is an implementation of the US Secure Hash Algorithm 1 (SHA1),

2

;;;; defined in RFC 3174, written by D. Eastlake and P. Jones, September

3

;;;; 2001. The RFC was based on the document "Secure Hash Standard",

4

;;;; United States of America, National Institute of Science and Technology,

5

;;;; Federal Information Processing Standard (FIPS) 180-1, April 1993.

6

;;;;

7

;;;; It was written by Nathan J. Froyd, with many of the main ideas and

8

;;;; functions grabbed from Pierre R. Mai's CL implementation of MD5,

9

;;;; available at http://www.pmsf.de/pmai/MD5.html.

10

;;;;

11

;;;; This implementation should work on any conforming Common Lisp

12

;;;; implementation, but it has been optimized for CMU CL and SBCL.

13

;;;;

14

;;;; The implementation makes heavy use of (UNSIGNED-BYTE 32) arithmetic;

15

;;;; if your CL implementation does not implement unboxed arithmetic on

16

;;;; such numbers, performance will likely be greater in a 16-bit

17

;;;; implementation.

18

;;;;

19

;;;; This software is "as is", and has no warranty of any kind. The

20

;;;; authors assume no responsibility for the consequences of any use

21

;;;; of this software.

22

(in-package :crypto)

23

24

;;; nonlinear functions

25

(defconstant +k1+ #x5a827999)

26

(defconstant +k2+ #x6ed9eba1)

27

(defconstant +k3+ #x8f1bbcdc)

28

(defconstant +k4+ #xca62c1d6)

29

30

;;; working set

31

(define-digest-registers (sha1 :endian :big)

32

(a #x67452301)

33

(b #xefcdab89)

34

(c #x98badcfe)

35

(d #x10325476)

36

(e #xc3d2e1f0))

37

38

(defconst +pristine-sha1-registers+ (initial-sha1-regs))

39

40

(defun update-sha1-block (regs block)

41

(declare (type sha1-regs regs)

42

(type (simple-array (unsigned-byte 32) (80)) block)

43

#.(burn-baby-burn))

44

;; FIXME: There must be a better way to do this

45

;; per-implementation/architecture specialization.

46

#+(and x86-64 ironclad-assembly)

47

(%update-sha1-block regs block)

48

#-(and x86-64 ironclad-assembly)

49

(let ((a (sha1-regs-a regs)) (b (sha1-regs-b regs))

50

(c (sha1-regs-c regs)) (d (sha1-regs-d regs))

51

(e (sha1-regs-e regs)))

52

(macrolet ((sha1-rounds (block func constant low high &rest initial-order)

53

;; Yay for "implementation-dependent" behavior (6.1.1.4).

54

(let ((xvars (apply #'make-circular-list initial-order)))

55

(loop for i from low upto high

56

for vars on xvars by #'cddddr

57

collect (let ((a-var (first vars))

58

(b-var (second vars))

59

(c-var (third vars))

60

(d-var (fourth vars))

61

(e-var (fifth vars)))

62

`(setf ,e-var

63

(mod32+ (rol32 ,a-var 5)

64

                                                   (mod32+ (mod32+ (,func ,b-var ,c-var ,d-var) ,e-var)

65

                                                           (mod32+ (aref ,block ,i) ,constant)))

66

                                           ,b-var (rol32 ,b-var 30))) into forms

67

finally (return `(progn ,@forms))))))

68

(flet ((f1 (x y z)

69

(declare (type (unsigned-byte 32) x y z))

70

(logxor z (logand x (logxor y z))))

71

(f2 (x y z)

72

(declare (type (unsigned-byte 32) x y z))

73

(ldb (byte 32 0) (logxor x y z)))

74

(f3 (x y z)

75

(declare (type (unsigned-byte 32) x y z))

76

(ldb (byte 32 0)

77

(logior (logand x y) (logand x z) (logand y z)))))

78

#+ironclad-fast-mod32-arithmetic

79

(declare (inline f1 f2 f3))

80

;; core of the algorithm

81

(sha1-rounds block f1 +k1+ 0 19 a b c d e)

82

(sha1-rounds block f2 +k2+ 20 39 a b c d e)

83

(sha1-rounds block f3 +k3+ 40 59 a b c d e)

84

(sha1-rounds block f2 +k4+ 60 79 a b c d e)

85

;; update and return

86

(setf (sha1-regs-a regs) (mod32+ (sha1-regs-a regs) a)

87

(sha1-regs-b regs) (mod32+ (sha1-regs-b regs) b)

88

(sha1-regs-c regs) (mod32+ (sha1-regs-c regs) c)

89

(sha1-regs-d regs) (mod32+ (sha1-regs-d regs) d)

90

(sha1-regs-e regs) (mod32+ (sha1-regs-e regs) e))

91

regs))))

92

93

;; ugh.

94

#+(and ironclad-fast-mod32-arithmetic (not (or x86 x86-64)))

95

(declaim (inline expand-block))

96

97

(defun expand-block (block)

98

"Expand the first 16 words in BLOCK to fill the entire 80 word space

99

available."

100

(declare (type (simple-array (unsigned-byte 32) (80)) block)

101

#.(burn-baby-burn))

102

(loop for i of-type (integer 16 80) from 16 below 80

103

do (setf (aref block i)

104

(rol32 (ldb (byte 32 0)

105

(logxor (aref block (- i 3))

106

(aref block (- i 8))

107

(aref block (- i 14))

108

(aref block (- i 16))))

109

1)))

110

(values))

111

112

;;; mid-level

113

(defstruct (sha1

114

(:constructor %make-sha1-digest nil)

115

(:constructor %make-sha1-state (regs amount block buffer buffer-index))

116

(:copier nil)

117

(:include mdx))

118

(regs (initial-sha1-regs) :type sha1-regs :read-only t)

119

(block (make-array 80 :element-type '(unsigned-byte 32))

120

:type (simple-array (unsigned-byte 32) (80)) :read-only t))

121

122

(defmethod reinitialize-instance ((state sha1) &rest initargs)

123

(declare (ignore initargs))

124

(replace (sha1-regs state) +pristine-sha1-registers+)

125

(setf (sha1-amount state) 0

126

(sha1-buffer-index state) 0)

127

state)

128

129

(defmethod copy-digest ((state sha1) &optional copy)

130

(check-type copy (or null sha1))

131

(cond

132

(copy

133

(replace (sha1-regs copy) (sha1-regs state))

134

(replace (sha1-buffer copy) (sha1-buffer state))

135

(setf (sha1-amount copy) (sha1-amount state)

136

(sha1-buffer-index copy) (sha1-buffer-index state))

137

copy)

138

(t

139

(%make-sha1-state (copy-seq (sha1-regs state))

140

(sha1-amount state)

141

(copy-seq (sha1-block state))

142

(copy-seq (sha1-buffer state))

143

(sha1-buffer-index state)))))

144

145

(define-digest-updater sha1

146

(flet ((compress (state sequence offset)

147

(let ((block (sha1-block state)))

148

(fill-block-ub8-be block sequence offset)

149

(expand-block block)

150

(update-sha1-block (sha1-regs state) block))))

151

(declare (dynamic-extent #'compress))

152

(declare (notinline mdx-updater))

153

(mdx-updater state #'compress sequence start end)))

154

155

(define-digest-finalizer (sha1 20)

156

(let ((regs (sha1-regs state))

157

(block (sha1-block state))

158

(buffer (sha1-buffer state))

159

(buffer-index (sha1-buffer-index state))

160

(total-length (* 8 (sha1-amount state))))

161

(declare (type sha1-regs regs)

162

(type (integer 0 63) buffer-index)

163

(type (simple-array (unsigned-byte 32) (80)) block)

164

(type (simple-array (unsigned-byte 8) (64)) buffer))

165

(declare (notinline update-sha1-block))

166

(setf (aref buffer buffer-index) #x80)

167

(when (> buffer-index 55)

168

(loop for index of-type (integer 0 64)

169

from (1+ buffer-index) below 64

170

do (setf (aref buffer index) #x00))

171

(fill-block-ub8-be block buffer 0)

172

(expand-block block)

173

(update-sha1-block regs block)

174

(loop for index of-type (integer 0 16)

175

from 0 below 16

176

do (setf (aref block index) #x00000000)))

177

(when (<= buffer-index 55)

178

(loop for index of-type (integer 0 64)

179

from (1+ buffer-index) below 64

180

do (setf (aref buffer index) #x00))

181

;; copy the data to BLOCK prematurely

182

(fill-block-ub8-be block buffer 0))

183

;; fill in the remaining block data

184

(store-data-length block total-length 14 t)

185

(expand-block block)

186

(update-sha1-block regs block)

187

(finalize-registers state regs)))

188

189

(defdigest sha1 :digest-length 20 :block-length 64)

190