Importing Oort Gnus v0.06.
[elisp/gnus.git-] / contrib / sha1.el
1 ;;; sha1.el --- SHA1 Message Digest Algorithm.
2 ;; Copyright (C) 1998,1999 Keiichi Suzuki.
3
4 ;; Author: Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
5 ;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
6 ;; Created: 1998-12-25
7 ;; Revised: 1999-01-13
8 ;; Keywords: sha1, news, cancel-lock, hmac, rfc2104
9
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;;; A copy of the GNU General Public License can be obtained from this
21 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
22 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
23 ;;; 02139, USA.
24
25 ;;; Commentary:
26
27 ;; This is a direct translation into Emacs LISP of the reference C
28 ;; implementation of the SHA1 message digest algorithm.
29
30 ;;; Usage:
31
32 ;; To compute the SHA1 message digest for a message M (represented as
33 ;; a string), call
34 ;; 
35 ;;   (sha1-encode M)
36 ;;
37 ;; which returns the message digest as a hexadecimal string of 20 bytes.
38 ;; If you need to supply the message in pieces M1, M2, ... Mn, then call
39 ;; 
40 ;;   (sha1-init)
41 ;;   (sha1-update M1)
42 ;;   (sha1-update M2)
43 ;;   ...
44 ;;   (sha1-update Mn)
45 ;;   (sha1-final)
46
47 ;;; Notes:
48
49 ;; The C algorithm uses 32-bit integers; because GNU Emacs
50 ;; implementations provide 28-bit integers (with 24-bit integers on
51 ;; versions prior to 19.29), the code represents a 32-bit integer as the
52 ;; cons of two 16-bit integers.  The most significant word is stored in
53 ;; the car and the least significant in the cdr.  The algorithm requires
54 ;; at least 19 bits of integer representation in order to represent the
55 ;; carry from a 16-bit addition. (see sha1-add())
56
57 ;;; Code:
58
59 (defmacro sha1-f1 (x y z)
60   `(cons
61     (logior (logand (car ,x) (car ,y)) (logand (lognot (car ,x)) (car ,z)))
62     (logior (logand (cdr ,x) (cdr ,y)) (logand (lognot (cdr ,x)) (cdr ,z)))
63     ))
64
65 (defmacro sha1-f2 (x y z)
66   `(cons
67     (logxor (car ,x) (car ,y) (car ,z))
68     (logxor (cdr ,x) (cdr ,y) (cdr ,z))
69     ))
70
71 (defmacro sha1-f3 (x y z)
72   `(cons
73     (logior (logand (car ,x) (car ,y)) (logand (car ,x) (car ,z))
74             (logand (car ,y) (car ,z)))
75     (logior (logand (cdr ,x) (cdr ,y)) (logand (cdr ,x) (cdr ,z))
76             (logand (cdr ,y) (cdr ,z)))
77     ))
78
79 (defmacro sha1-f4 (x y z)
80   `(cons
81     (logxor (car ,x) (car ,y) (car ,z))
82     (logxor (cdr ,x) (cdr ,y) (cdr ,z))
83     ))
84
85 (defconst sha1-const1 '(23170 . 31129)
86   "SHA constants 1 \(0x5a827999\)")
87 (defconst sha1-const2 '(28377 . 60321)
88   "SHA constants 2 \(0x6ed9eba1\)")
89 (defconst sha1-const3 '(36635 . 48348)
90   "SHA constants 3 \(0x8f1bbcdc\)")
91 (defconst sha1-const4 '(51810 . 49622)
92   "SHA constants 4 \(0xca62c1d6\)")
93
94 (defvar sha1-digest (make-vector 5 nil))
95 (defvar sha1-count-lo nil)
96 (defvar sha1-count-hi nil)
97 (defvar sha1-data nil)
98 (defvar sha1-local nil)
99 (defconst SHA1-BLOCKSIZE 64)
100
101 (defun sha1-init ()
102   "Initialize the state of the SHA1 message digest routines."
103   (aset sha1-digest 0 (cons 26437 8961))
104   (aset sha1-digest 1 (cons 61389 43913))
105   (aset sha1-digest 2 (cons 39098 56574))
106   (aset sha1-digest 3 (cons  4146 21622))
107   (aset sha1-digest 4 (cons 50130 57840))
108   (setq sha1-count-lo (cons 0 0)
109         sha1-count-hi (cons 0 0)
110         sha1-local 0
111         sha1-data nil)
112   )
113
114 (defmacro sha1-32-make (v)
115   "Return 32bits internal value from normal integer."
116   `(cons (lsh ,v -16) (logand 65535 ,v)))
117
118 (defun sha1-add (to &rest vals)
119   "Set sum of all the arguments to the first one."
120   (let (val)
121     (while (setq val (car vals))
122       (setcar to (+ (car to) (car val)))
123       (setcdr to (+ (cdr to) (cdr val)))
124       (setq vals (cdr vals))
125       )
126     (setcar to (logand 65535 (+ (car to) (lsh (cdr to) -16))))
127     (setcdr to (logand 65535 (cdr to)))
128     to
129     ))
130
131 (defun sha1-xor (to &rest vals)
132   "Set bitwise-exclusive-or of all the arguments to the first one."
133   (let (val)
134     (while (setq val (car vals))
135       (setcar to (logxor (car to) (car val)))
136       (setcdr to (logxor (cdr to) (cdr val)))
137       (setq vals (cdr vals)))
138     ))
139
140 (defmacro sha1-rot (val c1 c2)
141   "Internal macro for sha1-rot-*."
142   `(cons
143     (logand 65535 (logior (lsh (car ,val) ,c1) (lsh (cdr ,val) ,c2)))
144     (logand 65535 (logior (lsh (cdr ,val) ,c1) (lsh (car ,val) ,c2)))
145     ))
146
147 (defmacro sha1-rot-1 (val)
148   "Return VAL with its bits rotated left by 1."
149   `(sha1-rot ,val 1 -15)
150   )
151
152 (defmacro sha1-rot-5 (val)
153   "Return VAL with its bits rotated left by 5."
154   `(sha1-rot ,val 5 -11)
155   )
156
157 (defmacro sha1-rot-30 (val)
158   "Return VAL with its bits rotated left by 30."
159   `(sha1-rot ,val -2 14)
160   )
161
162 (defun sha1-inc (to)
163   "Set TO pulus one to TO."
164   (setcdr to (1+ (cdr to)))
165   (when (> (cdr to) 65535)
166     (setcdr to (logand 65535 (cdr to)))
167     (setcar to (logand 65535 (1+ (car to))))))
168
169 (defun sha1-lsh (to v count)
170   "Set TO with its bits shifted left by COUNT to TO."
171   (setcar to (logand 65535
172                      (logior (lsh (car v) count) (lsh (cdr v) (- count 16)))))
173   (setcdr to (logand 65535 (lsh (cdr v) count)))
174   to
175   )
176
177 (defun sha1-rsh (to v count)
178   "Set TO with its bits shifted right by COUNT to TO."
179   (setq count (- 0 count))
180   (setcdr to (logand 65535
181                      (logior (lsh (cdr v) count) (lsh (car v) (- count 16)))))
182   (setcar to (logand 65535 (lsh (car v) count)))
183   to
184   )
185
186 (defun sha1-< (v1 v2)
187   "Return t if firast argment is less then second argument."
188   (or (< (car v1) (car v2))
189       (and (eq (car v1) (car v2))
190            (< (cdr v1) (cdr v2))))
191   )
192
193 (unless (fboundp 'string-as-unibyte)
194   (defsubst string-as-unibyte (string)
195     string)
196   )
197
198 (defun sha1-update (bytes)
199   "Update the current SHA1 state with BYTES (an string of uni-bytes)."
200   (setq bytes (string-as-unibyte bytes))
201   (let* ((len (length bytes))
202          (len32 (sha1-32-make len))
203          (tmp32 (cons 0 0))
204          (top 0)
205          (clo (cons 0 0))
206          i done)
207     (sha1-add clo sha1-count-lo (sha1-lsh tmp32 len32 3))
208     (when (sha1-< clo sha1-count-lo)
209       (sha1-inc sha1-count-hi))
210     (setq sha1-count-lo clo)
211     (sha1-add sha1-count-hi (sha1-rsh tmp32 len32 29))
212     (when (> (length sha1-data) 0)
213       (setq i (- SHA1-BLOCKSIZE (length sha1-data)))
214       (when (> i len)
215         (setq i len))
216       (setq sha1-data (concat sha1-data (substring bytes 0 i)))
217       (setq len (- len i)
218             top i)
219       (if (eq (length sha1-data) SHA1-BLOCKSIZE)
220           (sha1-transform)
221         (setq done t)))
222     (when (not done)
223       (while (and (not done)
224                   (>= len SHA1-BLOCKSIZE))
225         (setq sha1-data (substring bytes top (+ top SHA1-BLOCKSIZE))
226               top (+ top SHA1-BLOCKSIZE)
227               len (- len SHA1-BLOCKSIZE))
228         (sha1-transform))
229       (setq sha1-data (substring bytes top (+ top len))))
230     ))
231
232 (defmacro sha1-FA (n)
233   (let ((func (intern (format "sha1-f%d" n)))
234         (const (intern (format "sha1-const%d" n))))
235     `(setq T (sha1-add (cons 0 0) (sha1-rot-5 A) (,func B C D) E (aref W WIDX)
236                        ,const)
237            WIDX (1+ WIDX)
238            B (sha1-rot-30 B))))
239
240 (defmacro sha1-FB (n)
241   (let ((func (intern (format "sha1-f%d" n)))
242         (const (intern (format "sha1-const%d" n))))
243     `(setq E (sha1-add (cons 0 0) (sha1-rot-5 T) (,func A B C) D (aref W WIDX)
244                        ,const)
245            WIDX (1+ WIDX)
246            A (sha1-rot-30 A))))
247
248 (defmacro sha1-FC (n)
249   (let ((func (intern (format "sha1-f%d" n)))
250         (const (intern (format "sha1-const%d" n))))
251     `(setq D (sha1-add (cons 0 0) (sha1-rot-5 E) (,func T A B) C (aref W WIDX)
252                        ,const)
253            WIDX (1+ WIDX)
254            T (sha1-rot-30 T))))
255
256 (defmacro sha1-FD (n)
257   (let ((func (intern (format "sha1-f%d" n)))
258         (const (intern (format "sha1-const%d" n))))
259     `(setq C (sha1-add (cons 0 0) (sha1-rot-5 D) (,func E T A) B (aref W WIDX)
260                        ,const)
261            WIDX (1+ WIDX)
262            E (sha1-rot-30 E))))
263
264 (defmacro sha1-FE (n)
265   (let ((func (intern (format "sha1-f%d" n)))
266         (const (intern (format "sha1-const%d" n))))
267     `(setq B (sha1-add (cons 0 0) (sha1-rot-5 C) (,func D E T) A (aref W WIDX)
268                        ,const)
269            WIDX (1+ WIDX)
270            D (sha1-rot-30 D))))
271
272 (defmacro sha1-FT (n)
273   (let ((func (intern (format "sha1-f%d" n)))
274         (const (intern (format "sha1-const%d" n))))
275     `(setq A (sha1-add (cons 0 0) (sha1-rot-5 B) (,func C D E) T (aref W WIDX)
276                        ,const)
277            WIDX (1+ WIDX)
278            C (sha1-rot-30 C))))
279
280 (defun sha1-transform ()
281   "Basic SHA1 step. Transform sha1-digest based on sha1-data."
282   (let ((W (make-vector 80 nil))
283         (WIDX 0)
284         (bidx 0)
285         T A B C D E)
286     (while (< WIDX 16)
287       (aset W WIDX
288             (cons (logior (lsh (aref sha1-data bidx) 8)
289                           (aref sha1-data (setq bidx (1+ bidx))))
290                   (logior (lsh (aref sha1-data (setq bidx (1+ bidx))) 8)
291                           (aref sha1-data (setq bidx (1+ bidx))))))
292       (setq bidx (1+ bidx)
293             WIDX (1+ WIDX)))
294     (while (< WIDX 80)
295       (aset W WIDX (cons 0 0))
296       (sha1-xor (aref W WIDX)
297                    (aref W (- WIDX 3)) (aref W (- WIDX 8))
298                    (aref W (- WIDX 14)) (aref W (- WIDX 16)))
299       (aset W WIDX (sha1-rot-1 (aref W WIDX)))
300       (setq WIDX (1+ WIDX)))
301     (setq A (cons (car (aref sha1-digest 0)) (cdr (aref sha1-digest 0)))
302           B (cons (car (aref sha1-digest 1)) (cdr (aref sha1-digest 1)))
303           C (cons (car (aref sha1-digest 2)) (cdr (aref sha1-digest 2)))
304           D (cons (car (aref sha1-digest 3)) (cdr (aref sha1-digest 3)))
305           E (cons (car (aref sha1-digest 4)) (cdr (aref sha1-digest 4)))
306           WIDX 0)
307
308     (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
309     (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
310     (sha1-FA 1) (sha1-FB 1) (sha1-FC 1) (sha1-FD 1) (sha1-FE 1) (sha1-FT 1)
311     (sha1-FA 1) (sha1-FB 1) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
312     (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
313     (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 2) (sha1-FT 2)
314     (sha1-FA 2) (sha1-FB 2) (sha1-FC 2) (sha1-FD 2) (sha1-FE 3) (sha1-FT 3)
315     (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
316     (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
317     (sha1-FA 3) (sha1-FB 3) (sha1-FC 3) (sha1-FD 3) (sha1-FE 3) (sha1-FT 3)
318     (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
319     (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
320     (sha1-FA 4) (sha1-FB 4) (sha1-FC 4) (sha1-FD 4) (sha1-FE 4) (sha1-FT 4)
321     (sha1-FA 4) (sha1-FB 4)
322
323     (sha1-add (aref sha1-digest 0) E)
324     (sha1-add (aref sha1-digest 1) T)
325     (sha1-add (aref sha1-digest 2) A)
326     (sha1-add (aref sha1-digest 3) B)
327     (sha1-add (aref sha1-digest 4) C)
328     ))
329
330 (defun sha1-final (&optional binary)
331   "Transform buffered sha1-data and return SHA1 message digest.
332 If optional argument BINARY is non-nil, then return binary formed 
333 string of message digest."
334   (let ((count (logand (lsh (cdr sha1-count-lo) -3) 63)))
335     (when (< (length sha1-data) SHA1-BLOCKSIZE)
336       (setq sha1-data
337             (concat sha1-data
338                     (make-string (- SHA1-BLOCKSIZE (length sha1-data)) 0))))
339     (aset sha1-data count 128)
340     (setq count (1+ count))
341     (if (> count (- SHA1-BLOCKSIZE 8))
342         (progn
343           (setq sha1-data (concat (substring sha1-data 0 count)
344                                   (make-string (- SHA1-BLOCKSIZE count) 0)))
345           (sha1-transform)
346           (setq sha1-data (concat (make-string (- SHA1-BLOCKSIZE 8) 0)
347                                   (substring sha1-data -8))))
348       (setq sha1-data (concat (substring sha1-data 0 count)
349                               (make-string (- SHA1-BLOCKSIZE 8 count) 0)
350                               (substring sha1-data -8))))
351     (aset sha1-data 56 (lsh (car sha1-count-hi) -8))
352     (aset sha1-data 57 (logand 255 (car sha1-count-hi)))
353     (aset sha1-data 58 (lsh (cdr sha1-count-hi) -8))
354     (aset sha1-data 59 (logand 255 (cdr sha1-count-hi)))
355     (aset sha1-data 60 (lsh (car sha1-count-lo) -8))
356     (aset sha1-data 61 (logand 255 (car sha1-count-lo)))
357     (aset sha1-data 62 (lsh (cdr sha1-count-lo) -8))
358     (aset sha1-data 63 (logand 255 (cdr sha1-count-lo)))
359     (sha1-transform)
360     (if binary
361         (mapconcat
362          (lambda (elem)
363            (concat (char-to-string (/ (car elem) 256))
364                    (char-to-string (% (car elem) 256))
365                    (char-to-string (/ (cdr elem) 256))
366                    (char-to-string (% (cdr elem) 256))))
367          (list (aref sha1-digest 0) (aref sha1-digest 1) (aref sha1-digest 2)
368                (aref sha1-digest 3) (aref sha1-digest 4))
369          "")
370       (format "%04x%04x%04x%04x%04x%04x%04x%04x%04x%04x"
371               (car (aref sha1-digest 0)) (cdr (aref sha1-digest 0))
372               (car (aref sha1-digest 1)) (cdr (aref sha1-digest 1))
373               (car (aref sha1-digest 2)) (cdr (aref sha1-digest 2))
374               (car (aref sha1-digest 3)) (cdr (aref sha1-digest 3))
375               (car (aref sha1-digest 4)) (cdr (aref sha1-digest 4)))
376       )))
377
378 (defun sha1-encode (message &optional binary)
379   "Encodes MESSAGE using the SHA1 message digest algorithm.
380 MESSAGE must be a unibyte-string.
381 By default, return a string which formed hex-decimal charcters
382 from message digest.
383 If optional argument BINARY is non-nil, then return binary formed
384 string of message digest."
385   (sha1-init)
386   (sha1-update message)
387   (sha1-final binary))
388
389 (defun sha1-encode-binary (message)
390   "Encodes MESSAGE using the SHA1 message digest algorithm.
391 MESSAGE must be a unibyte-string.
392 Return binary formed string of message digest."
393   (sha1-encode message 'binary))
394
395 (provide 'sha1)
396
397 ;;; sha1.el ends here