Add a hash function

8 files changed, 118 insertions, 2 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 3b99888..d4a8415 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,9 @@
 2020-11-25  Vivien Kraus  <vivien@planete-kraus.eu>
 
+	* libwebidoidc.c (init_webidoidc): Initialize the hash submodule.
+
+	* Makefile.am: Build the "hash" submodule.
+
 	* utilities.h: Add functions for the jwk submodule.
 
 	* libwebidoidc.c (init_webidoidc): Initialize the jwk submodule.
diff --git a/src/Makefile.am b/src/Makefile.am
index 1d5f61c..ace4ef9 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -26,6 +26,7 @@ install_mod_targets = install-webidoidcmodDATA install-dist_webidoidcmodDATA
 include %reldir%/base64/Makefile.am
 include %reldir%/random/Makefile.am
 include %reldir%/jwk/Makefile.am
+include %reldir%/hash/Makefile.am
 include %reldir%/pre-inst/Makefile.am
 include %reldir%/inst/Makefile.am
 include %reldir%/scm/Makefile.am
diff --git a/src/hash/ChangeLog b/src/hash/ChangeLog
new file mode 100644
index 0000000..c609232
--- /dev/null
+++ b/src/hash/ChangeLog
@@ -0,0 +1,11 @@
+2020-11-27  Vivien Kraus  <vivien@planete-kraus.eu>
+
+	* libwebidoidc-hash.c (webidoidc_hash_g): if the argument is a
+	string, encode it to utf8 first.
+
+2020-11-25  Vivien Kraus  <vivien@planete-kraus.eu>
+
+	* libwebidoidc-hash.c: New file.
+
+	* Makefile.am: New file.
+
diff --git a/src/hash/Makefile.am b/src/hash/Makefile.am
new file mode 100644
index 0000000..5579608
--- /dev/null
+++ b/src/hash/Makefile.am
@@ -0,0 +1,11 @@
+noinst_LTLIBRARIES += %reldir%/libwebidoidc-hash.la
+EXTRA_DIST += %reldir%/libwebidoidc-hash.x
+BUILT_SOURCES += %reldir%/libwebidoidc-hash.x
+
+%canon_reldir%_libwebidoidc_hash_la_LIBADD = $(GUILE_LIBS) $(NETTLE_LIBS)
+
+AM_CFLAGS += -I %reldir% -I $(srcdir)/%reldir%
+
+INDENTED += %reldir%/libwebidoidc-hash.c
+
+%reldir%/libwebidoidc-hash.o: %reldir%/libwebidoidc-hash.x
diff --git a/src/hash/libwebidoidc-hash.c b/src/hash/libwebidoidc-hash.c
new file mode 100644
index 0000000..75d7da9
--- /dev/null
+++ b/src/hash/libwebidoidc-hash.c
@@ -0,0 +1,64 @@
+#include <utilities.h>
+#include <nettle/sha2.h>
+
+#define _(s) dgettext (PACKAGE, s)
+
+SCM_SYMBOL (sha256, "SHA-256");
+SCM_SYMBOL (sha384, "SHA-384");
+SCM_SYMBOL (sha512, "SHA-512");
+
+SCM_SYMBOL (unsupported_alg, "unsupported-alg");
+
+SCM_DEFINE (webidoidc_hash_g, "hash", 2, 0, 0, (SCM alg, SCM payload),
+	    "Hash something with @var{alg}, which must be @code{'SHA-256}, @code{'SHA-384} or @code{'SHA-512}.")
+{
+  size_t payload_size;
+  uint8_t *c_payload;
+  if (scm_is_string (payload))
+    {
+      return webidoidc_hash_g (alg, scm_string_to_utf8 (payload));
+    }
+  payload_size = scm_c_bytevector_length (payload);
+  c_payload = scm_gc_malloc_pointerless (payload_size, "To hash");
+  memcpy (c_payload, SCM_BYTEVECTOR_CONTENTS (payload), payload_size);
+  if (scm_is_eq (alg, sha256))
+    {
+      struct sha256_ctx hash;
+      uint8_t digest[SHA256_DIGEST_SIZE];
+      sha256_init (&hash);
+      sha256_update (&hash, payload_size, c_payload);
+      sha256_digest (&hash, SHA256_DIGEST_SIZE, digest);
+      return wrap_bytevector (SHA256_DIGEST_SIZE, digest);
+    }
+  else if (scm_is_eq (alg, sha384))
+    {
+      struct sha384_ctx hash;
+      uint8_t digest[SHA384_DIGEST_SIZE];
+      sha384_init (&hash);
+      sha384_update (&hash, payload_size, c_payload);
+      sha384_digest (&hash, SHA384_DIGEST_SIZE, digest);
+      return wrap_bytevector (SHA384_DIGEST_SIZE, digest);
+    }
+  else if (scm_is_eq (alg, sha512))
+    {
+      struct sha512_ctx hash;
+      uint8_t digest[SHA512_DIGEST_SIZE];
+      sha512_init (&hash);
+      sha512_update (&hash, payload_size, c_payload);
+      sha512_digest (&hash, SHA512_DIGEST_SIZE, digest);
+      return wrap_bytevector (SHA512_DIGEST_SIZE, digest);
+    }
+  else
+    {
+      scm_throw (unsupported_alg, scm_list_1 (alg));
+    }
+  return SCM_UNDEFINED;
+}
+
+void
+init_webidoidc_hash (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libwebidoidc-hash.x"
+#endif /* not SCM_MAGIC_SNARFER */
+}
diff --git a/src/libwebidoidc.c b/src/libwebidoidc.c
index 514a51c..953fea5 100644
--- a/src/libwebidoidc.c
+++ b/src/libwebidoidc.c
@@ -2,6 +2,7 @@
 void init_webidoidc_base64 (void);
 void init_webidoidc_random (void);
 void init_webidoidc_jwk (void);
