guile-gcrypt/tests/hash.scm

;;; guile-gcrypt --- crypto tooling for guile
;;; Copyright © 2013, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Brendan Tildesley <mail@brendan.scot>
;;;
;;; This file is part of guile-gcrypt.
;;;
;;; guile-gcrypt 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 3 of the License, or
;;; (at your option) any later version.
;;;
;;; guile-gcrypt 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 guile-gcrypt.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-hash)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt base16)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 hash-table)
  #:use-module (ice-9 match))

;; Test the (guix hash) module.

(define checksum-table
  (alist->hashq-table
   (list
    ;; Each string is the hash of "", "hello world", and "hello" for each digest
    ;; respectively.
    (cons 'md5 (list  "d41d8cd98f00b204e9800998ecf8427e"
                      "5eb63bbbe01eeed093cb22bb8f5acdc3"
                      "5d41402abc4b2a76b9719d911017c592"))
    (cons 'sha1 (list "da39a3ee5e6b4b0d3255bfef95601890afd80709"
                      "2aae6c35c94fcfb415dbe95f408b9ce91ee846ed"
                      "aaf4c61ddcc5e8a2dabede0f3b482cd9aea9434d"))
    (cons 'rmd160 (list "9c1185a5c5e9fc54612808977ee8f548b2258d31"
                        "98c615784ccb5fe5936fbc0cbe9dfdb408d92f0f"
                        "108f07b8382412612c048d07d13f814118445acd"))
    (cons 'sha256 (list "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
                        "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9"
                        "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824"))
    (cons 'sha384 (list "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b"
                        "fdbd8e75a67f29f701a4e040385e2e23986303ea10239211af907fcbb83578b3e417cb71ce646efd0819dd8c088de1bd"
                        "59e1748777448c69de6b800d7a33bbfb9ff1b463e44354c3553bcdb9c666fa90125a3c79f90397bdf5f6a13de828684f"))
    (cons 'sha512 (list "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e"
                        "309ecc489c12d6eb4cc40f50c902f2b4d0ed77ee511a7c7a9bcd3ca86d4cd86f989dd35bc5ff499670da34255b45b0cfd830e81f605dcf7dc5542e93ae9cd76f"
                        "9b71d224bd62f3785d96d46ad3ea3d73319bfbc2890caadae2dff72519673ca72323c3d99ba5c11d7c7acc6e14b8c5da0c4663475c2e5c3adef46f73bcdec043"))
    (cons 'sha224 (list "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
                        "2f05477fc24bb4faefd86517156dafdecec45b8ad3cf2522a563582b"
                        "ea09ae9cc6768c50fcee903ed054556e5bfc8347907f12598aa24193"))
    (cons 'md4 (list "31d6cfe0d16ae931b73c59d7e0c089c0"
                     "aa010fbc1d14c795d86ef98c95479d17"
                     "866437cb7a794bce2b727acc0362ee27"))
    (cons 'crc32 (list "00000000"
                       "0d4a1185"
                       "3610a686"))
    (cons 'crc32-rfc1510 (list "00000000"
                               "66cda069"
                               "f032519b"))
    (cons 'crc24-rfc2440 (list "b704ce"
                               "b03cb7"
                               "47f58a"))
    (cons 'whirlpool (list "19fa61d75522a4669b44e39c1d2e1726c530232130d407f89afee0964997f7a73e83be698b288febcf88e3e03c4f0757ea8964e59b63d93708b138cc42a66eb3"
                           "8d8309ca6af848095bcabaf9a53b1b6ce7f594c1434fd6e5177e7e5c20e76cd30936d8606e7f36acbef8978fea008e6400a975d51abe6ba4923178c7cf90c802"
                           "0a25f55d7308eca6b9567a7ed3bd1b46327f0f1ffdc804dd8bb5af40e88d78b88df0d002a89e2fdbd5876c523f1b67bc44e9f87047598e7548298ea1c81cfd73"))
    (cons 'tiger (list "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3"
                       "4c8fbddae0b6f25832af45e7c62811bb64ec3e43691e9cc3"
                       "2cfd7f6f336288a7f2741b9bf874388a54026639cadb7bf2"))
    (cons 'tiger2 (list "4441be75f6018773c206c22745374b924aa8313fef919f41"
                        "d88ca069f106339a428590493258da26fbddb833157bb5f3"
                        "5123173ede1d5af22772b84bc616bcf43b45b10c40da62fb"))
    (cons 'gostr3411-94 (list "ce85b99cc46752fffee35cab9a7b0278abb4c2d2055cff685af4912c49490f8d"
                              "1bb6ce69d2e895a78489c87a0712a2f40258d1fae3a4666c23f8f487bef0e22a"
                              "a7eb5d08ddf2363f1ea0317a803fcef81d33863c8b2f9f6d7d14951d229f4567"))
    (cons 'stribog256 (list "3f539a213e97c802cc229d474c6aa32a825a360b2a933a949fd925208d9ce1bb"
                            "c600fd9dd049cf8abd2f5b32e840d2cb0e41ea44de1c155dcd88dc84fe58a855"
                            "3fb0700a41ce6e41413ba764f98bf2135ba6ded516bea2fae8429cc5bdd46d6d"))

    (cons 'stribog512 (list "8e945da209aa869f0455928529bcae4679e9873ab707b55315f56ceb98bef0a7362f715528356ee83cda5f2aac4c6ad2ba3a715c1bcd81cb8e9f90bf4c1c1a8a"
                            "84d883ede9fa6ce855d82d8c278ecd9f5fc88bf0602831ae0c38b9b506ea3cb02f3fa076b8f5664adf1ff862c0157da4cc9a83e141b738ff9268a9ba3ed6f563"
                            "8df414260966beb7b34d920763079e15df1f63297eb3dd4311e8b585d4bf2f5923214f1dfed3fdee4aaf018330a12acde0efcc338eb52922f3e571212d42c8de"))
    (cons 'gostr3411cp (list "981e5f3ca30c841487830f84fb433e13ac1101569b9c13584ac483234cd656c0"
                              "c5aa1455afe9f0c440eec3c96ccccb5c8495097572cc0f625278bd0da5ea5e07"
                              "92ea6ddbaf40020df3651f278fd7151217a24aa8d22ebd2519cfd4d89e6450ea"))
    (cons 'sha3-224 (list "6b4e03423667dbb73b6e15454f0eb1abd4597f9a1b078e3f5b5a6bc7"
                          "dfb7f18c77e928bb56faeb2da27291bd790bc1045cde45f3210bb6c5"
                          "b87f88c72702fff1748e58b87e9141a42c0dbedc29a78cb0d4a5cd81"))
    (cons 'sha3-256 (list "a7ffc6f8bf1ed76651c14756a061d662f580ff4de43b49fa82d80a4b80f8434a"
                          "644bcc7e564373040999aac89e7622f3ca71fba1d972fd94a31c3bfbf24e3938"
                          "3338be694f50c5f338814986cdf0686453a888b84f424d792af4b9202398f392"))
    (cons 'sha3-384 (list "0c63a75b845e4f7d01107d852e4c2485c51a50aaaa94fc61995e71bbee983a2ac3713831264adb47fb6bd1e058d5f004"
                          "83bff28dde1b1bf5810071c6643c08e5b05bdb836effd70b403ea8ea0a634dc4997eb1053aa3593f590f9c63630dd90b"
                          "720aea11019ef06440fbf05d87aa24680a2153df3907b23631e7177ce620fa1330ff07c0fddee54699a4c3ee0ee9d887"))
    (cons 'sha3-512 (list "a69f73cca23a9ac5c8b567dc185a756e97c982164fe25859e0d1dcc1475c80a615b2123af1f5f94c11e3e9402c3ac558f500199d95b6d3e301758586281dcd26"
                          "840006653e9ac9e95117a15c915caab81662918e925de9e004f774ff82d7079a40d4d27b1b372657c61d46d470304c88c788b3a4527ad074d1dccbee5dbaa99a"
                          "75d527c368f2efe848ecf6b073a36767800805e9eef2b1857d5f984f036eb6df891d75f72d9b154518c1cd58835286d1da9a38deba3de98b5a53e5ed78a84976"))
    (cons 'blake2b-512 (list "786a02f742015903c6c6fd852552d272912f4740e15847618a86e217f71f5419d25e1031afee585313896444934eb04b903a685b1448b755d56f701afe9be2ce"
                             "021ced8799296ceca557832ab941a50b4a11f83478cf141f51f933f653ab9fbcc05a037cddbed06e309bf334942c4e58cdf1a46e237911ccd7fcf9787cbc7fd0"
                             "e4cfa39a3d37be31c59609e807970799caa68a19bfaa15135f165085e01d41a65ba1e1b146aeb6bd0092b49eac214c103ccfa3a365954bbbe52f74a2b3620c94"))
    (cons 'blake2b-384 (list "b32811423377f52d7862286ee1a72ee540524380fda1724a6f25d7978c6fd3244a6caf0498812673c5e05ef583825100"
                             "8c653f8c9c9aa2177fb6f8cf5bb914828faa032d7b486c8150663d3f6524b086784f8e62693171ac51fc80b7d2cbb12b"
                             "85f19170be541e7774da197c12ce959b91a280b2f23e3113d6638a3335507ed72ddc30f81244dbe9fa8d195c23bceb7e"))
    (cons 'blake2b-256 (list "0e5751c026e543b2e8ab2eb06099daa1d1e5df47778f7787faab45cdf12fe3a8"
                             "256c83b297114d201b30179f3f0ef0cace9783622da5974326b436178aeef610"
                             "324dcf027dd4a30a932c441f365a25e86b173defa4b8e58948253471b81b72cf"))
    (cons 'blake2b-160 (list "3345524abf6bbe1809449224b5972c41790b6cf2"
                             "70e8ece5e293e1bda064deef6b080edde357010f"
                             "b5531c7037f06c9f2947132a6a77202c308e8939"))
    (cons 'blake2s-256 (list "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9"
                             "9aec6806794561107e594b1f6a8a6b0c92a0cba9acf5e5e93cca06f781813b0b"
                             "19213bacc58dee6dbde3ceb9a47cbb330b3d86f8cca8997eb00be456f140ca25"))
    (cons 'blake2s-224 (list "1fa1291e65248b37b3433475b2a0dd63d54a11ecc4e3e034e7bc1ef4"
                             "00d9f56ea4202532f8fd42b12943e6ee8ea6fbef70052a6563d041a1"
                             "ad56bacfd62714b275eb3a7988b428afb9b5e0926a3ef40eb5f0bbb7"))
    (cons 'blake2s-160 (list "354c9c33f735962418bdacb9479873429c34916f"
                             "5b61362bd56823fd6ed1d3bea2f3ff0d2a0214d7"
                             "0fee8bbc1b2b15579499fec667487059abd72794"))
    (cons 'blake2s-128 (list "64550d6ffe2c0a01a14aba1eade0200c"
                             "37deae0226c30da2ab424a7b8ee14e83"
                             "96d539653dbf841c384b53d5f04658e5")))))

