cgit.sxemacs.org Git - packages/blob - xemacs-packages/ecrypto/sha1-old.el

   1 ;;;  sha1-old.el -- SHA-1 message digest algorithm
   2
   3 ;; Copyright (C) 1998 Ray Jones
   4
   5 ;; Author: Ray Jones, rjones@pobox.com
   6 ;; Keywords: SHA, SHA-1, message digest
   7 ;; Created: 1998-04-27
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; if not, you can either send email to this
  21 ;; program's maintainer or write to: The Free Software Foundation,
  22 ;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; this is a slower, more clear, version of sha1.el.  it's based on
  27 ;; md5-old.el, since much of the code is similar.  however, SHA-1 is
  28 ;; different than MD5 in that MD5 treats the input bits as MSB-first
  29 ;; bitwise but LSB-first bytewise, but SHA-1 treats the data as
  30 ;; MSB-first both bit- and byte-wise.
  31
  32 ;;; Code:
  33 (require 'cl)
  34
  35 (defun sha1 (string)
  36   "return the sha1 hash of a string, as a 128 bit string"
  37   (let* ((length (length string))
  38          ;; sha1 requires the message be padded to a length of 512*k +
  39          ;; 64 (bits).  confusion source: we're working with bytes.
  40          ;;
  41          ;; padding is always done.
  42          ;; 512 bits = 64 bytes, 64 bits = 8 bytes
  43          (next-512 (+ 64 (logand (+ length 8) (lognot 63))))
  44          (pad-bytes (- next-512 length 8))
  45          (pad-string (make-string pad-bytes 0))
  46          (len-string (make-string 8 0)))
  47     ;; message is constructed as:
  48     ;; original-message | pad | length-in-bits
  49     ;; pad is 10000... (bitwise)
  50     ;; length-in-bits is length before padding, and is 64 bits long
  51
  52     ;; fill in the single bit of the pad
  53     (aset pad-string 0 (ash 1 7))
  54
  55     ;; there's a slim chance of overflow when multiplying the length
  56     ;; by 8 to get the length in bits.  to avoid this, do some
  57     ;; slightly hairier math when writing the length into len-string.
  58
  59     (dotimes (idx 4)
  60       (aset len-string (+ 4 idx) (logand #xff
  61                                    (ash length (+ -21 (* 8 idx))))))
  62
  63     (sha1-vector
  64      (sha1-string-to-32bit-vec
  65       (concat string pad-string len-string)))))
  66
  67 (defun sha1-string-to-32bit-vec (string)
  68   ;; emacs doesn't actually have 32 bits, in most implementations.
  69   ;; 32 bit numbers are represented as a pair of 16 bit numbers
  70
  71   ;; 4 chars per 32 bit number, MSB-first
  72   (let* ((veclen (/ (length string) 4))
  73          (vec (make-vector veclen nil))
  74          (stridx 0))
  75     (dotimes (vecidx veclen)
  76       ;; SHA-1 integers are (hi . lo) 16 bit words
  77       (aset vec vecidx (cons (+ (ash (aref string (+ stridx 0)) 8)
  78                                 (aref string (+ stridx 1)))
  79                              (+ (ash (aref string (+ stridx 2)) 8)
  80                                 (aref string (+ stridx 3)))))
  81       (incf stridx 4))
  82
  83     vec))
  84
  85 ;; f for rounds 0-19
  86 (defsubst sha1-f1-2 (x y z)
  87   (logior (logand x y)
  88           (logand (lognot x)
  89                   z)))
  90
  91 ;; f for rounds 20-39 and 60-79
  92 (defsubst sha1-f2&4-2 (x y z)
  93   (logxor x y z))
  94
  95 ; f for rounds 40-59
  96 (defsubst sha1-f3-2 (x y z)
  97   (logior (logand x y)
  98           (logand y z)
  99           (logand x z)))
 100
 101
 102 (defsubst sha1-f1 (x y z)
 103   (cons (sha1-f1-2 (car x) (car y) (car z))
 104         (sha1-f1-2 (cdr x) (cdr y) (cdr z))))
 105
 106 (defsubst sha1-f2&4 (x y z)
 107   (cons (sha1-f2&4-2 (car x) (car y) (car z))
 108         (sha1-f2&4-2 (cdr x) (cdr y) (cdr z))))
 109
 110 (defsubst sha1-f3 (x y z)
 111   (cons (sha1-f3-2 (car x) (car y) (car z))
 112         (sha1-f3-2 (cdr x) (cdr y) (cdr z))))
 113
 114 (defsubst sha1<<< (val shift)
 115   "circular shift sha1 32 bit int VAL by 1 bit"
 116   (let ((a (car val))
 117         (b (cdr val)))
 118     ;; only three cases ever occur
 119     (cond ((= shift 1) (cons (logand #xffff (logior (ash a 1) (ash b -15)))
 120                              (logand #xffff (logior (ash b 1) (ash a -15)))))
 121           ((= shift 5) (cons (logand #xffff (logior (ash a 5) (ash b -11)))
 122                              (logand #xffff (logior (ash b 5) (ash a -11)))))
 123           ;; shift = 30, which is a swap and a shift by 14
 124           (t (cons (logand #xffff (logior (ash b 14) (ash a -2)))
 125                    (logand #xffff (logior (ash a 14) (ash b -2))))))))
 126
 127 (defsubst sha1+ (&rest args)
 128   ;; since we only use 16 bits, there's enough room to just add
 129   ;; without carry checks for each add.
 130   (let* ((lo (apply #'+ (mapcar #'cdr args)))
 131          (hi (+ (ash lo -16) (apply #'+ (mapcar #'car args)))))
 132     (cons (logand #xffff hi)
 133           (logand #xffff lo))))
 134
 135 (defsubst sha1-logxor4 (a b c d)
 136   (cons (logxor (car a) (car b) (car c) (car d))
 137         (logxor (cdr a) (cdr b) (cdr c) (cdr d))))
 138
 139 (defmacro sha1-rewrite (fun k)
 140   "helper function for sha1-vector, below.  ugly coding practice,
 141 having a macro-rewriter elsewhere, but the indentation was getting a
 142 bit out of control.
 143 NB: many variables must be defined at the calling point!"
 144   `(let ((temp (sha1+ (sha1<<< a 5)
 145                       ,(list fun 'b 'c 'd)
 146                       e
 147                       (aref w w-idx)
 148                       ,k)))
 149      (setq e d
 150            d c
 151            c (sha1<<< b 30)
 152            b a
 153            a temp)
 154      (incf w-idx)))
 155
 156
 157 (defun sha1-vector (vec)
 158   ;; initialize the chaining variables
 159   (let ((a (cons #x6745 #x2301))
 160         (b (cons #xefcd #xab89))
 161         (c (cons #x98ba #xdcfe))
 162         (d (cons #x1032 #x5476))
 163         (e (cons #xc3d2 #xe1f0))
 164         (w (make-vector 80 0))
 165         (v-offset 0))
 166
 167     (dotimes (count (/ (length vec) 16))
 168       ;; initialize w
 169       (dotimes (idx 16)
 170         (aset w idx (aref vec (+ v-offset idx))))
 171
 172       ;; fill in the rest of w
 173       (do ((idx 16 (1+ idx)))
 174           ((= idx 80))
 175         (aset w idx (sha1<<< (sha1-logxor4 (aref w (- idx 3))
 176                                            (aref w (- idx 8))
 177                                            (aref w (- idx 14))
 178                                            (aref w (- idx 16)))
 179                             1)))
 180
 181       (let ((AA a) (BB b) (CC c) (DD d) (EE e)
 182             (w-idx 0))
 183
 184         (dotimes (count 20)
 185 ;;        (insert (format "%s %s %s %s %s\n"
 186 ;;                        a b c d e))
 187           (sha1-rewrite sha1-f1 '(#x5a82 . #x7999)))
 188
 189         (dotimes (count 20)
 190           (sha1-rewrite sha1-f2&4 '(#x6ed9 . #xeba1)))
 191
 192         (dotimes (count 20)
 193           (sha1-rewrite sha1-f3 '(#x8f1b . #xbcdc)))
 194
 195         (dotimes (count 20)
 196           (sha1-rewrite sha1-f2&4 '(#xca62 . #xc1d6)))
 197
 198         (setq a (sha1+ AA a)
 199               b (sha1+ BB b)
 200               c (sha1+ CC c)
 201               d (sha1+ DD d)
 202               e (sha1+ EE e)))
 203
 204       (incf v-offset 16))
 205
 206     ;; write out the concatenation of the state
 207     (mapconcat #'(lambda (x) (format "%04x" x))
 208                (list (car a) (cdr a)
 209                      (car b) (cdr b)
 210                      (car c) (cdr c)
 211                      (car d) (cdr d)
 212                      (car e) (cdr e))
 213                "")))
 214
 215 (provide 'sha1)