;;;  sha1-old.el -- SHA-1 message digest algorithm

;; Copyright (C) 1998 Ray Jones

;; Author: Ray Jones, rjones@pobox.com
;; Keywords: SHA, SHA-1, message digest
;; Created: 1998-04-27

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.

;;; Commentary:

;; this is a slower, more clear, version of sha1.el.  it's based on
;; md5-old.el, since much of the code is similar.  however, SHA-1 is
;; different than MD5 in that MD5 treats the input bits as MSB-first
;; bitwise but LSB-first bytewise, but SHA-1 treats the data as
;; MSB-first both bit- and byte-wise.

;;; Code:
(require 'cl)

(defun sha1 (string)
  "return the sha1 hash of a string, as a 128 bit string"
  (let* ((length (length string))
	 ;; sha1 requires the message be padded to a length of 512*k +
	 ;; 64 (bits).  confusion source: we're working with bytes.
	 ;;
	 ;; padding is always done.
	 ;; 512 bits = 64 bytes, 64 bits = 8 bytes
	 (next-512 (+ 64 (logand (+ length 8) (lognot 63))))
	 (pad-bytes (- next-512 length 8))
	 (pad-string (make-string pad-bytes 0))
	 (len-string (make-string 8 0)))
    ;; message is constructed as:
    ;; original-message | pad | length-in-bits
    ;; pad is 10000... (bitwise)
    ;; length-in-bits is length before padding, and is 64 bits long

    ;; fill in the single bit of the pad
    (aset pad-string 0 (ash 1 7))

    ;; there's a slim chance of overflow when multiplying the length
    ;; by 8 to get the length in bits.  to avoid this, do some
    ;; slightly hairier math when writing the length into len-string.

    (dotimes (idx 4)
      (aset len-string (+ 4 idx) (logand #xff
				   (ash length (+ -21 (* 8 idx))))))

    (sha1-vector
     (sha1-string-to-32bit-vec
      (concat string pad-string len-string)))))

(defun sha1-string-to-32bit-vec (string)
  ;; emacs doesn't actually have 32 bits, in most implementations.
  ;; 32 bit numbers are represented as a pair of 16 bit numbers

  ;; 4 chars per 32 bit number, MSB-first
  (let* ((veclen (/ (length string) 4))
	 (vec (make-vector veclen nil))
	 (stridx 0))
    (dotimes (vecidx veclen)
      ;; SHA-1 integers are (hi . lo) 16 bit words
      (aset vec vecidx (cons (+ (ash (aref string (+ stridx 0)) 8)
				(aref string (+ stridx 1)))
			     (+ (ash (aref string (+ stridx 2)) 8)
				(aref string (+ stridx 3)))))
      (incf stridx 4))

    vec))

;; f for rounds 0-19
(defsubst sha1-f1-2 (x y z)
  (logior (logand x y)
	  (logand (lognot x)
		  z)))

;; f for rounds 20-39 and 60-79
(defsubst sha1-f2&4-2 (x y z)
  (logxor x y z))

; f for rounds 40-59
(defsubst sha1-f3-2 (x y z)
  (logior (logand x y)
	  (logand y z)
	  (logand x z)))


(defsubst sha1-f1 (x y z)
  (cons (sha1-f1-2 (car x) (car y) (car z))
	(sha1-f1-2 (cdr x) (cdr y) (cdr z))))

(defsubst sha1-f2&4 (x y z)
  (cons (sha1-f2&4-2 (car x) (car y) (car z))
	(sha1-f2&4-2 (cdr x) (cdr y) (cdr z))))

(defsubst sha1-f3 (x y z)
  (cons (sha1-f3-2 (car x) (car y) (car z))
	(sha1-f3-2 (cdr x) (cdr y) (cdr z))))

(defsubst sha1<<< (val shift)
  "circular shift sha1 32 bit int VAL by 1 bit"
  (let ((a (car val))
	(b (cdr val)))
    ;; only three cases ever occur
    (cond ((= shift 1) (cons (logand #xffff (logior (ash a 1) (ash b -15)))
			     (logand #xffff (logior (ash b 1) (ash a -15)))))
	  ((= shift 5) (cons (logand #xffff (logior (ash a 5) (ash b -11)))
			     (logand #xffff (logior (ash b 5) (ash a -11)))))
	  ;; shift = 30, which is a swap and a shift by 14
	  (t (cons (logand #xffff (logior (ash b 14) (ash a -2)))
		   (logand #xffff (logior (ash a 14) (ash b -2))))))))

(defsubst sha1+ (&rest args)
  ;; since we only use 16 bits, there's enough room to just add
  ;; without carry checks for each add.
  (let* ((lo (apply #'+ (mapcar #'cdr args)))
	 (hi (+ (ash lo -16) (apply #'+ (mapcar #'car args)))))
    (cons (logand #xffff hi)
	  (logand #xffff lo))))

(defsubst sha1-logxor4 (a b c d)
  (cons (logxor (car a) (car b) (car c) (car d))
	(logxor (cdr a) (cdr b) (cdr c) (cdr d))))

(defmacro sha1-rewrite (fun k)
  "helper function for sha1-vector, below.  ugly coding practice,
having a macro-rewriter elsewhere, but the indentation was getting a
bit out of control.
NB: many variables must be defined at the calling point!"
  `(let ((temp (sha1+ (sha1<<< a 5)
		      ,(list fun 'b 'c 'd)
		      e
		      (aref w w-idx)
		      ,k)))
     (setq e d
	   d c
	   c (sha1<<< b 30)
	   b a
	   a temp)
     (incf w-idx)))


(defun sha1-vector (vec)
  ;; initialize the chaining variables
  (let ((a (cons #x6745 #x2301))
	(b (cons #xefcd #xab89))
	(c (cons #x98ba #xdcfe))
	(d (cons #x1032 #x5476))
	(e (cons #xc3d2 #xe1f0))
	(w (make-vector 80 0))
	(v-offset 0))

    (dotimes (count (/ (length vec) 16))
      ;; initialize w
      (dotimes (idx 16)
	(aset w idx (aref vec (+ v-offset idx))))
      
      ;; fill in the rest of w
      (do ((idx 16 (1+ idx)))
	  ((= idx 80))
	(aset w idx (sha1<<< (sha1-logxor4 (aref w (- idx 3))
					   (aref w (- idx 8))
					   (aref w (- idx 14))
					   (aref w (- idx 16)))
			    1)))

      (let ((AA a) (BB b) (CC c) (DD d) (EE e)
	    (w-idx 0))

	(dotimes (count 20)
;;	  (insert (format "%s %s %s %s %s\n"
;;			  a b c d e))
	  (sha1-rewrite sha1-f1 '(#x5a82 . #x7999)))

	(dotimes (count 20)
	  (sha1-rewrite sha1-f2&4 '(#x6ed9 . #xeba1)))

	(dotimes (count 20)
	  (sha1-rewrite sha1-f3 '(#x8f1b . #xbcdc)))

	(dotimes (count 20)
	  (sha1-rewrite sha1-f2&4 '(#xca62 . #xc1d6)))

	(setq a (sha1+ AA a)
	      b (sha1+ BB b)
	      c (sha1+ CC c)
	      d (sha1+ DD d)
	      e (sha1+ EE e)))

      (incf v-offset 16))

    ;; write out the concatenation of the state
    (mapconcat #'(lambda (x) (format "%04x" x))
	       (list (car a) (cdr a)
		     (car b) (cdr b)
		     (car c) (cdr c)
		     (car d) (cdr d)
		     (car e) (cdr e))
	       "")))

(provide 'sha1)