+void init_webidoidc_hash (void);
 
 void
 init_webidoidc (void)
@@ -10,4 +11,5 @@ init_webidoidc (void)
   init_webidoidc_base64 ();
   init_webidoidc_random ();
   init_webidoidc_jwk ();
+  init_webidoidc_hash ();
 }
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 27dc6e2..b575a77 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -54,6 +54,16 @@
   (raise-exception
    ((record-constructor &not-a-jwk) value cause)))
 
+(define-public &unsupported-alg
+  (make-exception-type
+   '&unsupported-alg
+   &external-error
+   '(value)))
+
+(define-public (raise-unsupported-alg value)
+  (raise-exception
+   ((record-constructor &unsupported-alg) value)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -82,6 +92,9 @@
                          (get 'value) cause)
                  (format #f (G_ "the value ~s does not identify a JWK")
                          (get 'value)))))
+          ((&unsupported-alg)
+           (format #f (G_ "the value ~s does not identify a hash algorithm")
+                   (get 'value)))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
@@ -108,6 +121,8 @@
                    (exception-irritants err)))
           ((&exception-with-kind-and-args)
            (format #f (G_ "there is a kind and args")))
+          ((&assertion-failure)
+           (format #f (G_ "there is an assertion failure")))
           (else
            (error (format #f (G_ "Unhandled exception type ~a.")
                           (record-type-name type))))))
diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index ff94497..4f2036b 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -28,9 +28,16 @@
         (unless ret
           (raise-not-a-jwk key #f))
         ret))
-    (lambda (error)
+    (lambda error
       (raise-unsupported-crv (cadr error)))))
 
+(define (fix-hash alg payload)
+  (catch 'unsupported-alg
+    (lambda ()
+      (hash alg payload))
+    (lambda error
+      (raise-unsupported-alg (cadr error)))))
+
 (export
  base64-encode
  (fix-base64-decode . base64-decode)
@@ -38,7 +45,8 @@
  random-init!
  (fix-generate-key . generate-key)
  (fix-kty . kty)
- strip-key)
+ strip-key
+ (fix-hash . hash))
 
 ;; json reader from guile-json will not behave consistently with
 ;; SRFI-180 with objects: keys will be mapped to strings, not