Add a hash function

18 files changed, 212 insertions, 42 deletions

diff --git a/ChangeLog b/ChangeLog
index c6aa356..020a65a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -15,6 +15,7 @@
 	* NEWS (A random number generator): Update NEWS
 	(Generating a key pair): Update NEWS
 	(Strip a public key): Update NEWS
+	(Hash some data): Update NEWS
 
 2020-11-22  Vivien Kraus  <vivien@planete-kraus.eu>
 
diff --git a/NEWS b/NEWS
index 5850dcd..63f11c7 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,8 @@ There is a function to generate a RSA or ECC key pair.
 ** Strip a public key
 In order to avoid leaking the private components of a key, the
 =strip-key= function keeps only the required parts.
+** Hash some data
+The function =hash= takes a string, and hashes its UTF-8 encoding.
 
 # Local Variables:
 # mode: org
diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi
index 0a368e4..c7bfa5b 100644
--- a/doc/webid-oidc.texi
+++ b/doc/webid-oidc.texi
@@ -151,6 +151,10 @@ The identifier @var{crv} does not identify an elliptic curve.
 @var{value} does not identify a JWK.
 @end deftp
 
+@deftp {exception type} &unsupported-alg @var{value}
+@var{value} does not identify a valid hash algorithm.
+@end deftp
+
 @node GNU Free Documentation License
 @appendix GNU Free Documentation License
 
diff --git a/po/ChangeLog b/po/ChangeLog
index aaa33ce..6a7ac81 100644
--- a/po/ChangeLog
+++ b/po/ChangeLog
@@ -2,6 +2,7 @@
 
 	* POTFILES.in: Put the random submodule in the list.
 	Put the jwk submodule in the list.
+	Put the hash submodule in the list.
 
 2020-11-22  Vivien Kraus  <vivien@planete-kraus.eu>
 
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 844066a..a4f4569 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -5,4 +5,5 @@ src/random/libwebidoidc-random.c
 src/random/generate-random.c
 src/jwk/libwebidoidc-jwk.c
 src/jwk/generate-key.c
+src/hash/libwebidoidc-hash.c
 src/scm/webid-oidc/errors.scm
diff --git a/po/fr.po b/po/fr.po
index 742edbb..869b9c1 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -12,7 +12,7 @@ msgstr ""
 "Content-Transfer-Encoding: 8bit\n"
 "Plural-Forms: nplurals=2; plural=(n > 1);\n"
 
-#: src/libwebidoidc.c:9
+#: src/libwebidoidc.c:10
 msgid "This is the main function."
 msgstr "Ceci est la fonction principale."
 
@@ -126,73 +126,82 @@ msgstr "Utilisation : generate-random [NOMBRE D'OCTETS]\n"
 msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n"
 msgstr "Utilisation : generate-key [NOMBRE DE BITS | COURBE]\n"
 
-#: src/scm/webid-oidc/errors.scm:65
+#: src/scm/webid-oidc/errors.scm:75
 msgid "that’s how it is"
 msgstr "c’est comme ça"
 
-#: src/scm/webid-oidc/errors.scm:70
+#: src/scm/webid-oidc/errors.scm:80
 #, scheme-format
 msgid "the value ~s is not a base64 string (because ~a)"
 msgstr "la valeur ~s n’est pas une chaîne base64 (parce que ~a)"
 
-#: src/scm/webid-oidc/errors.scm:73
+#: src/scm/webid-oidc/errors.scm:83
 #, scheme-format
 msgid "the value ~s is not JSON (because ~a)"
 msgstr "la valeur ~s n’est pas du JSON (parce que ~a)"
 
-#: src/scm/webid-oidc/errors.scm:76
+#: src/scm/webid-oidc/errors.scm:86
 #, scheme-format
 msgid "the value ~s does not identify an elleptic curve"
 msgstr "la valeur ~s n’identifie pas une courbe elliptique"
 
-#: src/scm/webid-oidc/errors.scm:81
+#: src/scm/webid-oidc/errors.scm:91
 #, scheme-format
 msgid "the value ~s does not identify a JWK (because ~a)"
 msgstr "la valeur ~s n’identifie pas une JWK (parce que ~a)"
 
