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