Merge pull request #258 from ilammy/native-sha-2.v2

Native SHA-2 implementation (take two)

Makefile

@@ -23,12 +23,14 @@ CHIBI_COMPILED_LIBS = lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
 	lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/stty$(SO) \
 	lib/chibi/weak$(SO) lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO) \
 	lib/chibi/net$(SO) lib/chibi/ast$(SO) lib/chibi/emscripten$(SO)
+CHIBI_CRYPTO_COMPILED_LIBS = lib/chibi/crypto/crypto$(SO)
 CHIBI_IO_COMPILED_LIBS = lib/chibi/io/io$(SO)
 CHIBI_OPT_COMPILED_LIBS = lib/chibi/optimize/rest$(SO) \
 	lib/chibi/optimize/profile$(SO)
 EXTRA_COMPILED_LIBS ?=
 COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
-	$(CHIBI_OPT_COMPILED_LIBS) $(EXTRA_COMPILED_LIBS) \
+	$(CHIBI_OPT_COMPILED_LIBS) $(CHIBI_CRYPTO_COMPILED_LIBS) \
+	$(EXTRA_COMPILED_LIBS) \
 	lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
 	lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
 	lib/srfi/98/env$(SO) lib/scheme/time$(SO)
@@ -39,7 +41,7 @@ INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h
 MODULE_DOCS := ast config disasm equiv filesystem generic heap-stats io \
 	loop match mime modules net pathname process repl scribble stty \
 	system test time trace type-inference uri weak monad/environment \
-	show show/base
+	show show/base crypto/sha2
 
 HTML_LIBS = $(MODULE_DOCS:%=doc/lib/chibi/%.html)
 