(define (get-checksum algorithm string)
  (let ((l (hashq-ref checksum-table algorithm)))
    (base16-string->bytevector
     (match string
       ("" (first l))
       ("hello world" (second l))
       ("hello" (third l))))))

(define (supports-unbuffered-cbip?)
  "Return #t if unbuffered custom binary input ports (CBIPs) are supported.
In Guile <= 2.0.9, CBIPs were always fully buffered, so 'open-hash-input-port'
does not work."
  (false-if-exception
   (setvbuf (make-custom-binary-input-port "foo" pk #f #f #f) _IONBF)))


(test-begin "hash")

;; dont forget the original tests for the deprecated bindings.

(define (empty-test algorithm)
  (test-equal
      (string-append (symbol->string algorithm) ", empty")
    (get-checksum algorithm "")
    (hash #vu8() algorithm)))

(define (hello-world-test algorithm)
  (test-equal
      (string-append (symbol->string algorithm) ", hello world")
    (get-checksum algorithm "hello world")
    (hash (string->utf8 "hello world") algorithm)))

(define (open-hash-port-empty-test algorithm)
  (test-equal (string-append "open-hash-port, " (symbol->string algorithm) ", empty")

    (get-checksum algorithm "")
    (let-values (((port get)
                  (open-hash-port algorithm)))
      (close-port port)
      (get))))

(define (open-hash-port-hello-world-test algorithm)
  (test-equal
      (string-append "open-hash-port, " (symbol->string algorithm) ", hello world")

    (list (get-checksum algorithm "hello world") (string-length "hello world"))
    (let-values (((port get)
                  (open-hash-port algorithm)))
      (put-bytevector port (string->utf8 "hello world"))
      (force-output port)
      (list (get) (port-position port)))))

(define (port-hash-test algorithm)
  (test-assert
      (string-append "port-hash, " (symbol->string algorithm))
      (let* ((file     (search-path %load-path "ice-9/psyntax.scm"))
             (size     (stat:size (stat file)))
             (contents (call-with-input-file file get-bytevector-all)))
        (equal? (hash contents algorithm)
                (call-with-input-file file (cut port-hash algorithm <>))))))

(define (open-hash-input-port-empty-test algorithm)
  (test-equal
      (string-append "open-hash-input-port, " (symbol->string algorithm) ", empty")
    `("" ,(get-checksum algorithm ""))
    (let-values (((port get)
                  (open-hash-input-port
                   algorithm
                   (open-string-input-port ""))))
      (let ((str (get-string-all port)))
        (list str (get))))))

(define (open-hash-input-port-hello-world-test algorithm)
  (test-equal
      (string-append
       "open-hash-input-port, " (symbol->string algorithm) ", hello world")
    `("hello world" ,(get-checksum algorithm "hello world"))
    (let-values (((port get)
                  (open-hash-input-port
                   algorithm
                   (open-string-input-port "hello world"))))
      (let ((str (get-string-all port)))
        (list str (get))))))

(define (open-hash-input-port-hello-test algorithm)
  (test-equal
      (string-append
       "open-hash-input-port, " (symbol->string algorithm) ", hello, one two")
    (list (string->utf8 "hel") (string->utf8 "lo")
          (get-checksum algorithm "hello")
          " world")
    (let-values (((port get)
                  (open-hash-input-port algorithm
                   (open-bytevector-input-port (string->utf8 "hello world")))))
      (let* ((one   (get-bytevector-n port 3))
             (two   (get-bytevector-n port 2))
             (hash  (get))
             (three (get-string-all port)))
        (list one two hash three)))))

(define (open-hash-input-port-hello-wrapped-test algorithm)
  (test-equal (string-append "open-hash-input-port, "
                             (symbol->string algorithm)
                             ", hello, read from wrapped port")
    (list (string->utf8 "hello")
          (get-checksum algorithm "hello")
          " world")
    (let*-values (((wrapped)
                   (open-bytevector-input-port (string->utf8 "hello world")))
                  ((port get)
                   (open-hash-input-port algorithm wrapped)))
      (let* ((hello (get-bytevector-n port 5))
             (hash  (get))

             ;; Now read from WRAPPED to make sure its current position is
             ;; correct.
             (world (get-string-all wrapped)))
        (list hello hash world)))))


(let ((supported-algorithms
       (hash-map->list (lambda x (car x)) checksum-table)))
  (for-each
   (lambda (algorithm)
     (empty-test algorithm)
     (hello-world-test algorithm)
     (open-hash-port-empty-test algorithm)
     (open-hash-port-hello-world-test algorithm)
     (port-hash-test algorithm)

     (test-skip (if (supports-unbuffered-cbip?) 0 4))

     (open-hash-input-port-empty-test algorithm)
     (open-hash-input-port-hello-world-test algorithm)
     (open-hash-input-port-hello-test algorithm)
     (open-hash-input-port-hello-wrapped-test algorithm))
   supported-algorithms))

(test-end)