Projects : gbw-signer : gbw-signer_genesis
| 1 | ;;;; Cryptographic hash functions in pure Scheme |
| 2 | ;;; J. Welsh, November 2017 - May 2018 |
| 3 | ;;; Trimmed for gbw, March 2020 |
| 4 | |
| 5 | (lambda (fz-ops) |
| 6 | (define word->ufz (fz-ops 'word->ufz)) |
| 7 | (define ufz+ (fz-ops 'ufz+)) |
| 8 | (define ufzshift (fz-ops 'ufzshift)) |
| 9 | (define fzrot (fz-ops 'fzrot)) |
| 10 | (define fznot (fz-ops 'fznot)) |
| 11 | (define fzior (fz-ops 'fzior)) |
| 12 | (define fzxor (fz-ops 'fzxor)) |
| 13 | (define fzif (fz-ops 'fzif)) |
| 14 | (define fzmaj (fz-ops 'fzmaj)) |
| 15 | (define bytes->fz (fz-ops 'bytes->fz)) |
| 16 | (define fz->bytes (fz-ops 'fz->bytes)) |
| 17 | (define hex->bytes (fz-ops 'hex->bytes)) |
| 18 | (define hex->fz (fz-ops 'hex->fz)) |
| 19 | |
| 20 | (define (compose f g) (lambda (x) (f (g x)))) |
| 21 | |
| 22 | (define null-byte (integer->char 0)) |
| 23 | (define initial-padding (string (integer->char 128))) |
| 24 | |
| 25 | ;; The Merkle-Damgard construction: turns a fixed size compression function into an arbitrary size hash function, by blockwise iteration with padding and length hardening. For simplicity, this implementation requires the full message to fit in a string. |
| 26 | (define (merkle-damgard block-size length-bits big-endian compress offset iv) |
| 27 | (define (finish hash tail packed-bit-length) |
| 28 | (let ((length-size (string-length packed-bit-length)) |
| 29 | (space (- block-size (string-length tail)))) |
| 30 | (if (< space length-size) |
| 31 | (finish (compress hash (string-append |
| 32 | tail (make-string space null-byte))) |
| 33 | "" packed-bit-length) |
| 34 | (compress hash (string-append |
| 35 | ;; assuming length goes at end of block |
| 36 | tail (make-string (- space length-size) null-byte) |
| 37 | packed-bit-length))))) |
| 38 | (lambda (msg) |
| 39 | (let ((len (string-length msg))) |
| 40 | (do ((pos 0 next) |
| 41 | (next block-size (+ next block-size)) |
| 42 | (hash iv (compress hash (substring msg pos next)))) |
| 43 | ((> next len) |
| 44 | (finish hash |
| 45 | (string-append (substring msg pos len) initial-padding) |
| 46 | (fz->bytes (ufzshift (ufz+ (word->ufz length-bits len) |
| 47 | (word->ufz length-bits offset)) |
| 48 | 3) |
| 49 | big-endian))))))) |
| 50 | |
| 51 | (define (append-hex->bytes . args) |
| 52 | (apply string-append (map hex->bytes args))) |
| 53 | (define (hex->fz-vec . args) |
| 54 | (list->vector (map hex->fz args))) |
| 55 | |
| 56 | ;; Load aligned word from byte string, little/big endian |
| 57 | (define (slice s k len) (substring s k (+ k len))) |
| 58 | (define (loadw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #f)) |
| 59 | (define (loadbw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #t)) |
| 60 | |
| 61 | ;; Pack words as byte string, little/big endian |
| 62 | (define (pack-words w) |
| 63 | (apply string-append (map (lambda (w) (fz->bytes w #f)) w))) |
| 64 | (define (packb-words w) |
| 65 | (apply string-append (map (lambda (w) (fz->bytes w #t)) w))) |
| 66 | |
| 67 | ;; The various "sigma" functions from [SHS] for 256-bit hashes |
| 68 | (define (ss0-32 x) (fzxor (fzrot x -2) (fzrot x -13) (fzrot x -22))) |
| 69 | (define (ss1-32 x) (fzxor (fzrot x -6) (fzrot x -11) (fzrot x -25))) |
| 70 | (define (s0-32 x) (fzxor (fzrot x -7) (fzrot x -18) (ufzshift x -3))) |
| 71 | (define (s1-32 x) (fzxor (fzrot x -17) (fzrot x -19) (ufzshift x -10))) |
| 72 | |
| 73 | (let ((rmd160-iv (append-hex->bytes |
| 74 | "01234567" "89abcdef" "fedcba98" "76543210" "f0e1d2c3")) |
| 75 | ;; First 32 fractional bits of square roots of first 8 primes |
| 76 | (sha256-iv (append-hex->bytes |
| 77 | "6a09e667" "bb67ae85" |
| 78 | "3c6ef372" "a54ff53a" |
| 79 | "510e527f" "9b05688c" |
| 80 | "1f83d9ab" "5be0cd19"))) |
| 81 | |
| 82 | (define rmd160-compress |
| 83 | (letrec ((F fzxor) |
| 84 | (G fzif) |
| 85 | (H (lambda (x y z) (fzxor (fzior (fznot y) x) z))) |
| 86 | (I (lambda (x y z) (G z x y))) |
| 87 | (J (lambda (x y z) (H y z x))) |
| 88 | (FF (lambda (a b c d e x s) |
| 89 | (ufz+ (fzrot (ufz+ a (F b c d) x) s) e))) |
| 90 | (make-op (lambda (func const) |
| 91 | (let ((k (hex->fz const))) |
| 92 | (lambda (a b c d e x s) |
| 93 | (ufz+ (fzrot (ufz+ a (func b c d) x k) s) e)))))) |
| 94 | ;; Floor of 2^30 times square and cube roots of (2 3 5 7) |
| 95 | (let ((ops1 (vector FF |
| 96 | (make-op G "5a827999") |
| 97 | (make-op H "6ed9eba1") |
| 98 | (make-op I "8f1bbcdc") |
| 99 | (make-op J "a953fd4e"))) |
| 100 | (ops2 (vector (make-op J "50a28be6") |
| 101 | (make-op I "5c4dd124") |
| 102 | (make-op H "6d703ef3") |
| 103 | (make-op G "7a6d76e9") |
| 104 | FF)) |
| 105 | (rho (lambda (i) |
| 106 | (vector-ref '#(7 4 13 1 10 6 15 3 12 0 9 5 2 14 11 8) i))) |
| 107 | (pi (lambda (i) (fxand (+ (* 9 i) 5) 15))) |
| 108 | (shifts '#(#(11 14 15 12 5 8 7 9 11 13 14 15 6 7 9 8) |
| 109 | #(12 13 11 15 6 9 9 7 12 15 11 13 7 8 7 7) |
| 110 | #(13 15 14 11 7 7 6 8 13 14 13 12 5 5 6 9) |
| 111 | #(14 11 12 14 8 6 5 5 15 12 15 14 9 9 8 6) |
| 112 | #(15 12 13 13 9 5 8 6 14 11 12 11 8 6 5 5))) |
| 113 | (W1 (make-vector 80)) |
| 114 | (W2 (make-vector 80))) |
| 115 | (do ((t 0 (+ t 1))) ((= t 16)) |
| 116 | (vector-set! W1 t t) |
| 117 | (vector-set! W2 t (pi t))) |
| 118 | (do ((t 16 (+ t 1))) ((= t 80)) |
| 119 | (vector-set! W1 t (rho (vector-ref W1 (- t 16)))) |
| 120 | (vector-set! W2 t (rho (vector-ref W2 (- t 16))))) |
| 121 | |
| 122 | (lambda (hash block) |
| 123 | (let ((h0 (loadw32 hash 0)) |
| 124 | (h1 (loadw32 hash 1)) |
| 125 | (h2 (loadw32 hash 2)) |
| 126 | (h3 (loadw32 hash 3)) |
| 127 | (h4 (loadw32 hash 4)) |
| 128 | (X (make-vector 16))) |
| 129 | (do ((t 0 (+ t 1))) ((= t 16)) |
| 130 | (vector-set! X t (loadw32 block t))) |
| 131 | (let loop ((t 0) (a1 h0) (b1 h1) (c1 h2) (d1 h3) (e1 h4) |
| 132 | (a2 h0) (b2 h1) (c2 h2) (d2 h3) (e2 h4)) |
| 133 | (if (= t 80) |
| 134 | (pack-words (map ufz+ (list h1 h2 h3 h4 h0) |
| 135 | (list c1 d1 e1 a1 b1) |
| 136 | (list d2 e2 a2 b2 c2))) |
| 137 | (let ((round (fxshift/unsigned t -4))) |
| 138 | (let ((shifts (vector-ref shifts round)) |
| 139 | (op1 (vector-ref ops1 round)) |
| 140 | (op2 (vector-ref ops2 round)) |
| 141 | (i1 (vector-ref W1 t)) |
| 142 | (i2 (vector-ref W2 t))) |
| 143 | (loop (+ t 1) |
| 144 | e1 (op1 a1 b1 c1 d1 e1 (vector-ref X i1) |
| 145 | (vector-ref shifts i1)) |
| 146 | b1 (fzrot c1 10) d1 |
| 147 | e2 (op2 a2 b2 c2 d2 e2 (vector-ref X i2) |
| 148 | (vector-ref shifts i2)) |
| 149 | b2 (fzrot c2 10) d2)))))))))) |
| 150 | |
| 151 | (define sha256-compress |
| 152 | ;; First 32 fractional bits of cube roots of first 64 primes |
| 153 | (let ((K (hex->fz-vec |
| 154 | "428a2f98" "71374491" "b5c0fbcf" "e9b5dba5" |
| 155 | "3956c25b" "59f111f1" "923f82a4" "ab1c5ed5" |
| 156 | "d807aa98" "12835b01" "243185be" "550c7dc3" |
| 157 | "72be5d74" "80deb1fe" "9bdc06a7" "c19bf174" |
| 158 | "e49b69c1" "efbe4786" "0fc19dc6" "240ca1cc" |
| 159 | "2de92c6f" "4a7484aa" "5cb0a9dc" "76f988da" |
| 160 | "983e5152" "a831c66d" "b00327c8" "bf597fc7" |
| 161 | "c6e00bf3" "d5a79147" "06ca6351" "14292967" |
| 162 | "27b70a85" "2e1b2138" "4d2c6dfc" "53380d13" |
| 163 | "650a7354" "766a0abb" "81c2c92e" "92722c85" |
| 164 | "a2bfe8a1" "a81a664b" "c24b8b70" "c76c51a3" |
| 165 | "d192e819" "d6990624" "f40e3585" "106aa070" |
| 166 | "19a4c116" "1e376c08" "2748774c" "34b0bcb5" |
| 167 | "391c0cb3" "4ed8aa4a" "5b9cca4f" "682e6ff3" |
| 168 | "748f82ee" "78a5636f" "84c87814" "8cc70208" |
| 169 | "90befffa" "a4506ceb" "bef9a3f7" "c67178f2"))) |
| 170 | (lambda (hash block) |
| 171 | (let ((W (make-vector 64)) |
| 172 | (h0 (loadbw32 hash 0)) (h1 (loadbw32 hash 1)) |
| 173 | (h2 (loadbw32 hash 2)) (h3 (loadbw32 hash 3)) |
| 174 | (h4 (loadbw32 hash 4)) (h5 (loadbw32 hash 5)) |
| 175 | (h6 (loadbw32 hash 6)) (h7 (loadbw32 hash 7))) |
| 176 | (do ((t 0 (+ t 1))) ((= t 16)) |
| 177 | (vector-set! W t (loadbw32 block t))) |
| 178 | (do ((t 16 (+ t 1))) ((= t 64)) |
| 179 | (vector-set! W t (ufz+ (s1-32 (vector-ref W (- t 2))) |
| 180 | (vector-ref W (- t 7)) |
| 181 | (s0-32 (vector-ref W (- t 15))) |
| 182 | (vector-ref W (- t 16))))) |
| 183 | (let loop ((t 0) (a h0) (b h1) (c h2) (d h3) (e h4) (f h5) (g h6) |
| 184 | (h h7)) |
| 185 | (if (= t 64) |
| 186 | (packb-words (map ufz+ (list a b c d e f g h) |
| 187 | (list h0 h1 h2 h3 h4 h5 h6 h7))) |
| 188 | (let* ((temp1 (ufz+ (ss1-32 e) |
| 189 | (fzif e f g) |
| 190 | h |
| 191 | (vector-ref K t) |
| 192 | (vector-ref W t))) |
| 193 | (temp2 (ufz+ (ss0-32 a) |
| 194 | (fzmaj a b c) |
| 195 | temp1))) |
| 196 | (loop (+ t 1) temp2 a b c (ufz+ d temp1) e f g)))))))) |
| 197 | |
| 198 | (let ((ripemd160 (merkle-damgard 64 64 #f rmd160-compress 0 rmd160-iv)) |
| 199 | (sha256 (merkle-damgard 64 64 #t sha256-compress 0 sha256-iv))) |
| 200 | (export ripemd160 sha256)))) |
| 201 | |
| 202 | ;;; References |
| 203 | |
| 204 | ;; H. Dobbertin, A. Bosselaers, B. Preneel 1996. "RIPEMD-160: A Strengthened Version of RIPEMD." http://homes.esat.kuleuven.be/bosselae/ripemd160/pdf/AB-9601/AB-9601.pdf |
| 205 | ;; [SHS] Information Technology Laboratory 2015. "FIPS PUB 180-4: Secure Hash Standard." National Institute of Standards and Technology. http://dx.doi.org/10.6028/NIST.FIPS.180-4 |