#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do whirlpool-sum)' -s $0 "$@" # -*- scheme -*-
!#
;;; whirlpool-sum

;; Copyright (C) 2005, 2007, 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: whirlpool-sum [ -c CHECKFILE | FILE... ]
;;
;; If given a list of filenames, for each FILE, display the digest
;; (128 hex digits corresponding to 64 bytes) followed by two spaces
;; followed by the filename and newline.  For example (backslash and
;; newline added for readability):
;;
;; $ whirlpool-sum COPYING
;; 9e4bbb1ab48b0df77d0f5df1229a5c6314f0d65c4c96bcf7cbd870fd03\
;; 97036664eaea9c7318285f82ad7715473b1298c36735cebeb0a04d8a65\
;; ad9b31106bd1  COPYING
;;
;; If given ‘-c CHECKFILE’, read CHECKFILE and check the sums of
;; the files listed therein.  On mismatch, display the message
;; "Whirlpool check failed for 'FILENAME'" to the stderr.
;;
;; The Whirlpool algorithm was developed by
;;   Paulo S. L. M. Barreto (pbarreto@scopus.com.br) and
;;   Vincent Rijmen (vincent.rijmen@cryptomathic.com).
;;
;; P.S.L.M. Barreto, V. Rijmen,
;; ``The Whirlpool hashing function,''
;; First NESSIE workshop, 2000 (tweaked version, 2003),
;; http://www.larc.usp.br/~pbarreto/whirlpool.zip
;;
;; This program implements version 3.0 (2003.03.12) of the algorithm.

;;; Code:

(define-module (ttn-do whirlpool-sum)
  #:export (string-digest file-digest main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ice-9 format) #:select (format))
  #:use-module ((ttn-do mogrify) #:select (find-file-read-only
                                           editing-buffer))
  #:use-module ((ttn-do zzz personally) #:select (FE)))

(define v: vector-ref)
(define v! vector-set!)