@@ -284,11 +286,13 @@ install: all
 	$(INSTALL) -m0644 lib/srfi/95/*.scm $(DESTDIR)$(MODDIR)/srfi/95/
 	$(INSTALL) -m0644 lib/srfi/99/*.sld $(DESTDIR)$(MODDIR)/srfi/99/
 	$(INSTALL) -m0644 lib/srfi/99/records/*.sld lib/srfi/99/records/*.scm $(DESTDIR)$(MODDIR)/srfi/99/records/
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/33 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
 	$(INSTALL) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
+	$(INSTALL) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
 	$(INSTALL) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
 	$(INSTALL) -m0755 $(CHIBI_OPT_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
 	$(INSTALL) -m0755 lib/scheme/time$(SO) $(DESTDIR)$(BINMODDIR)/scheme/

Makefile.detect

@@ -108,7 +108,7 @@ RLDFLAGS=-Wl,-R$(DESTDIR)$(LIBDIR)
 endif
 
 ########################################################################
-# Check for NTP (who needs autoconf?)
+# Check for headers (who needs autoconf?)
 
 ifndef $(SEXP_USE_NTP_GETTIME)
 SEXP_USE_NTP_GETTIME := $(shell echo "main(){struct ntptimeval n; ntp_gettime(&n);}" | gcc -fsyntax-only -include sys/timex.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
@@ -117,3 +117,11 @@ endif
 ifeq ($(SEXP_USE_NTP_GETTIME),1)
 CPPFLAGS += -DSEXP_USE_NTPGETTIME
 endif
+
+ifndef $(SEXP_USE_INTTYPES)
+SEXP_USE_INTTYPES := $(shell echo "main(){int_least8_t x;}" | gcc -fsyntax-only -include inttypes.h -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+endif
+
+ifeq ($(SEXP_USE_INTTYPES),1)
+CPPFLAGS += -DSEXP_USE_INTTYPES
+endif

include/chibi/sexp.h

@@ -195,6 +195,34 @@ typedef int sexp_sint_t;
 #define sexp_heap_align(n) sexp_align(n, 4)
 #endif
 
+#ifdef SEXP_USE_INTTYPES
+# include <inttypes.h>
+# ifdef UINT8_MAX
+#  define SEXP_UINT8_DEFINED 1
+typedef uint8_t  sexp_uint8_t;
+# endif
+# ifdef UINT32_MAX
+#  define SEXP_UINT32_DEFINED 1
+typedef uint32_t sexp_uint32_t;
+# endif
+#else
+# include <limits.h>
+# if UCHAR_MAX == 255
+#  define SEXP_UINT8_DEFINED 1
+typedef unsigned char sexp_uint8_t;
+# endif
+# if UINT_MAX == 4294967295U
+#  define SEXP_UINT32_DEFINED 1
+typedef unsigned int sexp_uint32_t;
+# elif ULONG_MAX == 4294967295UL
+#  define SEXP_UINT32_DEFINED 1
+typedef unsigned long sexp_uint32_t;
+# elif USHRT_MAX == 4294967295U
+#  define SEXP_UINT32_DEFINED 1
+typedef unsigned short sexp_uint32_t;
+# endif
+#endif
+
 #if SEXP_USE_LONG_PROCEDURE_ARGS
 typedef int sexp_proc_num_args_t;
 #else

lib/chibi/crypto/crypto.stub

@@ -0,0 +1,39 @@
+(c-include-verbatim "sha2.c")
+
+;; \procedure{(start-sha type)}
+;;
+;; Allocates a new opaque computation context for a SHA-\var{type}
+;; digest, where \var{type} can be one of the following constants:
+;; \scheme{type-sha-224}, \scheme{type-sha-256}.
+
+(define-c-struct sha_context)
+
+(define-c sexp (start-sha "sexp_start_sha")
+  ((value ctx sexp) (value self sexp) unsigned-int (value NULL sha_context)))
+
+(define-c-const unsigned-int (type-sha-224 "SHA_TYPE_224"))
+(define-c-const unsigned-int (type-sha-256 "SHA_TYPE_256"))
+
+;; \procedure{(add-sha-data! sha-context data)}
+;;
+;; Adds a new piece of data into the given context. \var{data} can be
+;; a bytevector or a string. Bytevectors are added as sequences bytes.
+;; Strings are added as sequences of byte representations of their
+;; chars (which is either UTF-8 or ASCII code point sequence, depending
+;; on whether Chibi was compiled with Unicode support).
+;;
+;; It is an error to add more data into a context that was finalized
+;; by \scheme{get-sha}. This procedure returns an unspecified value.
+
+(define-c sexp (add-sha-data! "sexp_add_sha_data")
+  ((value ctx sexp) (value self sexp) sha_context sexp))
+
+;; \procedure{(get-sha sha-context)}
+;;
+;; Finalizes computation and returns resulting SHA-2 digest as a hex
+;; string (in lowercase). It is not possible to add more data with
+;; \scheme{add-sha-data!} after this call. Though, digest string can
+;; be retrieved multiple times from the same computation context.
+
+(define-c sexp (get-sha "sexp_get_sha")
+  ((value ctx sexp) (value self sexp) sha_context))

lib/chibi/crypto/sha2-native.scm

@@ -0,0 +1,24 @@
+;; sha2-native.scm -- SHA-2 digest algorithms native interface
+;; Copyright (c) 2015 Alexei Lozovsky.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (process-sha-data! context src)
+  (cond ((or (bytevector? src) (string? src))
+         (add-sha-data! context src))
+        ((input-port? src)
+         (let lp ((chunk (read-bytevector 1024 src)))
+           (unless (eof-object? chunk)
+             (add-sha-data! context chunk)
+             (lp (read-bytevector 1024 src)))))
+        (else
+         (error "unknown digest source: " src))))
+
+(define (sha-224 src)
+  (let ((context (start-sha type-sha-224)))
+    (process-sha-data! context src)
+    (get-sha context)))
+
+(define (sha-256 src)
+  (let ((context (start-sha type-sha-256)))
+    (process-sha-data! context src)
+    (get-sha context)))

lib/chibi/crypto/sha2-test.sld

@@ -1,6 +1,6 @@
 (define-library (chibi crypto sha2-test)
   (export run-tests)
-  (import (chibi) (chibi crypto sha2) (chibi test))
+  (import (chibi) (chibi io) (chibi crypto sha2) (chibi test))
   (begin
     (define (run-tests)
       (test-begin "sha2")
@@ -10,6 +10,36 @@
           (sha-224 "abc"))
       (test "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525"
           (sha-224 "The quick brown fox jumps over the lazy dog"))
+      (test "7c9da3bf97ccdeee630639aacdce35d3c136e514332a28e67097a4a4"
+          (sha-224 "Boundary test for 448 bits (-1) - 012345678901234567890"))
+      (test "35aebce593c857a2c817428340ff465922ffe43ed076d24553db1a24"
+          (sha-224 "Boundary test for 448 bits (0)  - 0123456789012345678901"))
+      (test "3f8dbeb9c33981d7007e20641d506d048e89e98a9546ecccc3224d3b"
+          (sha-224 "Boundary test for 448 bits (+1) - 01234567890123456789012"))
+      (test "8b311209d5880800911d3e72ffe7e75ec33a6e83932d5cdd00c96327"
+          (sha-224 "Boundary test for 512 bits (-1) - 01234567890123456789012345678"))
+      (test "9b68fdc122e1cb38575ba97f54699d71eaf0e58ee88f9e653b31d6ce"
+          (sha-224 "Boundary test for 512 bits (0)  - 012345678901234567890123456789"))
+      (test "52b28e31226ee5e6ada43e33194e11d8015abf8b5511c1631ad11aea"
+          (sha-224 "Boundary test for 512 bits (+1) - 0123456789012345678901234567890"))
+      (test "aa85fe2924d9c259f92e154fa88d0c845654fe69aa7dc1e3f7e4c789"
+          (sha-224 "Boundary test for 960 bits (-1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234"))
+      (test "dd8af6abfe24e78065afd1ae06220e8d46401db13f202109770ca2d2"
+          (sha-224 "Boundary test for 960 bits (0)  - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345"))
+      (test "5299a41ce9c6e8b405f42b193922fb4af3da16a1519610057baca20f"
+          (sha-224 "Boundary test for 960 bits (+1) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"))
+      (test "cb88e45dc662233ef4e7171e9e1c4903bd6502dd25923105778ea82e"
+          (sha-224 "Boundary test for 1024 bits (-1) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901"))
+      (test "f41c907a7fd2fa3aec70815669fe467760f4fd15763a75192d2c9f45"
+          (sha-224 "Boundary test for 1024 bits (0)  - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012"))
+      (test "cc1501345f86b1ef60eaf3637f7a37c38c63252b5674d343a3cc4aea"
+          (sha-224 "Boundary test for 1024 bits (+1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123"))
+      (test "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f"
+          (sha-224 #u8()))
+      (test "ae40be26ae2072dd84f37c13a5f6af48e3c33ea1c08a5ef4a54b22e3"
+          (sha-224 #u8(1 2 3 4 5 6 7 8 9)))
+      (test "54e5eb52479c241cc4759318619f548994ae46979124cb9b1435db14"
+          (sha-224 (open-input-bytevector #u8(1 2 3 9))))
       (test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
           (sha-256 ""))
       (test "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
@@ -20,4 +50,34 @@
           (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklm"))
       (test "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
           (sha-256 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"))
+      (test "f904e41d6488bc982a929e1f9307d9b47f12e6cc01ab42d109b083a780dbb70a"
+          (sha-256 "Boundary test for 448 bits (-1) - 012345678901234567890"))
+      (test "4621c7c067a12951ed5b0339a6c6811aec2dea4adcb2dcbb1383868765dbbc21"
+          (sha-256 "Boundary test for 448 bits (0)  - 0123456789012345678901"))
+      (test "a62bd24e12494c5a213dc366fec9d79e2bd77789febf6b1437191f264ad0a7fe"
+          (sha-256 "Boundary test for 448 bits (+1) - 01234567890123456789012"))
+      (test "2c47adeb018cd5634aa3c121bf0e6d122789448568814e7243b19b6c26ac4860"
+          (sha-256 "Boundary test for 512 bits (-1) - 01234567890123456789012345678"))
+      (test "eb1018cf7e5f40ba45a711c4154584234e2194f10cc6fa7559a438bed9e4a388"
+          (sha-256 "Boundary test for 512 bits (0)  - 012345678901234567890123456789"))
+      (test "714f030e4971ade8976564693a8fe202ca357e87cb1cb7391a9af3c45590f7c0"
+          (sha-256 "Boundary test for 512 bits (+1) - 0123456789012345678901234567890"))
+      (test "a745d68a9999da92558757735428346439e2af5668b188e9e4da7935e318335b"
+          (sha-256 "Boundary test for 960 bits (-1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234"))
+      (test "f2d7ad79e0360fbad145dd551db33548dc7cd253e6c56c975f2820e4c99dee51"
+          (sha-256 "Boundary test for 960 bits (0)  - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345"))
+      (test "9f0378e0ba55965bd17232f994710b786e9d72a88a806c0b10cd9d36a06e41ed"
+          (sha-256 "Boundary test for 960 bits (+1) - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456"))
+      (test "483a36ca7824cc0d9bff2d63901301ba8ca7deb675628c71d8a08d52a0396cfe"
+          (sha-256 "Boundary test for 1024 bits (-1) - 01234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901"))
+      (test "8bd16f15e5f1b753650753497d09e1956137fba0cb2162a61dc6a2b49c7fcda3"
+          (sha-256 "Boundary test for 1024 bits (0)  - 012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012"))
+      (test "c6c960e1c106d214e82d58c12c44adb000903d2022ea2ce239f273294d3055e5"
+          (sha-256 "Boundary test for 1024 bits (+1) - 0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123"))
+      (test "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
+          (sha-256 #u8()))
+      (test "47e4ee7f211f73265dd17658f6e21c1318bd6c81f37598e20a2756299542efcf"
+          (sha-256 #u8(1 2 3 4 5 6 7 8 9)))
+      (test "a745f3ca4f474d583c050eaf476ce76439d171ebe2b49d4af8b44f13ba71fb56"
+          (sha-256 (open-input-bytevector #u8(1 2 3 9))))
       (test-end))))

lib/chibi/crypto/sha2.c

@@ -0,0 +1,253 @@
+/* sha2.c -- SHA-2 digest algorithms native implementations  */
+/* Copyright (c) 2015 Alexei Lozovsky.  All rights reserved. */
+/* BSD-style license: http://synthcode.com/license.txt       */
+
+#if !(SEXP_UINT8_DEFINED && SEXP_UINT32_DEFINED)
+# error SHA-2 requires exact 8-bit and 32-bit integers to be available
+#endif
+
+/*
+ * SHA-2 algorithms are described in RFC 6234:
+ *
+ *    http://tools.ietf.org/html/rfc6234
+ */
+
+/* Initial hash vector for SHA-224 */
+static const sexp_uint32_t h224[8] = {
+  0xC1059ED8UL, 0x367CD507UL, 0x3070DD17UL, 0xF70E5939UL,
+  0xFFC00B31UL, 0x68581511UL, 0x64F98FA7UL, 0xBEFA4FA4UL,
+};
+
+/* Initial hash vector for SHA-256 */
+static const sexp_uint32_t h256[8] = {
+  0x6A09E667UL, 0xBB67AE85UL, 0x3C6EF372UL, 0xA54FF53AUL,
+  0x510E527FUL, 0x9B05688CUL, 0x1F83D9ABUL, 0x5BE0CD19UL,
+};
+
+/* Round constants for SHA-224/256 */
+static const sexp_uint32_t k256[64] = {
+  0x428A2F98UL, 0x71374491UL, 0xB5C0FBCFUL, 0xE9B5DBA5UL,
+  0x3956C25BUL, 0x59F111F1UL, 0x923F82A4UL, 0xAB1C5ED5UL,
+  0xD807AA98UL, 0x12835B01UL, 0x243185BEUL, 0x550C7DC3UL,
+  0x72BE5D74UL, 0x80DEB1FEUL, 0x9BDC06A7UL, 0xC19BF174UL,
+  0xE49B69C1UL, 0xEFBE4786UL, 0x0FC19DC6UL, 0x240CA1CCUL,
+  0x2DE92C6FUL, 0x4A7484AAUL, 0x5CB0A9DCUL, 0x76F988DAUL,
+  0x983E5152UL, 0xA831C66DUL, 0xB00327C8UL, 0xBF597FC7UL,
+  0xC6E00BF3UL, 0xD5A79147UL, 0x06CA6351UL, 0x14292967UL,
+  0x27B70A85UL, 0x2E1B2138UL, 0x4D2C6DFCUL, 0x53380D13UL,
+  0x650A7354UL, 0x766A0ABBUL, 0x81C2C92EUL, 0x92722C85UL,
+  0xA2BFE8A1UL, 0xA81A664BUL, 0xC24B8B70UL, 0xC76C51A3UL,
+  0xD192E819UL, 0xD6990624UL, 0xF40E3585UL, 0x106AA070UL,
+  0x19A4C116UL, 0x1E376C08UL, 0x2748774CUL, 0x34B0BCB5UL,
+  0x391C0CB3UL, 0x4ED8AA4AUL, 0x5B9CCA4FUL, 0x682E6FF3UL,
+  0x748F82EEUL, 0x78A5636FUL, 0x84C87814UL, 0x8CC70208UL,
+  0x90BEFFFAUL, 0xA4506CEBUL, 0xBEF9A3F7UL, 0xC67178F2UL,
+};
+
+/* Supported digest types */
+enum sha_type {
+  SHA_TYPE_224,
+  SHA_TYPE_256,
+  SHA_TYPE_MAX
+};
+
+/* Intermediate digest computation state */
+struct sha_context {
+  enum sha_type type;
+  char sealed;
+  sexp_uint_t len;
+  sexp_uint32_t hash256[8];
+  sexp_uint8_t buffer[128]; /* enough for all SHA-2 */
+};
+
+/* = SHA-224/256 implementation ===================================== */
+
+#define ror32(v, a) (((v) >> (a)) | ((v) << (32 - (a))))
+
+static void sha_224_256_round (const sexp_uint8_t chunk[64],
+                               sexp_uint32_t hash[8]) {
+  int i;
+  sexp_uint32_t w[64];
+  sexp_uint32_t tmp1, tmp2;
+  sexp_uint32_t a, b, c, d, e, f, g, h;
+  /* Initialize schedule array */
+  for (i = 0; i < 16; i++) {
+    w[i] = (chunk[4*i + 0] << 24)
+         | (chunk[4*i + 1] << 16)
+         | (chunk[4*i + 2] <<  8)
+         | (chunk[4*i + 3] <<  0);
+  }
+  for (i = 16; i < 64; i++) {
+    w[i] = w[i - 16]
+         + (ror32(w[i-15], 7) ^ ror32(w[i-15], 18) ^ (w[i-15] >> 3))
+         + w[i - 7]
+         + (ror32(w[i-2], 17) ^ ror32(w[i-2], 19) ^ (w[i-2] >> 10));
+  }
+  /* Initialize working variables */
+  a = hash[0]; b = hash[1]; c = hash[2]; d = hash[3];
+  e = hash[4]; f = hash[5]; g = hash[6]; h = hash[7];
+  /* Main loop */
+  for (i = 0; i < 64; i++) {
+    tmp1 = h
+         + (ror32(e, 6) ^ ror32(e, 11) ^ ror32(e, 25))
+         + ((e & f) ^ ((~e) & g))
+         + k256[i]
+         + w[i];
+    tmp2 = (ror32(a, 2) ^ ror32(a, 13) ^ ror32(a, 22))
+         + ((a & b) ^ (a & c) ^ (b & c));
+    h = g; g = f; f = e; e = d + tmp1;
+    d = c; c = b; b = a; a = tmp1 + tmp2;
+  }
+  /* Update hash values */
+  hash[0] += a; hash[1] += b; hash[2] += c; hash[3] += d;
+  hash[4] += e; hash[5] += f; hash[6] += g; hash[7] += h;
+}
+
+static void sha_224_256_remainder (sexp_uint8_t chunk[64], sexp_uint_t offset,
+                                   sexp_uint_t len_bits, sexp_uint32_t hash[8]) {
+  int i;
+  /* Pad with '1' bit and zeros */
+  chunk[offset] = 0x80;
+  memset(chunk + offset + 1, 0, 64 - offset - 1);
+  /* If we can't fit the length, use an additional chunk */
+  if (offset >= 56) {
+    sha_224_256_round(chunk, hash);
+    memset(chunk, 0, 64);
+  }
+  /* Append the message length in bits as big-endian 64-bit integer */
+  for (i = 63; i >= 56; i--) {
+    chunk[i] = len_bits & 0xFF;
+    len_bits >>= 8;
+  }
+  sha_224_256_round(chunk, hash);
+}
+
+/* = Allocating computation context ================================= */
+
+sexp sexp_start_sha (sexp ctx, sexp self, unsigned type, struct sha_context* v) {
+  sexp res;
+  struct sha_context *sha;
+  sexp_uint_t sha_context_tag;
+  if (type >= SHA_TYPE_MAX)
+    return sexp_xtype_exception(ctx, self, "SHA-2 digest type not supported",
+                                sexp_make_fixnum(type));
+  (void)v; /* We receive this phony argument to access the type tag of
+      sha_context and still be able to return an error with Chibi FFI */
+  sha_context_tag = sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), SEXP_ZERO));
+  res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sha_context_tag);
+  if (sexp_exceptionp(res))
+    return res;
+  sha = calloc(1, sizeof(*sha));
+  sha->type = type;
+  switch (type) {
+  case SHA_TYPE_224:
+    memcpy(sha->hash256, h224, sizeof(h224));
+    break;
+  case SHA_TYPE_256:
+    memcpy(sha->hash256, h256, sizeof(h256));
+    break;
+  default:
+    break;
+  }
+  sexp_cpointer_value(res) = sha;
+  sexp_freep(res) = 1;
+  return res;
+}
+
+/* = Processing incoming data ======================================= */
+
+static sexp sha_224_256_add_bytes (struct sha_context *sha,
+                                   const sexp_uint8_t *src, sexp_uint_t len) {
+  sexp_uint_t src_offset, buf_offset;
+  /* Realign (src + src_offset) to 64 bytes */
+  src_offset = 0;
+  buf_offset = sha->len % 64;
+  sha->len += len;
+  if (buf_offset) {
+    while ((buf_offset < 64) && (src_offset < len))
+      sha->buffer[buf_offset++] = src[src_offset++];
+    if (buf_offset == 64)
+      sha_224_256_round(sha->buffer, sha->hash256);
+    else
+      return SEXP_VOID;
+  }
+  /* Process whole chunks without copying them */
+  if (len >= 64) {
+    for ( ; src_offset <= (len - 64); src_offset += 64)
+      sha_224_256_round(src + src_offset, sha->hash256);
+  }
+  /* Copy the remainder into the buffer */
+  if (src_offset < len)
+    memcpy(sha->buffer + buf_offset, src + src_offset, len - src_offset);
+  return SEXP_VOID;
+}
+
+static sexp sha_add_bytes (sexp ctx, sexp self, struct sha_context *sha,
+                           const char* data, sexp_uint_t len) {
+  switch (sha->type) {
+  case SHA_TYPE_224:
+  case SHA_TYPE_256:
+    return sha_224_256_add_bytes(sha, (const sexp_uint8_t*) data, len);
+  default:
+    return sexp_xtype_exception(ctx, self, "unexpected context type",
+                                sexp_make_fixnum(sha->type));
+  }
+}
+
+sexp sexp_add_sha_data (sexp ctx, sexp self, struct sha_context *sha, sexp data) {
+  if (sha->sealed)
+    return sexp_xtype_exception(ctx, self, "cannot add to sealed context", data);
+  if (sexp_bytesp(data))
+    return sha_add_bytes(ctx, self, sha, sexp_bytes_data(data), sexp_bytes_length(data));
+  if (sexp_stringp(data))
+    return sha_add_bytes(ctx, self, sha, sexp_string_data(data), sexp_string_size(data));
+  return sexp_xtype_exception(ctx, self, "data type not supported", data);
+}
+
+/* = Extracting computed digest ===================================== */
+
+static const char *hex = "0123456789abcdef";
+
+static sexp sha_224_256_hash_string (sexp ctx, sexp self,
+                                     const sexp_uint32_t hash[8], int count) {
+  sexp res;
+  int i, j;
+  sexp_uint32_t next_word;
+  /* Allocate a string of target length */
+  res = sexp_make_string(ctx, sexp_make_fixnum(count * 8), SEXP_VOID);
+  if (sexp_exceptionp(res))
+    return res;
+  /* Write 32-bit words as nibbles in big-endian order */
+  for (i = 0; i < count; i++) {
+    next_word = hash[i];
+    for (j = 7; j >= 0; j--) {
+      sexp_string_data(res)[8*i + j] = hex[next_word & 0xF];
+      next_word >>= 4;
+    }
+  }
+  return res;
+}
+
+sexp sexp_get_sha (sexp ctx, sexp self, struct sha_context *sha) {
+  if (!sha->sealed) {
+    sha->sealed = 1;
+    switch (sha->type) {
+    case SHA_TYPE_224:
+    case SHA_TYPE_256:
+      sha_224_256_remainder(sha->buffer, sha->len % 64,
+                            sha->len * 8, sha->hash256);
+      break;
+    default:
+      break;
+    }
+  }
+  switch (sha->type) {
+  case SHA_TYPE_224:
+    return sha_224_256_hash_string(ctx, self, sha->hash256, 7);
+  case SHA_TYPE_256:
+    return sha_224_256_hash_string(ctx, self, sha->hash256, 8);
+  default:
+    return sexp_xtype_exception(ctx, self, "unexpected context type",
+                                sexp_make_fixnum(sha->type));
+  }
+}