-#: src/scm/webid-oidc/errors.scm:83
+#: src/scm/webid-oidc/errors.scm:93
 #, scheme-format
 msgid "the value ~s does not identify a JWK"
 msgstr "la valeur ~s n’identifie pas une JWK"
 
-#: src/scm/webid-oidc/errors.scm:88
+#: src/scm/webid-oidc/errors.scm:96
+#, scheme-format
+msgid "the value ~s does not identify a hash algorithm"
+msgstr "la valeur ~s n’identifie pas un algorithme de hachage"
+
+#: src/scm/webid-oidc/errors.scm:101
 msgid "that’s it"
 msgstr "c’est tout"
 
-#: src/scm/webid-oidc/errors.scm:92
+#: src/scm/webid-oidc/errors.scm:105
 #, scheme-format
 msgid "~a and ~a"
 msgstr "~a et ~a"
 
-#: src/scm/webid-oidc/errors.scm:95
+#: src/scm/webid-oidc/errors.scm:108
 #, scheme-format
 msgid "~a, ~a"
 msgstr "~a, ~a"
 
-#: src/scm/webid-oidc/errors.scm:99
+#: src/scm/webid-oidc/errors.scm:112
 msgid "there is an undefined variable"
 msgstr "il y a une variable non définie"
 
-#: src/scm/webid-oidc/errors.scm:101
+#: src/scm/webid-oidc/errors.scm:114
 #, scheme-format
 msgid "the origin is ~a"
 msgstr "l’origine est ~a"
 
-#: src/scm/webid-oidc/errors.scm:104
+#: src/scm/webid-oidc/errors.scm:117
 #, scheme-format
 msgid "a message is attached: ~a"
 msgstr "un message est attaché : ~a"
 
-#: src/scm/webid-oidc/errors.scm:107
+#: src/scm/webid-oidc/errors.scm:120
 #, scheme-format
 msgid "the values ~s are problematic"
 msgstr "les valeurs ~s sont problématiques"
 
-#: src/scm/webid-oidc/errors.scm:110
+#: src/scm/webid-oidc/errors.scm:123
 msgid "there is a kind and args"
 msgstr "il y a un type et des arguments"
 
-#: src/scm/webid-oidc/errors.scm:112
+#: src/scm/webid-oidc/errors.scm:125
+msgid "there is an assertion failure"
+msgstr "il y a un échec d’assertion"
+
+#: src/scm/webid-oidc/errors.scm:127
 #, scheme-format
 msgid "Unhandled exception type ~a."
 msgstr "Type d’exception non pris en charge ~a."
@@ -226,10 +235,6 @@ msgstr "Type d’exception non pris en charge ~a."
 #~ msgstr "la valeur ~s n’identifie pas un JWKS"
 
 #, scheme-format
-#~ msgid "the value ~s does not identify a hash algorithm"
-#~ msgstr "la valeur ~s n’identifie pas un algorithme de hachage"
-
-#, scheme-format
 #~ msgid "the value ~s is not an alist or misses key ~s"
 #~ msgstr "la valeur ~s n’est pas une alist ou il manque la clé ~s"
 
@@ -671,9 +676,6 @@ msgstr "Type d’exception non pris en charge ~a."
 #~ msgid "the signature ~a does not match key ~s with payload ~a"
 #~ msgstr "la signature ~a ne correspond pas à la clé ~s avec le contenu ~a"
 
-#~ msgid "there is an assertion failure"
-#~ msgstr "il y a un échec d’assertion"
-
 #, scheme-format
 #~ msgid "the program quits with code ~a"
 #~ msgstr "le programme quitte avec le code ~a"
diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot
index 21b0d57..f1fa6a0 100644
--- a/po/webid-oidc.pot
+++ b/po/webid-oidc.pot
@@ -17,7 +17,7 @@ msgstr ""
 "Content-Type: text/plain; charset=UTF-8\n"
 "Content-Transfer-Encoding: 8bit\n"
 
-#: src/libwebidoidc.c:9
+#: src/libwebidoidc.c:10
 msgid "This is the main function."
 msgstr ""
 
