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

Kind	Covered	All	%
expression	1	143	0.7
branch	0	2	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; md4.lisp -- the MD4 digest algorithm as given in RFC1320

2

3

(in-package :crypto)

4

5

(define-digest-registers (md4 :endian :little)

6

(a #x67452301)

7

(b #xefcdab89)

8

(c #x98badcfe)

9

(d #x10325476))

10

11

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

12

13

(defun update-md4-block (regs block)

14

(declare (type md4-regs regs))

15

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

16

#.(burn-baby-burn))

17

(let ((a (md4-regs-a regs))

18

(b (md4-regs-b regs))

19

(c (md4-regs-c regs))

20

(d (md4-regs-d regs)))

21

(declare (type (unsigned-byte 32) a b c d))

22

(flet ((f (x y z)

23

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

24

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

25

(g (x y z)

26

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

27

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

28

(h (x y z)

29

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

30

(logxor x y z)))

31

#+ironclad-fast-mod32-arithmetic

32

(declare (inline f g h))

33

(macrolet ((with-md4-round ((op block constant) &rest clauses)

34

(loop for (a b c d k s) in clauses

35

collect `(setq ,a (rol32 (mod32+

36

(mod32+ ,a

37

                                                            (mod32+ (,op ,b ,c ,d)

38

                                                                    (aref ,block ,k)))

39

                                                    ,constant) ,s)) into result

40

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

41

(with-md4-round (f block 0)

42

(a b c d 0 3) (d a b c 1 7) (c d a b 2 11) (b c d a 3 19)

43

(a b c d 4 3) (d a b c 5 7) (c d a b 6 11) (b c d a 7 19)

44

(a b c d 8 3) (d a b c 9 7) (c d a b 10 11) (b c d a 11 19)

45

(a b c d 12 3) (d a b c 13 7) (c d a b 14 11) (b c d a 15 19))

46

(with-md4-round (g block #x5a827999)

47

(a b c d 0 3) (d a b c 4 5) (c d a b 8 9) (b c d a 12 13)

48

(a b c d 1 3) (d a b c 5 5) (c d a b 9 9) (b c d a 13 13)

49

(a b c d 2 3) (d a b c 6 5) (c d a b 10 9) (b c d a 14 13)

50

(a b c d 3 3) (d a b c 7 5) (c d a b 11 9) (b c d a 15 13))

51

(with-md4-round (h block #x6ed9eba1)

52

(a b c d 0 3) (d a b c 8 9) (c d a b 4 11) (b c d a 12 15)

53

(a b c d 2 3) (d a b c 10 9) (c d a b 6 11) (b c d a 14 15)

54

(a b c d 1 3) (d a b c 9 9) (c d a b 5 11) (b c d a 13 15)

55

(a b c d 3 3) (d a b c 11 9) (c d a b 7 11) (b c d a 15 15))

56

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

57

(md4-regs-b regs) (mod32+ (md4-regs-b regs) b)

58

(md4-regs-c regs) (mod32+ (md4-regs-c regs) c)

59

(md4-regs-d regs) (mod32+ (md4-regs-d regs) d))

60

regs))))

61

62

(defstruct (md4

63

(:constructor %make-md4-digest nil)

64

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

65

(:copier nil)

66

(:include mdx))

67

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

68

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

69

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

70

71

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

72

(declare (ignore initargs))

73

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

74

(setf (md4-amount state) 0

75

(md4-buffer-index state) 0)

76

state)

77

78

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

79

(check-type copy (or null md4))

80

(cond

81

(copy

82

(replace (md4-regs copy) (md4-regs state))

83

(replace (md4-buffer copy) (md4-buffer state))

84

(setf (md4-amount copy) (md4-amount state)

85

(md4-buffer-index copy) (md4-buffer-index state))

86

copy)

87

(t

88

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

89

(md4-amount state)

90

(copy-seq (md4-block state))

91

(copy-seq (md4-buffer state))

92

(md4-buffer-index state)))))

93

94

(define-digest-updater md4

95

"Update the given md4-state from sequence, which is either a

96

simple-string or a simple-array with element-type (unsigned-byte 8),

97

bounded by start and end, which must be numeric bounding-indices."

98

(flet ((compress (state sequence offset)

99

(let ((block (md4-block state)))

100

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

101

(update-md4-block (md4-regs state) block))))

102

(declare (dynamic-extent #'compress))

103

(declare (notinline mdx-updater))

104

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

105

106

(define-digest-finalizer (md4 16)

107

"If the given md4-state has not already been finalized, finalize it,

108

by processing any remaining input in its buffer, with suitable padding

109

and appended bit-length, as specified by the MD4 standard.

110

111

The resulting MD4 message-digest is returned as an array of sixteen

112

(unsigned-byte 8) values. Calling UPDATE-MD4-STATE after a call to

113

FINALIZE-MD4-STATE results in unspecified behaviour."

114

(let ((regs (md4-regs state))

115

(block (md4-block state))

116

(buffer (md4-buffer state))

117

(buffer-index (md4-buffer-index state))

118

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

119

(declare (type md4-regs regs)

120

(type (integer 0 63) buffer-index)

121

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

122

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

123

;; Add mandatory bit 1 padding

124

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

125

;; Fill with 0 bit padding

126

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

127

from (1+ buffer-index) below 64

128

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

129

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

130

;; Flush block first if length wouldn't fit

131

(when (>= buffer-index 56)

132

(update-md4-block regs block)

133

;; Create new fully 0 padded block

134

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

135

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

136

;; Add 64bit message bit length

137

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

138

;; Flush last block

139

(update-md4-block regs block)

140

;; Done, remember digest for later calls

141

(finalize-registers state regs)))

142

143

(defdigest md4 :digest-length 16 :block-length 64)