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