lib/chibi/crypto/sha2.scm

@@ -40,7 +40,12 @@
    (u32 (arithmetic-shift n (- 32 k)))
    (arithmetic-shift n (- k))))
 
-(define hex integer->hex-string)
+(define (hex32 num)
+  (let* ((res (number->string num 16))
+         (len (string-length res)))
+    (if (>= len 8)
+        res
+        (string-append (make-string (- 8 len) #\0) res))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -152,8 +157,8 @@
                 (if (>= n 56)
                     (chunk (+ i n) 0 a b c d e f g h)
                     (string-append
-                     (hex a) (hex b) (hex c) (hex d)
+                     (hex32 a) (hex32 b) (hex32 c) (hex32 d)
-                     (hex e) (hex f) (hex g) (if full? (hex h) ""))))
+                     (hex32 e) (hex32 f) (hex32 g) (if full? (hex32 h) ""))))
                (else
                 (chunk (+ i 64) pad a b c d e f g h)))))
            (else

lib/chibi/crypto/sha2.sld

@@ -1,5 +1,23 @@
 
 (define-library (chibi crypto sha2)
-  (import (scheme base) (srfi 33) (chibi bytevector))
+  (import (scheme base))
   (export sha-224 sha-256)
-  (include "sha2.scm"))
+  (cond-expand
+   (chibi
+    (include "sha2-native.scm")
+    (include-shared "crypto"))
+   (else
+    (import (srfi 33) (chibi bytevector))
+    (include "sha2.scm"))))
+
+;;> \procedure{(sha-224 src)}
+;;>
+;;> Computes SHA-224 digest of the \var{src} which can be a string,
+;;> a bytevector, or a binary input port. Returns a hexadecimal string
+;;> (in lowercase).
+
+;;> \procedure{(sha-256 src)}
+;;>
+;;> Computes SHA-256 digest of the \var{src} which can be a string,
+;;> a bytevector, or a binary input port. Returns a hexadecimal string
+;;> (in lowercase).