372d33d28959d35137fa48901159a50ce9962d3f
[gnus] / lisp / md4.el
1 ;;; md4.el --- MD4 Message Digest Algorithm.
2
3 ;; Copyright (C) 2001, 2004, 2007-2015 Free Software Foundation, Inc.
4
5 ;; Author: Taro Kawagishi <tarok@transpulse.org>
6 ;; Keywords: MD4
7 ;; Version: 1.00
8 ;; Created: February 2001
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Code:
26
27 ;;;
28 ;;; MD4 hash calculation
29
30 (defvar md4-buffer (make-vector 4 '(0 . 0))
31   "Work buffer of four 32-bit integers.")
32
33 (defun md4 (in n)
34   "Return the MD4 hash for a string IN of length N bytes.
35 The returned hash is 16 bytes long.  N is required to handle
36 strings containing the character 0."
37   (let (m
38         (b (cons 0 (* n 8)))
39         (i 0)
40         (buf (make-string 128 0)) c4)
41     ;; initial values
42     (aset md4-buffer 0 '(26437 . 8961))         ;0x67452301
43     (aset md4-buffer 1 '(61389 . 43913))        ;0xefcdab89
44     (aset md4-buffer 2 '(39098 . 56574))        ;0x98badcfe
45     (aset md4-buffer 3 '(4146 . 21622))         ;0x10325476
46
47     ;; process the string in 64 bits chunks
48     (while (> n 64)
49       (setq m (md4-copy64 (substring in 0 64)))
50       (md4-64 m)
51       (setq in (substring in 64))
52       (setq n (- n 64)))
53
54     ;; process the rest of the string (length is now n <= 64)
55     (setq i 0)
56     (while (< i n)
57       (aset buf i (aref in i))
58       (setq i (1+ i)))
59     (aset buf n 128)                    ;0x80
60     (if (<= n 55)
61         (progn
62           (setq c4 (md4-pack-int32 b))
63           (aset buf 56 (aref c4 0))
64           (aset buf 57 (aref c4 1))
65           (aset buf 58 (aref c4 2))
66           (aset buf 59 (aref c4 3))
67           (setq m (md4-copy64 buf))
68           (md4-64 m))
69       ;; else
70       (setq c4 (md4-pack-int32 b))
71       (aset buf 120 (aref c4 0))
72       (aset buf 121 (aref c4 1))
73       (aset buf 122 (aref c4 2))
74       (aset buf 123 (aref c4 3))
75       (setq m (md4-copy64 buf))
76       (md4-64 m)
77       (setq m (md4-copy64 (substring buf 64)))
78       (md4-64 m)))
79
80     (concat (md4-pack-int32 (aref md4-buffer 0))
81             (md4-pack-int32 (aref md4-buffer 1))
82             (md4-pack-int32 (aref md4-buffer 2))
83             (md4-pack-int32 (aref md4-buffer 3))))
84
85 (defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z)))
86 (defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z)))
87 (defsubst md4-H (x y z) (logxor x y z))
88
89 (defmacro md4-make-step (name func)
90   `(defun ,name (a b c d xk s ac)
91      (let*
92          ((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac)))
93           (l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac)))
94           (h2 (logand 65535 (+ h1 (lsh l1 -16))))
95           (l2 (logand 65535 l1))
96           ;; cyclic shift of 32 bits integer
97           (h3 (logand 65535 (if (> s 15)
98                                 (+ (lsh h2 (- s 32)) (lsh l2 (- s 16)))
99                               (+ (lsh h2 s) (lsh l2 (- s 16))))))
100           (l3 (logand 65535 (if (> s 15)
101                                 (+ (lsh l2 (- s 32)) (lsh h2 (- s 16)))
102                               (+ (lsh l2 s) (lsh h2 (- s 16)))))))
103        (cons h3 l3))))
104
105 (md4-make-step md4-round1 md4-F)
106 (md4-make-step md4-round2 md4-G)
107 (md4-make-step md4-round3 md4-H)
108
109 (defsubst md4-add (x y)
110   "Return 32-bit sum of 32-bit integers X and Y."
111   (let ((h (+ (car x) (car y)))
112         (l (+ (cdr x) (cdr y))))
113     (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l))))
114
115 (defsubst md4-and (x y)
116   (cons (logand (car x) (car y)) (logand (cdr x) (cdr y))))
117
118 (defun md4-64 (m)
119   "Calculate MD4 hash of M.
120 M is a 64-bytes chunk, represented as 16 pairs of 32-bit integers.
121 The resulting MD4 value is placed in `md4-buffer'."
122   (let ((a (aref md4-buffer 0))
123         (b (aref md4-buffer 1))
124         (c (aref md4-buffer 2))
125         (d (aref md4-buffer 3)))
126     (setq a (md4-round1 a b c d (aref m  0)   3 '(0 . 0))
127           d (md4-round1 d a b c (aref m  1)   7 '(0 . 0))
128           c (md4-round1 c d a b (aref m  2)  11 '(0 . 0))
129           b (md4-round1 b c d a (aref m  3)  19 '(0 . 0))
130           a (md4-round1 a b c d (aref m  4)   3 '(0 . 0))
131           d (md4-round1 d a b c (aref m  5)   7 '(0 . 0))
132           c (md4-round1 c d a b (aref m  6)  11 '(0 . 0))
133           b (md4-round1 b c d a (aref m  7)  19 '(0 . 0))
134           a (md4-round1 a b c d (aref m  8)   3 '(0 . 0))
135           d (md4-round1 d a b c (aref m  9)   7 '(0 . 0))
136           c (md4-round1 c d a b (aref m 10)  11 '(0 . 0))
137           b (md4-round1 b c d a (aref m 11)  19 '(0 . 0))
138           a (md4-round1 a b c d (aref m 12)   3 '(0 . 0))
139           d (md4-round1 d a b c (aref m 13)   7 '(0 . 0))
140           c (md4-round1 c d a b (aref m 14)  11 '(0 . 0))
141           b (md4-round1 b c d a (aref m 15)  19 '(0 . 0))
142
143           a (md4-round2 a b c d (aref m  0)   3 '(23170 . 31129)) ;0x5A827999
144           d (md4-round2 d a b c (aref m  4)   5 '(23170 . 31129))
145           c (md4-round2 c d a b (aref m  8)   9 '(23170 . 31129))
146           b (md4-round2 b c d a (aref m 12)  13 '(23170 . 31129))
147           a (md4-round2 a b c d (aref m  1)   3 '(23170 . 31129))
148           d (md4-round2 d a b c (aref m  5)   5 '(23170 . 31129))
149           c (md4-round2 c d a b (aref m  9)   9 '(23170 . 31129))
150           b (md4-round2 b c d a (aref m 13)  13 '(23170 . 31129))
151           a (md4-round2 a b c d (aref m  2)   3 '(23170 . 31129))
152           d (md4-round2 d a b c (aref m  6)   5 '(23170 . 31129))
153           c (md4-round2 c d a b (aref m 10)   9 '(23170 . 31129))
154           b (md4-round2 b c d a (aref m 14)  13 '(23170 . 31129))
155           a (md4-round2 a b c d (aref m  3)   3 '(23170 . 31129))
156           d (md4-round2 d a b c (aref m  7)   5 '(23170 . 31129))
157           c (md4-round2 c d a b (aref m 11)   9 '(23170 . 31129))
158           b (md4-round2 b c d a (aref m 15)  13 '(23170 . 31129))
159
160           a (md4-round3 a b c d (aref m  0)   3 '(28377 . 60321)) ;0x6ED9EBA1
161           d (md4-round3 d a b c (aref m  8)   9 '(28377 . 60321))
162           c (md4-round3 c d a b (aref m  4)  11 '(28377 . 60321))
163           b (md4-round3 b c d a (aref m 12)  15 '(28377 . 60321))
164           a (md4-round3 a b c d (aref m  2)   3 '(28377 . 60321))
165           d (md4-round3 d a b c (aref m 10)   9 '(28377 . 60321))
166           c (md4-round3 c d a b (aref m  6)  11 '(28377 . 60321))
167           b (md4-round3 b c d a (aref m 14)  15 '(28377 . 60321))
168           a (md4-round3 a b c d (aref m  1)   3 '(28377 . 60321))
169           d (md4-round3 d a b c (aref m  9)   9 '(28377 . 60321))
170           c (md4-round3 c d a b (aref m  5)  11 '(28377 . 60321))
171           b (md4-round3 b c d a (aref m 13)  15 '(28377 . 60321))
172           a (md4-round3 a b c d (aref m  3)   3 '(28377 . 60321))
173           d (md4-round3 d a b c (aref m 11)   9 '(28377 . 60321))
174           c (md4-round3 c d a b (aref m  7)  11 '(28377 . 60321))
175           b (md4-round3 b c d a (aref m 15)  15 '(28377 . 60321)))
176
177     (aset md4-buffer 0 (md4-add a (aref md4-buffer 0)))
178     (aset md4-buffer 1 (md4-add b (aref md4-buffer 1)))
179     (aset md4-buffer 2 (md4-add c (aref md4-buffer 2)))
180     (aset md4-buffer 3 (md4-add d (aref md4-buffer 3)))
181     ))
182
183 (defun md4-copy64 (seq)
184   "Unpack a 64 bytes string into 16 pairs of 32 bits integers."
185   (let ((int32s (make-vector 16 0)) (i 0) j)
186     (while (< i 16)
187       (setq j (* i 4))
188       (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8))
189                            (+ (aref seq j) (lsh (aref seq (1+ j)) 8))))
190       (setq i (1+ i)))
191     int32s))
192
193 ;;;
194 ;;; sub functions
195
196 (defun md4-pack-int16 (int16)
197   "Pack 16 bits integer in 2 bytes string as little endian."
198   (let ((str (make-string 2 0)))
199     (aset str 0 (logand int16 255))
200     (aset str 1 (lsh int16 -8))
201     str))
202
203 (defun md4-pack-int32 (int32)
204   "Pack 32 bits integer in a 4 bytes string as little endian.
205 A 32 bits integer is represented as a pair of two 16 bits
206 integers (cons high low)."
207   (let ((str (make-string 4 0))
208         (h (car int32)) (l (cdr int32)))
209     (aset str 0 (logand l 255))
210     (aset str 1 (lsh l -8))
211     (aset str 2 (logand h 255))
212     (aset str 3 (lsh h -8))
213     str))
214
215 (defun md4-unpack-int16 (str)
216   (if (eq 2 (length str))
217       (+ (lsh (aref str 1) 8) (aref str 0))
218     (error "%s is not 2 bytes long" str)))
219
220 (defun md4-unpack-int32 (str)
221   (if (eq 4 (length str))
222       (cons (+ (lsh (aref str 3) 8) (aref str 2))
223             (+ (lsh (aref str 1) 8) (aref str 0)))
224     (error "%s is not 4 bytes long" str)))
225
226 (provide 'md4)
227
228 ;;; md4.el ends here