git.chise.org Git - elisp/gnus.git-/blob - 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