git.chise.org Git - elisp/gnus.git-/blob - lisp/sha1-el.el

   1 ;;; sha1-el.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp.
   2
   3 ;; Copyright (C) 1999, 2001  Free Software Foundation, Inc.
   4
   5 ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   6 ;; Keywords: SHA1, FIPS 180-1
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or
  13 ;; (at your option) 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 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This program is implemented from the definition of SHA-1 in FIPS PUB
  28 ;; 180-1 (Federal Information Processing Standards Publication 180-1),
  29 ;; "Announcing the Standard for SECURE HASH STANDARD".
  30 ;; <URL:http://www.itl.nist.gov/div897/pubs/fip180-1.htm>
  31 ;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c)
  32 ;;
  33 ;; Test cases from FIPS PUB 180-1.
  34 ;;
  35 ;; (sha1 "abc")
  36 ;; => a9993e364706816aba3e25717850c26c9cd0d89d
  37 ;;
  38 ;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq")
  39 ;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1
  40 ;;
  41 ;; (sha1 (make-string 1000000 ?a))
  42 ;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f
  43 ;;
  44 ;; BUGS:
  45 ;;  * It is assumed that length of input string is less than 2^29 bytes.
  46 ;;  * It is caller's responsibility to make string (or region) unibyte.
  47 ;;
  48 ;; TODO:
  49 ;;  * Rewrite from scratch!
  50 ;;    This version is much faster than Keiichi Suzuki's another sha1.el,
  51 ;;    but it is too dirty.
  52
  53 ;;; Code:
  54
  55 (require 'hex-util)
  56
  57 (autoload 'executable-find "executable")
  58
  59 ;;;
  60 ;;; external SHA1 function.
  61 ;;;
  62
  63 (defvar sha1-maximum-internal-length 500
  64   "*Maximum length of message to use lisp version of SHA1 function.
  65 If message is longer than this, `sha1-program' is used instead.
  66
  67 If this variable is set to 0, use extarnal program only.
  68 If this variable is set to nil, use internal function only.")
  69
  70 (defvar sha1-program '("openssl" "sha1")
  71   "*Name of program to compute SHA1.
  72 It must be a string \(program name\) or list of strings \(name and its args\).")
  73
  74 (defvar sha1-use-external
  75   (executable-find (car sha1-program))
  76   "*Use external sh1 program.
  77 If this variable is set to nil, use internal function only.")
  78
  79 (defun sha1-string-external (string)
  80   ;; `with-temp-buffer' is new in v20, so we do not use it.
  81   (save-excursion
  82     (let (buffer)
  83       (unwind-protect
  84           (let (prog args)
  85             (if (consp sha1-program)
  86                 (setq prog (car sha1-program)
  87                       args (cdr sha1-program))
  88               (setq prog sha1-program
  89                     args nil))
  90             (setq buffer (set-buffer
  91                           (generate-new-buffer " *sha1 external*")))
  92             (insert string)
  93             (apply (function call-process-region)
  94                    (point-min)(point-max)
  95                    prog t t nil args)
  96             ;; SHA1 is 40 bytes long in hexadecimal form.
  97             (buffer-substring (point-min)(+ (point-min) 40)))
  98         (and buffer
  99              (buffer-name buffer)
 100              (kill-buffer buffer))))))
 101
 102 (defun sha1-region-external (beg end)
 103   (sha1-string-external (buffer-substring-no-properties beg end)))
 104
 105 ;;;
 106 ;;; internal SHA1 function.
 107 ;;;
 108
 109 (eval-when-compile
 110   ;; optional second arg of string-to-number is new in v20.
 111   (defconst sha1-K0-high 23170)         ; (string-to-number "5A82" 16)
 112   (defconst sha1-K0-low  31129)         ; (string-to-number "7999" 16)
 113   (defconst sha1-K1-high 28377)         ; (string-to-number "6ED9" 16)
 114   (defconst sha1-K1-low  60321)         ; (string-to-number "EBA1" 16)
 115   (defconst sha1-K2-high 36635)         ; (string-to-number "8F1B" 16)
 116   (defconst sha1-K2-low  48348)         ; (string-to-number "BCDC" 16)
 117   (defconst sha1-K3-high 51810)         ; (string-to-number "CA62" 16)
 118   (defconst sha1-K3-low  49622)         ; (string-to-number "C1D6" 16)
 119
 120 ;;; original definition of sha1-F0.
 121 ;;; (defmacro sha1-F0 (B C D)
 122 ;;;   (` (logior (logand (, B) (, C))
 123 ;;;          (logand (lognot (, B)) (, D)))))
 124 ;;; a little optimization from GnuPG/cipher/sha1.c.
 125   (defmacro sha1-F0 (B C D)
 126     (` (logxor (, D) (logand (, B) (logxor (, C) (, D))))))
 127   (defmacro sha1-F1 (B C D)
 128     (` (logxor (, B) (, C) (, D))))
 129 ;;; original definition of sha1-F2.
 130 ;;; (defmacro sha1-F2 (B C D)
 131 ;;;   (` (logior (logand (, B) (, C))
 132 ;;;          (logand (, B) (, D))
 133 ;;;          (logand (, C) (, D)))))
 134 ;;; a little optimization from GnuPG/cipher/sha1.c.
 135   (defmacro sha1-F2 (B C D)
 136     (` (logior (logand (, B) (, C))
 137                (logand (, D) (logior (, B) (, C))))))
 138   (defmacro sha1-F3 (B C D)
 139     (` (logxor (, B) (, C) (, D))))
 140
 141   (defmacro sha1-S1  (W-high W-low)
 142     (` (let ((W-high (, W-high))
 143              (W-low  (, W-low)))
 144          (setq S1W-high (+ (% (* W-high 2) 65536)
 145                            (/ W-low (, (/ 65536 2)))))
 146          (setq S1W-low (+ (/ W-high (, (/ 65536 2)))
 147                           (% (* W-low 2) 65536))))))
 148   (defmacro sha1-S5  (A-high A-low)
 149     (` (progn
 150          (setq S5A-high (+ (% (* (, A-high) 32) 65536)
 151                            (/ (, A-low) (, (/ 65536 32)))))
 152          (setq S5A-low  (+ (/ (, A-high) (, (/ 65536 32)))
 153                            (% (* (, A-low) 32) 65536))))))
 154   (defmacro sha1-S30 (B-high B-low)
 155     (` (progn
 156          (setq S30B-high (+ (/ (, B-high) 4)
 157                             (* (% (, B-low) 4) (, (/ 65536 4)))))
 158          (setq S30B-low  (+ (/ (, B-low) 4)
 159                             (* (% (, B-high) 4) (, (/ 65536 4))))))))
 160
 161   (defmacro sha1-OP (round)
 162     (` (progn
 163          (sha1-S5 sha1-A-high sha1-A-low)
 164          (sha1-S30 sha1-B-high sha1-B-low)
 165          (setq sha1-A-low (+ ((, (intern (format "sha1-F%d" round)))
 166                               sha1-B-low sha1-C-low sha1-D-low)
 167                              sha1-E-low
 168                              (, (symbol-value
 169                                  (intern (format "sha1-K%d-low" round))))
 170                              (aref block-low idx)
 171                              (progn
 172                                (setq sha1-E-low sha1-D-low)
 173                                (setq sha1-D-low sha1-C-low)
 174                                (setq sha1-C-low S30B-low)
 175                                (setq sha1-B-low sha1-A-low)
 176                                S5A-low)))
 177          (setq carry (/ sha1-A-low 65536))
 178          (setq sha1-A-low (% sha1-A-low 65536))
 179          (setq sha1-A-high (% (+ ((, (intern (format "sha1-F%d" round)))
 180                                   sha1-B-high sha1-C-high sha1-D-high)
 181                                  sha1-E-high
 182                                  (, (symbol-value
 183                                      (intern (format "sha1-K%d-high" round))))
 184                                  (aref block-high idx)
 185                                  (progn
 186                                    (setq sha1-E-high sha1-D-high)
 187                                    (setq sha1-D-high sha1-C-high)
 188                                    (setq sha1-C-high S30B-high)
 189                                    (setq sha1-B-high sha1-A-high)
 190                                    S5A-high)
 191                                  carry)
 192                               65536)))))
 193
 194   (defmacro sha1-add-to-H (H X)
 195     (` (progn
 196          (setq (, (intern (format "sha1-%s-low" H)))
 197                (+ (, (intern (format "sha1-%s-low" H)))
 198                   (, (intern (format "sha1-%s-low" X)))))
 199          (setq carry (/ (, (intern (format "sha1-%s-low" H))) 65536))
 200          (setq (, (intern (format "sha1-%s-low" H)))
 201                (% (, (intern (format "sha1-%s-low" H))) 65536))
 202          (setq (, (intern (format "sha1-%s-high" H)))
 203                (% (+ (, (intern (format "sha1-%s-high" H)))
 204                      (, (intern (format "sha1-%s-high" X)))
 205                      carry)
 206                   65536)))))
 207   )
 208
 209 ;;; buffers (H0 H1 H2 H3 H4).
 210 (defvar sha1-H0-high)
 211 (defvar sha1-H0-low)
 212 (defvar sha1-H1-high)
 213 (defvar sha1-H1-low)
 214 (defvar sha1-H2-high)
 215 (defvar sha1-H2-low)
 216 (defvar sha1-H3-high)
 217 (defvar sha1-H3-low)
 218 (defvar sha1-H4-high)
 219 (defvar sha1-H4-low)
 220
 221 (defun sha1-block (block-high block-low)
 222   (let (;; step (c) --- initialize buffers (A B C D E).
 223         (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low)
 224         (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low)
 225         (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low)
 226         (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low)
 227         (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low)
 228         (idx 16))
 229     ;; step (b).
 230     (let (;; temporary variables used in sha1-S1 macro.
 231           S1W-high S1W-low)
 232       (while (< idx 80)
 233         (sha1-S1 (logxor (aref block-high (- idx 3))
 234                          (aref block-high (- idx 8))
 235                          (aref block-high (- idx 14))
 236                          (aref block-high (- idx 16)))
 237                  (logxor (aref block-low  (- idx 3))
 238                          (aref block-low  (- idx 8))
 239                          (aref block-low  (- idx 14))
 240                          (aref block-low  (- idx 16))))
 241         (aset block-high idx S1W-high)
 242         (aset block-low  idx S1W-low)
 243         (setq idx (1+ idx))))
 244     ;; step (d).
 245     (setq idx 0)
 246     (let (;; temporary variables used in sha1-OP macro.
 247           S5A-high S5A-low S30B-high S30B-low carry)
 248       (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx)))
 249       (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx)))
 250       (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx)))
 251       (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx))))
 252     ;; step (e).
 253     (let (;; temporary variables used in sha1-add-to-H macro.
 254           carry)
 255       (sha1-add-to-H H0 A)
 256       (sha1-add-to-H H1 B)
 257       (sha1-add-to-H H2 C)
 258       (sha1-add-to-H H3 D)
 259       (sha1-add-to-H H4 E))))
 260
 261 (defun sha1-binary (string)
 262   "Return the SHA1 of STRING in binary form."
 263   (let (;; prepare buffers for a block. byte-length of block is 64.
 264         ;; input block is split into two vectors.
 265         ;;
 266         ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ...
 267         ;; block-high:  +-0-+       +-1-+       +-2-+       +-3-+
 268         ;; block-low:         +-0-+       +-1-+       +-2-+       +-3-+
 269         ;;
 270         ;; length of each vector is 80, and elements of each vector are
 271         ;; 16bit integers.  elements 0x10-0x4F of each vector are
 272         ;; assigned later in `sha1-block'.
 273         (block-high (eval-when-compile (make-vector 80 nil)))
 274         (block-low  (eval-when-compile (make-vector 80 nil))))
 275     (unwind-protect
 276         (let* (;; byte-length of input string.
 277                (len (length string))
 278                (lim (* (/ len 64) 64))
 279                (rem (% len 4))
 280                (idx 0)(pos 0))
 281           ;; initialize buffers (H0 H1 H2 H3 H4).
 282           (setq sha1-H0-high 26437      ; (string-to-number "6745" 16)
 283                 sha1-H0-low  8961       ; (string-to-number "2301" 16)
 284                 sha1-H1-high 61389      ; (string-to-number "EFCD" 16)
 285                 sha1-H1-low  43913      ; (string-to-number "AB89" 16)
 286                 sha1-H2-high 39098      ; (string-to-number "98BA" 16)
 287                 sha1-H2-low  56574      ; (string-to-number "DCFE" 16)
 288                 sha1-H3-high 4146       ; (string-to-number "1032" 16)
 289                 sha1-H3-low  21622      ; (string-to-number "5476" 16)
 290                 sha1-H4-high 50130      ; (string-to-number "C3D2" 16)
 291                 sha1-H4-low  57840)     ; (string-to-number "E1F0" 16)
 292           ;; loop for each 64 bytes block.
 293           (while (< pos lim)
 294             ;; step (a).
 295             (setq idx 0)
 296             (while (< idx 16)
 297               (aset block-high idx (+ (* (aref string pos) 256)
 298                                       (aref string (1+ pos))))
 299               (setq pos (+ pos 2))
 300               (aset block-low  idx (+ (* (aref string pos) 256)
 301                                       (aref string (1+ pos))))
 302               (setq pos (+ pos 2))
 303               (setq idx (1+ idx)))
 304             (sha1-block block-high block-low))
 305           ;; last block.
 306           (if (prog1
 307                   (< (- len lim) 56)
 308                 (setq lim (- len rem))
 309                 (setq idx 0)
 310                 (while (< pos lim)
 311                   (aset block-high idx (+ (* (aref string pos) 256)
 312                                           (aref string (1+ pos))))
 313                   (setq pos (+ pos 2))
 314                   (aset block-low  idx (+ (* (aref string pos) 256)
 315                                           (aref string (1+ pos))))
 316                   (setq pos (+ pos 2))
 317                   (setq idx (1+ idx)))
 318                 ;; this is the last (at most) 32bit word.
 319                 (cond
 320                  ((= rem 3)
 321                   (aset block-high idx (+ (* (aref string pos) 256)
 322                                           (aref string (1+ pos))))
 323                   (setq pos (+ pos 2))
 324                   (aset block-low  idx (+ (* (aref string pos) 256)
 325                                           128)))
 326                  ((= rem 2)
 327                   (aset block-high idx (+ (* (aref string pos) 256)
 328                                           (aref string (1+ pos))))
 329                   (aset block-low  idx 32768))
 330                  ((= rem 1)
 331                   (aset block-high idx (+ (* (aref string pos) 256)
 332                                           128))
 333                   (aset block-low  idx 0))
 334                  (t ;; (= rem 0)
 335                   (aset block-high idx 32768)
 336                   (aset block-low  idx 0)))
 337                 (setq idx (1+ idx))
 338                 (while (< idx 16)
 339                   (aset block-high idx 0)
 340                   (aset block-low  idx 0)
 341                   (setq idx (1+ idx))))
 342               ;; last block has enough room to write the length of string.
 343               (progn
 344                 ;; write bit length of string to last 4 bytes of the block.
 345                 (aset block-low  15 (* (% len 8192) 8))
 346                 (setq len (/ len 8192))
 347                 (aset block-high 15 (% len 65536))
 348                 ;; XXX: It is not practical to compute SHA1 of
 349                 ;;      such a huge message on emacs.
 350                 ;; (setq len (/ len 65536))     ; for 64bit emacs.
 351                 ;; (aset block-low  14 (% len 65536))
 352                 ;; (aset block-high 14 (/ len 65536))
 353                 (sha1-block block-high block-low))
 354             ;; need one more block.
 355             (sha1-block block-high block-low)
 356             (fillarray block-high 0)
 357             (fillarray block-low  0)
 358             ;; write bit length of string to last 4 bytes of the block.
 359             (aset block-low  15 (* (% len 8192) 8))
 360             (setq len (/ len 8192))
 361             (aset block-high 15 (% len 65536))
 362             ;; XXX: It is not practical to compute SHA1 of
 363             ;;      such a huge message on emacs.
 364             ;; (setq len (/ len 65536))         ; for 64bit emacs.
 365             ;; (aset block-low  14 (% len 65536))
 366             ;; (aset block-high 14 (/ len 65536))
 367             (sha1-block block-high block-low))
 368           ;; make output string (in binary form).
 369           (let ((result (make-string 20 0)))
 370             (aset result  0 (/ sha1-H0-high 256))
 371             (aset result  1 (% sha1-H0-high 256))
 372             (aset result  2 (/ sha1-H0-low  256))
 373             (aset result  3 (% sha1-H0-low  256))
 374             (aset result  4 (/ sha1-H1-high 256))
 375             (aset result  5 (% sha1-H1-high 256))
 376             (aset result  6 (/ sha1-H1-low  256))
 377             (aset result  7 (% sha1-H1-low  256))
 378             (aset result  8 (/ sha1-H2-high 256))
 379             (aset result  9 (% sha1-H2-high 256))
 380             (aset result 10 (/ sha1-H2-low  256))
 381             (aset result 11 (% sha1-H2-low  256))
 382             (aset result 12 (/ sha1-H3-high 256))
 383             (aset result 13 (% sha1-H3-high 256))
 384             (aset result 14 (/ sha1-H3-low  256))
 385             (aset result 15 (% sha1-H3-low  256))
 386             (aset result 16 (/ sha1-H4-high 256))
 387             (aset result 17 (% sha1-H4-high 256))
 388             (aset result 18 (/ sha1-H4-low  256))
 389             (aset result 19 (% sha1-H4-low  256))
 390             result))
 391       ;; do not leave a copy of input string.
 392       (fillarray block-high nil)
 393       (fillarray block-low  nil))))
 394
 395 (defun sha1-string-internal (string)
 396   (encode-hex-string (sha1-binary string)))
 397
 398 (defun sha1-region-internal (beg end)
 399   (sha1-string-internal (buffer-substring-no-properties beg end)))
 400
 401 ;;;
 402 ;;; application interface.
 403 ;;;
 404
 405 (defun sha1-region (beg end)
 406   (if (and sha1-use-external
 407            sha1-maximum-internal-length
 408            (> (abs (- end beg)) sha1-maximum-internal-length))
 409       (sha1-region-external beg end)
 410     (sha1-region-internal beg end)))
 411
 412 (defun sha1-string (string)
 413   (if (and sha1-use-external
 414            sha1-maximum-internal-length
 415            (> (length string) sha1-maximum-internal-length))
 416       (sha1-string-external string)
 417     (sha1-string-internal string)))
 418
 419 (defun sha1 (object &optional beg end)
 420   "Return the SHA1 (Secure Hash Algorithm) of an object.
 421 OBJECT is either a string or a buffer.
 422 Optional arguments BEG and END denote buffer positions for computing the
 423 hash of a portion of OBJECT."
 424   (if (stringp object)
 425       (sha1-string object)
 426     (save-excursion
 427       (set-buffer object)
 428       (sha1-region (or beg (point-min)) (or end (point-max))))))
 429
 430 (provide 'sha1-el)
 431
 432 ;;; sha1-el.el ends here