;;;; Cryptographic hash functions in pure Scheme
;;; J. Welsh, November 2017 - May 2018

(lambda (fz-ops)
  (define word->ufz (fz-ops 'word->ufz))
  (define ufz+ (fz-ops 'ufz+))
  (define ufzshift (fz-ops 'ufzshift))
  (define fzrot (fz-ops 'fzrot))
  (define fznot (fz-ops 'fznot))
  (define fzior (fz-ops 'fzior))
  (define fzxor (fz-ops 'fzxor))
  (define fzif (fz-ops 'fzif))
  (define fzmaj (fz-ops 'fzmaj))
  (define bytes->fz (fz-ops 'bytes->fz))
  (define fz->bytes (fz-ops 'fz->bytes))
  (define hex->bytes (fz-ops 'hex->bytes))
  (define hex->fz (fz-ops 'hex->fz))

  (define (compose f g) (lambda (x) (f (g x))))

  (define null-byte (integer->char 0))
  (define initial-padding (string (integer->char 128)))

  ;; 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.
  (define (merkle-damgard block-size length-bits big-endian compress offset iv)
    (define (finish hash tail packed-bit-length)
      (let ((length-size (string-length packed-bit-length))
            (space (- block-size (string-length tail))))
        (if (< space length-size)
          (finish (compress hash (string-append
                                   tail (make-string space null-byte)))
                  "" packed-bit-length)
          (compress hash (string-append
                           ;; assuming length goes at end of block
                           tail (make-string (- space length-size) null-byte)
                           packed-bit-length)))))
    (lambda (msg)
      (let ((len (string-length msg)))
        (do ((pos 0 next)
             (next block-size (+ next block-size))
             (hash iv (compress hash (substring msg pos next))))
          ((> next len)
           (finish hash
                   (string-append (substring msg pos len) initial-padding)
                   (fz->bytes (ufzshift (ufz+ (word->ufz length-bits len)
                                              (word->ufz length-bits offset))
                                        3)
                              big-endian)))))))

  (define (hmac block-size)
    (define (pack x) (fz->bytes x #f))
    (define (unpack buf) (bytes->fz buf #f))
    (define (make-pad byte)
      (unpack (make-string block-size (integer->char byte))))
    (define (extend-key k)
      (let ((l (string-length k)))
        (if (> l block-size) (error "oversize key, must hash explicitly"))
        (string-append k (make-string (- block-size l) null-byte))))
    (let ((ipad (make-pad 54)) ;; 0x36
          (opad (make-pad 92))) ;; 0x5c
      (lambda (length-bits big-endian compress iv)
        (lambda (k)
          (let ((k (unpack (extend-key k))))
            (compose (merkle-damgard block-size length-bits big-endian compress
                                     block-size
                                     (compress iv (pack (fzxor k opad))))
                     (merkle-damgard block-size length-bits big-endian compress
                                     block-size
                                     (compress iv (pack (fzxor k ipad))))))))))

  (define (append-hex->bytes . args)
    (apply string-append (map hex->bytes args)))
  (define (hex->fz-vec . args)
    (list->vector (map hex->fz args)))

  ;; Load aligned word from byte string, little/big endian
  (define (slice s k len) (substring s k (+ k len)))
  (define (loadw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #f))
  (define (loadbw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #t))
  (define (loadbw64 s k) (bytes->fz (slice s (fxshift k 3) 8) #t))

  ;; Pack words as byte string, little/big endian
  (define (pack-words w)
    (apply string-append (map (lambda (w) (fz->bytes w #f)) w)))
  (define (packb-words w)
    (apply string-append (map (lambda (w) (fz->bytes w #t)) w)))

  ;; The various "sigma" functions from [SHS] for 256-bit hashes
  (define (ss0-32 x) (fzxor (fzrot x -2) (fzrot x -13) (fzrot x -22)))
  (define (ss1-32 x) (fzxor (fzrot x -6) (fzrot x -11) (fzrot x -25)))
  (define (s0-32 x) (fzxor (fzrot x -7) (fzrot x -18) (ufzshift x -3)))
  (define (s1-32 x) (fzxor (fzrot x -17) (fzrot x -19) (ufzshift x -10)))

  ;; The various "sigma" functions from [SHS] for 512-bit hashes
  (define (ss0-64 x) (fzxor (fzrot x -28) (fzrot x -34) (fzrot x -39)))
  (define (ss1-64 x) (fzxor (fzrot x -14) (fzrot x -18) (fzrot x -41)))
  (define (s0-64 x) (fzxor (fzrot x -1) (fzrot x -8) (ufzshift x -7)))
  (define (s1-64 x) (fzxor (fzrot x -19) (fzrot x -61) (ufzshift x -6)))

  (let ((rmd160-iv (append-hex->bytes
                     "01234567" "89abcdef" "fedcba98" "76543210" "f0e1d2c3"))
        (sha1-iv (append-hex->bytes
                   "67452301" "efcdab89" "98badcfe" "10325476" "c3d2e1f0"))
        ;; First 32 fractional bits of square roots of first 8 primes
        (sha256-iv (append-hex->bytes
                     "6a09e667" "bb67ae85"
                     "3c6ef372" "a54ff53a"
                     "510e527f" "9b05688c"
                     "1f83d9ab" "5be0cd19"))
        ;; First 64 fractional bits of square roots of first 8 primes
        (sha512-iv (append-hex->bytes
                     "6a09e667f3bcc908" "bb67ae8584caa73b"
                     "3c6ef372fe94f82b" "a54ff53a5f1d36f1"
                     "510e527fade682d1" "9b05688c2b3e6c1f"
                     "1f83d9abfb41bd6b" "5be0cd19137e2179")))

    (define rmd160-compress
      (letrec ((F fzxor)
               (G fzif)
               (H (lambda (x y z) (fzxor (fzior (fznot y) x) z)))
               (I (lambda (x y z) (G z x y)))
               (J (lambda (x y z) (H y z x)))
               (FF (lambda (a b c d e x s)
                     (ufz+ (fzrot (ufz+ a (F b c d) x) s) e)))
               (make-op (lambda (func const)
                          (let ((k (hex->fz const)))
                            (lambda (a b c d e x s)
                              (ufz+ (fzrot (ufz+ a (func b c d) x k) s) e))))))
        ;; Floor of 2^30 times square and cube roots of (2 3 5 7)
        (let ((ops1 (vector FF
                            (make-op G "5a827999")
                            (make-op H "6ed9eba1")
                            (make-op I "8f1bbcdc")
                            (make-op J "a953fd4e")))
              (ops2 (vector (make-op J "50a28be6")
                            (make-op I "5c4dd124")
                            (make-op H "6d703ef3")
                            (make-op G "7a6d76e9")
                            FF))
              (rho (lambda (i)
                     (vector-ref '#(7 4 13 1 10 6 15 3 12 0 9 5 2 14 11 8) i)))
              (pi (lambda (i) (fxand (+ (* 9 i) 5) 15)))
              (shifts '#(#(11 14 15 12 5 8 7 9 11 13 14 15 6 7 9 8)
                         #(12 13 11 15 6 9 9 7 12 15 11 13 7 8 7 7)
                         #(13 15 14 11 7 7 6 8 13 14 13 12 5 5 6 9)
                         #(14 11 12 14 8 6 5 5 15 12 15 14 9 9 8 6)
                         #(15 12 13 13 9 5 8 6 14 11 12 11 8 6 5 5)))
              (W1 (make-vector 80))
              (W2 (make-vector 80)))
          (do ((t 0 (+ t 1))) ((= t 16))
            (vector-set! W1 t t)
            (vector-set! W2 t (pi t)))
          (do ((t 16 (+ t 1))) ((= t 80))
            (vector-set! W1 t (rho (vector-ref W1 (- t 16))))
            (vector-set! W2 t (rho (vector-ref W2 (- t 16)))))

          (lambda (hash block)
            (let ((h0 (loadw32 hash 0))
                  (h1 (loadw32 hash 1))
                  (h2 (loadw32 hash 2))
                  (h3 (loadw32 hash 3))
                  (h4 (loadw32 hash 4))
                  (X (make-vector 16)))
              (do ((t 0 (+ t 1))) ((= t 16))
                (vector-set! X t (loadw32 block t)))
              (let loop ((t 0) (a1 h0) (b1 h1) (c1 h2) (d1 h3) (e1 h4)
                               (a2 h0) (b2 h1) (c2 h2) (d2 h3) (e2 h4))
                (if (= t 80)
                  (pack-words (map ufz+ (list h1 h2 h3 h4 h0)
                                   (list c1 d1 e1 a1 b1)
                                   (list d2 e2 a2 b2 c2)))
                  (let ((round (fxshift-unsigned t -4)))
                    (let ((shifts (vector-ref shifts round))
                          (op1 (vector-ref ops1 round))
                          (op2 (vector-ref ops2 round))
                          (i1 (vector-ref W1 t))
                          (i2 (vector-ref W2 t)))
                      (loop (+ t 1)
                            e1 (op1 a1 b1 c1 d1 e1 (vector-ref X i1)
                                    (vector-ref shifts i1))
                            b1 (fzrot c1 10) d1
                            e2 (op2 a2 b2 c2 d2 e2 (vector-ref X i2)
                                    (vector-ref shifts i2))
                            b2 (fzrot c2 10) d2))))))))))

    (define sha1-compress
      ;; Floor of 2^30 times square roots of (2 3 5 10)
      (let ((K (hex->fz-vec
                 "5a827999" "6ed9eba1" "8f1bbcdc" "ca62c1d6")))
        (lambda (hash block)
          (let ((f (vector fzif fzxor fzmaj fzxor))
                (W (make-vector 80))
                (h0 (loadbw32 hash 0))
                (h1 (loadbw32 hash 1))
                (h2 (loadbw32 hash 2))
                (h3 (loadbw32 hash 3))
                (h4 (loadbw32 hash 4)))
            (do ((t 0 (+ t 1))) ((= t 16))
              (vector-set! W t (loadbw32 block t)))
            (do ((t 16 (+ t 1))) ((= t 80))
              (vector-set! W t (fzrot (fzxor (vector-ref W (- t 3))
                                             (vector-ref W (- t 8))
                                             (vector-ref W (- t 14))
                                             (vector-ref W (- t 16)))
                                      1)))
            (let loop ((t 0) (a h0) (b h1) (c h2) (d h3) (e h4))
              (if (= t 80)
                (packb-words (map ufz+ (list a b c d e)
                                  (list h0 h1 h2 h3 h4)))
                (let* ((phase (quotient t 20))
                       (temp (ufz+ (fzrot a 5)
                                   ((vector-ref f phase) b c d)
                                   e
                                   (vector-ref K phase)
                                   (vector-ref W t))))
                  (loop (+ t 1) temp a (fzrot b 30) c d))))))))

    (define sha256-compress
      ;; First 32 fractional bits of cube roots of first 64 primes
      (let ((K (hex->fz-vec
                 "428a2f98" "71374491" "b5c0fbcf" "e9b5dba5"
                 "3956c25b" "59f111f1" "923f82a4" "ab1c5ed5"
                 "d807aa98" "12835b01" "243185be" "550c7dc3"
                 "72be5d74" "80deb1fe" "9bdc06a7" "c19bf174"
                 "e49b69c1" "efbe4786" "0fc19dc6" "240ca1cc"
                 "2de92c6f" "4a7484aa" "5cb0a9dc" "76f988da"
                 "983e5152" "a831c66d" "b00327c8" "bf597fc7"
                 "c6e00bf3" "d5a79147" "06ca6351" "14292967"
                 "27b70a85" "2e1b2138" "4d2c6dfc" "53380d13"
                 "650a7354" "766a0abb" "81c2c92e" "92722c85"
                 "a2bfe8a1" "a81a664b" "c24b8b70" "c76c51a3"
                 "d192e819" "d6990624" "f40e3585" "106aa070"
                 "19a4c116" "1e376c08" "2748774c" "34b0bcb5"
                 "391c0cb3" "4ed8aa4a" "5b9cca4f" "682e6ff3"
                 "748f82ee" "78a5636f" "84c87814" "8cc70208"
                 "90befffa" "a4506ceb" "bef9a3f7" "c67178f2")))
        (lambda (hash block)
          (let ((W (make-vector 64))
                (h0 (loadbw32 hash 0)) (h1 (loadbw32 hash 1))
                (h2 (loadbw32 hash 2)) (h3 (loadbw32 hash 3))
                (h4 (loadbw32 hash 4)) (h5 (loadbw32 hash 5))
                (h6 (loadbw32 hash 6)) (h7 (loadbw32 hash 7)))
            (do ((t 0 (+ t 1))) ((= t 16))
              (vector-set! W t (loadbw32 block t)))
            (do ((t 16 (+ t 1))) ((= t 64))
              (vector-set! W t (ufz+ (s1-32 (vector-ref W (- t 2)))
                                     (vector-ref W (- t 7))
                                     (s0-32 (vector-ref W (- t 15)))
                                     (vector-ref W (- t 16)))))
            (let loop ((t 0) (a h0) (b h1) (c h2) (d h3) (e h4) (f h5) (g h6)
                             (h h7))
              (if (= t 64)
                (packb-words (map ufz+ (list a b c d e f g h)
                                  (list h0 h1 h2 h3 h4 h5 h6 h7)))
                (let* ((temp1 (ufz+ (ss1-32 e)
                                    (fzif e f g)
                                    h
                                    (vector-ref K t)
                                    (vector-ref W t)))
                       (temp2 (ufz+ (ss0-32 a)
                                    (fzmaj a b c)
                                    temp1)))
                  (loop (+ t 1) temp2 a b c (ufz+ d temp1) e f g))))))))

    (define sha512-compress
      ;; First 64 fractional bits of cube roots of first 80 primes
      (let ((K (hex->fz-vec
                 "428a2f98d728ae22" "7137449123ef65cd"
                 "b5c0fbcfec4d3b2f" "e9b5dba58189dbbc"
                 "3956c25bf348b538" "59f111f1b605d019"
                 "923f82a4af194f9b" "ab1c5ed5da6d8118"
                 "d807aa98a3030242" "12835b0145706fbe"
                 "243185be4ee4b28c" "550c7dc3d5ffb4e2"
                 "72be5d74f27b896f" "80deb1fe3b1696b1"
                 "9bdc06a725c71235" "c19bf174cf692694"
                 "e49b69c19ef14ad2" "efbe4786384f25e3"
                 "0fc19dc68b8cd5b5" "240ca1cc77ac9c65"
                 "2de92c6f592b0275" "4a7484aa6ea6e483"
                 "5cb0a9dcbd41fbd4" "76f988da831153b5"
                 "983e5152ee66dfab" "a831c66d2db43210"
                 "b00327c898fb213f" "bf597fc7beef0ee4"
                 "c6e00bf33da88fc2" "d5a79147930aa725"
                 "06ca6351e003826f" "142929670a0e6e70"
                 "27b70a8546d22ffc" "2e1b21385c26c926"
                 "4d2c6dfc5ac42aed" "53380d139d95b3df"
                 "650a73548baf63de" "766a0abb3c77b2a8"
                 "81c2c92e47edaee6" "92722c851482353b"
                 "a2bfe8a14cf10364" "a81a664bbc423001"
                 "c24b8b70d0f89791" "c76c51a30654be30"
                 "d192e819d6ef5218" "d69906245565a910"
                 "f40e35855771202a" "106aa07032bbd1b8"
                 "19a4c116b8d2d0c8" "1e376c085141ab53"
                 "2748774cdf8eeb99" "34b0bcb5e19b48a8"
                 "391c0cb3c5c95a63" "4ed8aa4ae3418acb"
                 "5b9cca4f7763e373" "682e6ff3d6b2b8a3"
                 "748f82ee5defb2fc" "78a5636f43172f60"
                 "84c87814a1f0ab72" "8cc702081a6439ec"
                 "90befffa23631e28" "a4506cebde82bde9"
                 "bef9a3f7b2c67915" "c67178f2e372532b"
                 "ca273eceea26619c" "d186b8c721c0c207"
                 "eada7dd6cde0eb1e" "f57d4f7fee6ed178"
                 "06f067aa72176fba" "0a637dc5a2c898a6"
                 "113f9804bef90dae" "1b710b35131c471b"
                 "28db77f523047d84" "32caab7b40c72493"
                 "3c9ebe0a15c9bebc" "431d67c49c100d4c"
                 "4cc5d4becb3e42b6" "597f299cfc657e2a"
                 "5fcb6fab3ad6faec" "6c44198c4a475817")))
        (lambda (hash block)
          (let ((W (make-vector 80))
                (h0 (loadbw64 hash 0)) (h1 (loadbw64 hash 1))
                (h2 (loadbw64 hash 2)) (h3 (loadbw64 hash 3))
                (h4 (loadbw64 hash 4)) (h5 (loadbw64 hash 5))
                (h6 (loadbw64 hash 6)) (h7 (loadbw64 hash 7)))
            (do ((t 0 (+ t 1))) ((= t 16))
              (vector-set! W t (loadbw64 block t)))
            (do ((t 16 (+ t 1))) ((= t 80))
              (vector-set! W t (ufz+ (s1-64 (vector-ref W (- t 2)))
                                     (vector-ref W (- t 7))
                                     (s0-64 (vector-ref W (- t 15)))
                                     (vector-ref W (- t 16)))))
            (let loop ((t 0) (a h0) (b h1) (c h2) (d h3) (e h4) (f h5) (g h6)
                             (h h7))
              (if (= t 80)
                (packb-words (map ufz+ (list a b c d e f g h)
                                  (list h0 h1 h2 h3 h4 h5 h6 h7)))
                (let* ((temp1 (ufz+ (ss1-64 e) (fzif e f g) h
                                    (vector-ref K t) (vector-ref W t)))
                       (temp2 (ufz+ (ss0-64 a) (fzmaj a b c) temp1)))
                  (loop (+ t 1) temp2 a b c (ufz+ d temp1) e f g))))))))

    (let ((hmac64 (hmac 64))
          (hmac128 (hmac 128)))
      (let ((ripemd160 (merkle-damgard 64 64 #f rmd160-compress 0 rmd160-iv))
            (sha1 (merkle-damgard 64 64 #t sha1-compress 0 sha1-iv))
            (sha256 (merkle-damgard 64 64 #t sha256-compress 0 sha256-iv))
            (sha512 (merkle-damgard 128 128 #t sha512-compress 0 sha512-iv))
            (hmac-ripemd160 (hmac64 64 #f rmd160-compress rmd160-iv))
            (hmac-sha1 (hmac64 64 #t sha1-compress sha1-iv))
            (hmac-sha256 (hmac64 64 #t sha256-compress sha256-iv))
            (hmac-sha512 (hmac128 128 #t sha512-compress sha512-iv)))

        (export ripemd160 hmac-ripemd160
                sha1 hmac-sha1
                sha256 hmac-sha256
                sha512 hmac-sha512)))))

;;; References
;;
;; 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
;;
;; [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
;;
;; H. Krawczyk, M. Bellare, R. Canetti 1997. "HMAC: Keyed-Hashing for Message
;; Authentication." Network Working Group, Request for Comments: 2104