(define (b3b n)                         ; bottom 3 bits
  (logand n #x7))

(define (byte n)
  (logand n #xff))

(define (long n)
  (logand n #xffffffffffffffff))

(define (lsr64 n count)
  (ash n (- count)))

(define (blsr n shift)
  (byte (lsr64 n shift)))

(define (v8<- to from)
  (vector-move-left! from 0 8 to 0))

(define (apply-map2-proc op proc)
  (lambda (ls-a ls-b)
    (apply op (map proc ls-a ls-b))))

(define xor*ash (apply-map2-proc logxor ash))

(define INC-BY-1-FROM-0 (iota 8))
(define DEC-BY-8-FROM-56 (map (lambda (n) (- 56 (* 8 n))) INC-BY-1-FROM-0))

(define DIGESTBITS
  ;; The message digest size (in bits).
  512)

(define DIGESTBYTES
  ;; The message digest size (in bytes).
  (ash DIGESTBITS -3))

(define R
  ;; The number of rounds of the internal dedicated block cipher.
  10)

(define sbox
  ;; The substitution box.
  #(#x18 #x23 #xc6 #xE8 #x87 #xB8 #x01 #x4F #x36 #xA6 #xd2 #xF5
         #x79 #x6F #x91 #x52 #x60 #xBc #x9B #x8E #xA3 #x0c #x7B
         #x35 #x1d #xE0 #xd7 #xc2 #x2E #x4B #xFE #x57 #x15 #x77
         #x37 #xE5 #x9F #xF0 #x4A #xdA #x58 #xc9 #x29 #x0A #xB1
         #xA0 #x6B #x85 #xBd #x5d #x10 #xF4 #xcB #x3E #x05 #x67
         #xE4 #x27 #x41 #x8B #xA7 #x7d #x95 #xd8 #xFB #xEE #x7c
         #x66 #xdd #x17 #x47 #x9E #xcA #x2d #xBF #x07 #xAd #x5A
         #x83 #x33 #x63 #x02 #xAA #x71 #xc8 #x19 #x49 #xd9 #xF2
         #xE3 #x5B #x88 #x9A #x26 #x32 #xB0 #xE9 #x0F #xd5 #x80
         #xBE #xcd #x34 #x48 #xFF #x7A #x90 #x5F #x20 #x68 #x1A
         #xAE #xB4 #x54 #x93 #x22 #x64 #xF1 #x73 #x12 #x40 #x08
         #xc3 #xEc #xdB #xA1 #x8d #x3d #x97 #x00 #xcF #x2B #x76
         #x82 #xd6 #x1B #xB5 #xAF #x6A #x50 #x45 #xF3 #x30 #xEF
         #x3F #x55 #xA2 #xEA #x65 #xBA #x2F #xc0 #xdE #x1c #xFd
         #x4d #x92 #x75 #x06 #x8A #xB2 #xE6 #x0E #x1F #x62 #xd4
         #xA8 #x96 #xF9 #xc5 #x25 #x59 #x84 #x72 #x39 #x4c #x5E
         #x78 #x38 #x8c #xd1 #xA5 #xE2 #x61 #xB3 #x21 #x9c #x1E
         #x43 #xc7 #xFc #x04 #x51 #x99 #x6d #x0d #xFA #xdF #x7E
         #x24 #x3B #xAB #xcE #x11 #x8F #x4E #xB7 #xEB #x3c #x81
         #x94 #xF7 #xB9 #x13 #x2c #xd3 #xE7 #x6E #xc4 #x03 #x56
         #x44 #x7F #xA9 #x2A #xBB #xc1 #x53 #xdc #x0B #x9d #x6c
         #x31 #x74 #xF6 #x46 #xAc #x89 #x14 #xE1 #x16 #x3A #x69
         #x09 #x70 #xB6 #xd0 #xEd #xcc #x42 #x98 #xA4 #x28 #x5c
         #xF8 #x86))

(define C
  ;; The circulant table.
  (let ((ra (make-array 1 8 256))
        (ior*ash (apply-map2-proc logior ash)))
    (define (maybe-11d n)
      (if (<= #x100 n)
          (logxor #x11d n)
          n))
    (define (?? a b)
      (array-ref ra a b))
    (define (!! a b v)
      (array-set! ra v a b))
    (do ((x 0 (1+ x)))
        ((= x 256))
      (let* ((v1 (v: sbox x))
             (v2 (maybe-11d (ash v1 1)))
             (v4 (maybe-11d (ash v2 1)))
             (v5 (logxor v4 v1))
             (v8 (maybe-11d (ash v4 1)))
             (v9 (logxor v8 v1)))
        ;; Build the circulant table C[0][x] = S[x].[1, 1, 4, 1, 8, 5, 2, 9].
        (!! 0 x (ior*ash (list v1 v1 v4 v1 v8 v5 v2 v9)
                         DEC-BY-8-FROM-56))
        ;; Build the remaining circulant tables C[t][x] = C[0][x] rotr t.
        (do ((t 1 (1+ t)))
            ((= t 8))
          (let ((prev (?? (1- t) x)))
            (!! t x (long (logior (lsr64 prev 8)
                                  (ash prev 56))))))))
    ra))

(define C-vv
  (let ((v0 (make-vector 8)))
    (array-index-map!
     v0 (lambda (i)
          (let ((v1 (make-vector 256)))
            (array-index-map!
             v1 (lambda (j)
                  (array-ref C i j)))
            v1)))
    v0))

(define rc
  ;; The round constants.
  (let ((vec (make-vector (1+ R) #f)))
    ;; Build the round constants.
    (v! vec 0 0)                        ; unused
    (do ((r 1 (1+ r)))
        ((= r (1+ R)))
      (let* ((i (* 8 (1- r)))
             (from-C (lambda (mask a)
                       (logand mask (array-ref C a (+ a i)))))
             (xor*from-C (apply-map2-proc logxor from-C)))
        (v! vec r (xor*from-C (map ash (make-list 8 #xff) DEC-BY-8-FROM-56)
                              INC-BY-1-FROM-0))))
    vec))

(define bit-length
  ;; Global number of hashed bits (256-bit counter).
  (make-vector 32))

(define buffer
  ;; Buffer of data to hash.
  (make-vector DIGESTBYTES))

(define nbits
  ;; Current number of bits on the buffer.
  0)

(define bufpos
  ;; Current (possibly incomplete) byte slot on the buffer.
  0)

;; The hashing state.
(define hash  (make-vector 8))
(define K     (make-vector 8))          ; the round key
(define L     (make-vector 8))
(define block (make-vector 8))          ; mu(buffer)
(define state (make-vector 8))          ; the cipher state

(define b3b-vv
  (let ((v0 (make-vector 8)))
    (array-index-map!
     v0 (lambda (i)
          (let ((v1 (make-vector 8)))
            (array-index-map!
             v1 (lambda (t)
                  (b3b (- i t))))
            v1)))
    v0))

(define v56down (list->vector DEC-BY-8-FROM-56))
(define v-iota  (list->vector INC-BY-1-FROM-0))

(define (process-buffer)
  ;; The core Whirlpool transform.

  ;; Map the buffer to a block.
  (array-index-map!
   block (lambda (i)
           (let ((j (ash i 3)))
             (xor*ash (map (lambda (n)
                             (v: buffer (+ n j)))
                           INC-BY-1-FROM-0)
                      DEC-BY-8-FROM-56))))
  ;; Compute and apply K^0 to the cipher state.
  (v8<- K hash)
  (array-index-map!
   state (lambda (i)
           (logxor (v: block i)
                   (v: K     i))))
  ;; Iterate over all rounds.
  (do ((r 1 (1+ r)))
      ((= (1+ R) r))
    ;; Compute K^r from K^{r-1}.
    (array-index-map!
     L (lambda (i)
         (let ((res 0))
           (array-for-each
            (lambda (C-row lo s)
              (set! res (logxor res (v: C-row (blsr (v: K lo) s)))))
            C-vv (v: b3b-vv i) v56down)
           res)))
    (v8<- K L)
    (v! K 0 (logxor (v: K  0)
                    (v: rc r)))
    ;; Apply the r-th round transformation.
    (v8<- L K)
    (array-index-map!
     L (lambda (i)
         (let ((res (v: L i)))
           (array-for-each
            (lambda (C-row lo s)
              (set! res (logxor res (v: C-row (blsr (v: state lo) s)))))
            C-vv (v: b3b-vv i) v56down)
           res)))
    (v8<- state L))
  ;; Apply the Miyaguchi-Preneel compression function.
  (array-index-map!
   hash (lambda (i)
          (logxor (v: hash i)
                  (v: state i)
                  (v: block i)))))

(define (init!)
  ;; Initialize the hashing state.
  (vector-fill! bit-length 0)
  (set! nbits 0)
  (set! bufpos 0)
  ;; It's only necessary to cleanup buffer[bufpos].
  (v! buffer 0 0)
  (vector-fill! hash 0))

(define (add! source srcbits)
  ;; Deliver input data to the hashing algorithm.
  ;;
  ;; source  -- plaintext data to hash.
  ;; srcbits -- how many bits of plaintext to process.
  ;;
  ;; This method maintains the invariant: (< nbits 512).
  ;;
  ;;                    srcpos
  ;;                    |
  ;;                    +-------+-------+-------
  ;;                       ||||||||||||||||||||| source
  ;;                    +-------+-------+-------
  ;; +-------+-------+-------+-------+-------+-------
  ;; ||||||||||||||||||||||                           buffer
  ;; +-------+-------+-------+-------+-------+-------
  ;;                 |
  ;;                 bufpos
  ;;
  (let* ((srcpos
          ;; Index of leftmost source byte containing data (1 to 8 bits).
          0)
         (gap
          ;; Space on source[srcpos].
          (b3b (- 8 (b3b srcbits))))
         (rem
          ;; Occupied bits on buffer[bufpos].
          (b3b nbits))
         (b #f)
         (value #f))
    ;; Tally the length of the added data.
    (set! value srcbits)
    (do ((i 31 (1- i)) (carry 0))
        ((not (and (>= i 0)
                   (or (not (zero? carry))
                       (not (zero? value))))))
      (set! carry (+ carry
                     (byte (v: bit-length i))
                     (byte value)))
      (v! bit-length i (byte carry))
      (set! carry (lsr64 carry 8))
      (set! value (lsr64 value 8)))
    ;; Process data in chunks of 8 bits.
    (let loop ()
      ;; At least source[srcpos] and source[srcpos+1] contain data.
      (and (< 8 srcbits)
           (begin
             ;; Take a byte from the source.
             (set! b (logior
                      (byte (ash (v: source srcpos) gap))
                      (ash (byte (v: source (1+ srcpos)))
                           (- gap 8))))
             (or (<= 0 b 255)
                 (error "LOGIC ERROR"))
             ;; Process this byte.
             (v! buffer bufpos (logior
                                (v: buffer bufpos)
                                (lsr64 b rem)))
             (set! bufpos (1+ bufpos))
             (set! nbits (+ nbits 8 (- rem)))
             (cond ((= DIGESTBITS nbits)
                    ;; Process data block.
                    (process-buffer)
                    ;; Reset buffer.
                    (set! nbits 0)
                    (set! bufpos 0)))
             (v! buffer bufpos (byte (ash b (- 8 rem))))
             (set! nbits (+ nbits rem))
             ;; Proceed to remaining data.
             (set! srcbits (- srcbits 8))
             (set! srcpos (1+ srcpos))
             (loop))))
    ;; Now 0 <= srcbits <= 8.
    ;; Furthermore, all data (if any is left) is in source[srcpos].
    (cond ((< 0 srcbits)
           ;; Bits are left-justified on b.
           (set! b (byte (ash (v: source srcpos) gap)))
           ;; Process the remaining bits.
           (v! buffer bufpos (logior
                              (v: buffer bufpos)
                              (lsr64 b rem))))
          (else
           (set! b 0)))
    (cond ((> 8 (+ rem srcbits))
           ;; All remaining data fits on buffer[bufpos],
           ;; and there still remains some space.
           (set! nbits (+ nbits srcbits)))
          (else
           ;; buffer[bufpos] is full.
           (set! bufpos (1+ bufpos))
           (set! nbits (+ nbits 8 (- rem)))
           (set! srcbits (+ srcbits -8 rem))
           ;; Now 0 <= srcbits < 8; furthermore,
           ;; all data is in source[srcpos].
           (cond ((= DIGESTBITS nbits)
                  ;; Process data block.
                  (process-buffer)
                  ;; Reset buffer.
                  (set! nbits 0)
                  (set! bufpos 0)))
           (v! buffer bufpos (byte (ash b (- 8 rem))))
           (set! nbits (+ nbits srcbits))))))

(define (finalize! digest)
  ;; Get the hash value from the hashing state.
  ;;
  ;; This method uses the invariant: (< nbits 512).

  ;; Append a '1'-bit.
  (v! buffer bufpos (logior
                     (v: buffer bufpos)
                     (lsr64 #x80 (b3b nbits))))
  ;; All remaining bits on the current byte are set to zero.
  (set! bufpos (1+ bufpos))
  ;; Pad with zero bits to complete (+ 256 (* 512 N)) bits.
  (cond ((< 32 bufpos)
         (let loop ()
           (and (> DIGESTBYTES bufpos)
                (begin
                  (v! buffer bufpos 0)
                  (set! bufpos (1+ bufpos))
                  (loop))))
         ;; Process data block.
         (process-buffer)
         ;; Reset buffer.
         (set! bufpos 0)))
  (let loop ()
    (and (> 32 bufpos)
         (begin
           (v! buffer bufpos 0)
           (set! bufpos (1+ bufpos))
           (loop))))
  ;; Append bit length of hashed data.
  (do ((i 0 (1+ i)))
      ((= 32 i))
    (v! buffer (+ i 32) (v: bit-length i)))
  ;; Process data block.
  (process-buffer)
  ;; Return the completed message digest.
  (do ((i 0 (1+ i)) (j 0 (+ 8 j)))
      ((= 8 i))
    (let ((h (v: hash i)))
      (vector-set! digest      j  (blsr h 56))
      (vector-set! digest (+ 1 j) (blsr h 48))
      (vector-set! digest (+ 2 j) (blsr h 40))
      (vector-set! digest (+ 3 j) (blsr h 32))
      (vector-set! digest (+ 4 j) (blsr h 24))
      (vector-set! digest (+ 5 j) (blsr h 16))
      (vector-set! digest (+ 6 j) (blsr h 8))
      (vector-set! digest (+ 7 j) (byte h)))))

(define (add!-string source)
  ;; Deliver string input data to the hashing algorithm.
  ;;
  ;; source -- plaintext data to hash (ASCII text string).
  ;;
  ;; This method maintains the invariant: (< nbits 512).
  ;;
  (let* ((len (string-length source))
         (data (make-vector len)))
    (array-index-map! data (lambda (x) (char->integer (string-ref source x))))
    (add! data (* 8 len))))

(define LONG-ITERATION 100000000)

(define (digest->string digest)
  (format #f "~{~:@(~2,'0X~)~}"
          (map (lambda (x)
                 (v: digest x))
               (iota DIGESTBYTES))))

(define (string<-digest digest)
  (format #f "~{~2,'0X~}" (vector->list digest)))

;; Compute the WHIRLPOOL digest of @var{string}.
;; Return a vector of length 64, with each element
;; a byte value (0--255), representing the digest.
;;
(define (string-digest string)
  (let ((digest (make-vector DIGESTBYTES)))
    (init!)
    (add!-string string)
    (finalize! digest)
    digest))

;; Return the @code{string-digest} of the contents of @var{filename}.
;;
(define (file-digest filename)
  (editing-buffer (find-file-read-only filename)
    (string-digest (buffer-string))))

(define (process-file filename)
  (format #t "~A  ~A~%"
          (string<-digest (file-digest filename))
          filename)
  (force-output))

(define (check checkfile)
  (editing-buffer (find-file-read-only checkfile)
    (while (re-search-forward "^([0-9a-f]+)  (.+)$" (point-max) #t)
      (let ((digest-s (match-string 1))
            (filename (match-string 2)))
        (and (file-exists? filename)
             (or (string=? (string<-digest (file-digest filename))
                           digest-s)
                 (format (current-error-port)
                         "~A: Whirlpool check failed for '~A'~%"
                         (basename (car (command-line)))
                         filename)))))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "2.1")
                   (help . commentary)))
  (let ((qop (qop<-args args '((check (value #t) (single-char #\c))))))
    (cond ((qop 'check check))
          ((null? (qop '()))
           (error "no input specified"))
          (else
           (FE (qop '()) process-file)))))

;;; whirlpool-sum ends here