@@ -122,73 +122,82 @@ msgstr ""
 msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:65
+#: src/scm/webid-oidc/errors.scm:75
 msgid "that’s how it is"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:70
+#: src/scm/webid-oidc/errors.scm:80
 #, scheme-format
 msgid "the value ~s is not a base64 string (because ~a)"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:73
+#: src/scm/webid-oidc/errors.scm:83
 #, scheme-format
 msgid "the value ~s is not JSON (because ~a)"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:76
+#: src/scm/webid-oidc/errors.scm:86
 #, scheme-format
 msgid "the value ~s does not identify an elleptic curve"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:81
+#: src/scm/webid-oidc/errors.scm:91
 #, scheme-format
 msgid "the value ~s does not identify a JWK (because ~a)"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:83
+#: src/scm/webid-oidc/errors.scm:93
 #, scheme-format
 msgid "the value ~s does not identify a JWK"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:88
+#: src/scm/webid-oidc/errors.scm:96
+#, scheme-format
+msgid "the value ~s does not identify a hash algorithm"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:101
 msgid "that’s it"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:92
+#: src/scm/webid-oidc/errors.scm:105
 #, scheme-format
 msgid "~a and ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:95
+#: src/scm/webid-oidc/errors.scm:108
 #, scheme-format
 msgid "~a, ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:99
+#: src/scm/webid-oidc/errors.scm:112
 msgid "there is an undefined variable"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:101
+#: src/scm/webid-oidc/errors.scm:114
 #, scheme-format
 msgid "the origin is ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:104
+#: src/scm/webid-oidc/errors.scm:117
 #, scheme-format
 msgid "a message is attached: ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:107
+#: src/scm/webid-oidc/errors.scm:120
 #, scheme-format
 msgid "the values ~s are problematic"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:110
+#: src/scm/webid-oidc/errors.scm:123
 msgid "there is a kind and args"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:112
+#: src/scm/webid-oidc/errors.scm:125
+msgid "there is an assertion failure"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:127
 #, scheme-format
 msgid "Unhandled exception type ~a."
 msgstr ""
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
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 65191b4..cb41e05 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -5,7 +5,9 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/jwk-kty-ec-correct.scm \
   %reldir%/jwk-kty-ec-incorrect.scm \
   %reldir%/jwk-kty-rsa-correct.scm \
-  %reldir%/jwk-kty-rsa-incorrect.scm
+  %reldir%/jwk-kty-rsa-incorrect.scm \
+  %reldir%/hash-ok.scm \
+  %reldir%/hash-unsupported.scm
 
 EXTRA_DIST += $(TESTS)
 
diff --git a/tests/hash-ok.scm b/tests/hash-ok.scm
new file mode 100644
index 0000000..26384f8
--- /dev/null
+++ b/tests/hash-ok.scm
@@ -0,0 +1,11 @@
+(use-modules
+ (webid-oidc testing)
+ ((webid-oidc stubs) #:prefix stubs:)
+ (rnrs bytevectors))
+
+(with-test-environment
+ "hash-ok"
+ (lambda ()
+   (let ((hashed (stubs:hash 'SHA-256 "hello :)")))
+     (unless (string? hashed)
+       (exit 1)))))
diff --git a/tests/hash-unsupported.scm b/tests/hash-unsupported.scm
new file mode 100644
index 0000000..c52959a
--- /dev/null
+++ b/tests/hash-unsupported.scm
@@ -0,0 +1,21 @@
+(use-modules
+ (webid-oidc testing)
+ (webid-oidc errors)
+ ((webid-oidc stubs) #:prefix stubs:)
+ (rnrs bytevectors))
+
+(with-test-environment
+ "hash-unsupported"
+ (lambda ()
+   (with-exception-handler
+       (lambda (error)
+         (unless ((record-predicate &unsupported-alg) error)
+           (exit 1))
+         (let ((value ((record-accessor &unsupported-alg 'value) error)))
+           (unless (eq? value 'SHA-1024)
+             (exit 2))))
+     (lambda ()
+       (stubs:hash 'SHA-1024 "hello :)")
+       (exit 3))
+     #:unwind? #t
+     #:unwind-for-type &unsupported-alg)))