Add a base64 encoder and decoder

15 files changed, 368 insertions, 51 deletions

diff --git a/NEWS b/NEWS
index 8a3f965..816a170 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,7 @@
 #+email: vivien@planete-kraus.eu
 
 * Initial features
+** Add base64 encoding and decoding
 
 # Local Variables:
 # mode: org
diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi
index 81d408a..d63fc09 100644
--- a/doc/webid-oidc.texi
+++ b/doc/webid-oidc.texi
@@ -121,6 +121,21 @@ Return a string explaining the @var{error}. You can limit the
 @var{depth} of the explanation as an integer.
 @end deffn
 
+@menu
+* Invalid data format::
+@end menu
+
+@node Invalid data format
+@section Invalid data format
+There are a few JSON objects with required fields. This exceptions
+usually occur as the cause of a higher-level exception.
+
+@deftp {exception type} &not-base64 @var{value} @var{cause}
+This exception is raised when the base64 decoding function
+failed. @var{value} is the incorrect input, and @var{cause} is a
+low-level error.
+@end deftp
+
 @node GNU Free Documentation License
 @appendix GNU Free Documentation License
 
diff --git a/po/fr.po b/po/fr.po
index 88e7661..6fcba28 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -2,7 +2,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-06-05 16:09+0200\n"
+"POT-Creation-Date: 2021-06-05 16:10+0200\n"
 "PO-Revision-Date: 2021-06-05 11:07+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
@@ -12,14 +12,61 @@ msgstr ""
 "Content-Transfer-Encoding: 8bit\n"
 "Plural-Forms: nplurals=2; plural=(n > 1);\n"
 
-#: src/libwebidoidc.c:6
+#: src/libwebidoidc.c:7
 msgid "This is the main function."
 msgstr "Ceci est la fonction principale."
 
-#: src/scm/webid-oidc/errors.scm:25
+#: src/scm/webid-oidc/errors.scm:35
 msgid "that’s how it is"
 msgstr "c’est comme ça"
 
+#: src/scm/webid-oidc/errors.scm:40
+#, 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:45
+msgid "that’s it"
+msgstr "c’est tout"
+
+#: src/scm/webid-oidc/errors.scm:49
+#, scheme-format
+msgid "~a and ~a"
+msgstr "~a et ~a"
+
+#: src/scm/webid-oidc/errors.scm:52
+#, scheme-format
+msgid "~a, ~a"
+msgstr "~a, ~a"
+
+#: src/scm/webid-oidc/errors.scm:56
+msgid "there is an undefined variable"
+msgstr "il y a une variable non définie"
+
+#: src/scm/webid-oidc/errors.scm:58
+#, scheme-format
+msgid "the origin is ~a"
+msgstr "l’origine est ~a"
+
+#: src/scm/webid-oidc/errors.scm:61
+#, scheme-format
+msgid "a message is attached: ~a"
+msgstr "un message est attaché : ~a"
+
+#: src/scm/webid-oidc/errors.scm:64
+#, scheme-format
+msgid "the values ~s are problematic"
+msgstr "les valeurs ~s sont problématiques"
+
+#: src/scm/webid-oidc/errors.scm:67
+msgid "there is a kind and args"
+msgstr "il y a un type et des arguments"
+
+#: src/scm/webid-oidc/errors.scm:69
+#, scheme-format
+msgid "Unhandled exception type ~a."
+msgstr "Type d’exception non pris en charge ~a."
+
 #, c-format
 #~ msgid "Could not set the global random generator up.\n"
 #~ msgstr ""
@@ -113,10 +160,6 @@ msgstr "c’est comme ça"
 #~ msgstr "Utilisation : generate-key [NOMBRE DE BITS | COURBE]\n"
 
 #, 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)"
-
-#, scheme-format
 #~ msgid "the value ~s is not JSON (because ~a)"
 #~ msgstr "la valeur ~s n’est pas du JSON (parce que ~a)"
 
@@ -602,39 +645,10 @@ msgstr "c’est comme ça"
 #~ msgid "the container ~s should be emptied before being deleted"
 #~ msgstr "le conteneur ~s doit être vidé avant d’être détruit"
 
-#~ msgid "that’s it"
-#~ msgstr "c’est tout"
-
-#, scheme-format
-#~ msgid "~a and ~a"
-#~ msgstr "~a et ~a"
-
-#, scheme-format
-#~ msgid "~a, ~a"
-#~ msgstr "~a, ~a"
-
 #, scheme-format
 #~ 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 undefined variable"
-#~ msgstr "il y a une variable non définie"
-
-#, scheme-format
-#~ msgid "the origin is ~a"
-#~ msgstr "l’origine est ~a"
-
-#, scheme-format
-#~ msgid "a message is attached: ~a"
-#~ msgstr "un message est attaché : ~a"
-
-#, scheme-format
-#~ msgid "the values ~s are problematic"
-#~ msgstr "les valeurs ~s sont problématiques"
-
-#~ msgid "there is a kind and args"
-#~ msgstr "il y a un type et des arguments"
-
 #~ msgid "there is an assertion failure"
 #~ msgstr "il y a un échec d’assertion"
 
@@ -651,10 +665,6 @@ msgstr "c’est comme ça"
 #~ msgid "there is an external error"
 #~ msgstr "il y a une erreur externe"
 
-#, scheme-format
-#~ msgid "Unhandled exception type ~a."
-#~ msgstr "Type d’exception non pris en charge ~a."
-
 #~ msgid "Warning: generating a new key pair."
 #~ msgstr "Attention : génération d'une nouvelle paire de clé."
 
diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot
index 9935e70..dc31531 100644
--- a/po/webid-oidc.pot
+++ b/po/webid-oidc.pot
@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc SNAPSHOT\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-06-05 16:09+0200\n"
+"POT-Creation-Date: 2021-06-05 16:10+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
@@ -17,10 +17,57 @@ msgstr ""
 "Content-Type: text/plain; charset=UTF-8\n"
 "Content-Transfer-Encoding: 8bit\n"
 
-#: src/libwebidoidc.c:6
+#: src/libwebidoidc.c:7
 msgid "This is the main function."
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:25
+#: src/scm/webid-oidc/errors.scm:35
 msgid "that’s how it is"
 msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:40
+#, scheme-format
+msgid "the value ~s is not a base64 string (because ~a)"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:45
+msgid "that’s it"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:49
+#, scheme-format
+msgid "~a and ~a"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:52
+#, scheme-format
+msgid "~a, ~a"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:56
+msgid "there is an undefined variable"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:58
+#, scheme-format
+msgid "the origin is ~a"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:61
+#, scheme-format
+msgid "a message is attached: ~a"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:64
+#, scheme-format
+msgid "the values ~s are problematic"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:67
+msgid "there is a kind and args"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:69
+#, scheme-format
+msgid "Unhandled exception type ~a."
+msgstr ""
diff --git a/src/ChangeLog b/src/ChangeLog
new file mode 100644
index 0000000..75ed3d1
--- /dev/null
+++ b/src/ChangeLog
@@ -0,0 +1,5 @@
+2020-11-25  Vivien Kraus  <vivien@planete-kraus.eu>
+
+	* Makefile.am (%canon_reldir%_libwebidoidc_la_SOURCES): the common code is considered a source.
+
+	* utilities.h: Put the common code in that header.
diff --git a/src/Makefile.am b/src/Makefile.am
index a508f40..93fbada 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -23,13 +23,14 @@ webidoidcgo_DATA =
 install_go_targets = install-webidoidcgoDATA
 install_mod_targets = install-webidoidcmodDATA install-dist_webidoidcmodDATA
 
+include %reldir%/base64/Makefile.am
 include %reldir%/pre-inst/Makefile.am
 include %reldir%/inst/Makefile.am
 include %reldir%/scm/Makefile.am
 
 CLEANFILES += $(go_DATA) $(webidoidcgo_DATA) $(mod_DATA) $(webidoidcmod_DATA)
 
-%canon_reldir%_libwebidoidc_la_SOURCES = %reldir%/gettext.h %reldir%/libwebidoidc.c
+%canon_reldir%_libwebidoidc_la_SOURCES = %reldir%/gettext.h %reldir%/libwebidoidc.c %reldir%/utilities.h
 %canon_reldir%_libwebidoidc_la_LIBADD = $(noinst_LTLIBRARIES) $(GUILE_LIBS) $(NETTLE_LIBS)
 
 INDENTED += $(%canon_reldir%_libwebidoidc_la_SOURCES)
diff --git a/src/base64/Makefile.am b/src/base64/Makefile.am
new file mode 100644
index 0000000..11fdc5a
--- /dev/null
+++ b/src/base64/Makefile.am
@@ -0,0 +1,11 @@
+noinst_LTLIBRARIES += %reldir%/libwebidoidc-base64.la
+EXTRA_DIST += %reldir%/libwebidoidc-base64.x
+BUILT_SOURCES += %reldir%/libwebidoidc-base64.x
+
+%canon_reldir%_libwebidoidc_base64_la_LIBADD = $(GUILE_LIBS) $(NETTLE_LIBS)
+
+AM_CFLAGS += -I %reldir% -I $(srcdir)/%reldir%
+
+INDENTED += %reldir%/libwebidoidc-base64.c
+
+%reldir%/libwebidoidc-base64.o: %reldir%/libwebidoidc-base64.x
diff --git a/src/base64/libwebidoidc-base64.c b/src/base64/libwebidoidc-base64.c
new file mode 100644
index 0000000..8eb29b8
--- /dev/null
+++ b/src/base64/libwebidoidc-base64.c
@@ -0,0 +1,38 @@
+#include <utilities.h>
+
+#define _(s) dgettext (PACKAGE, s)
+
+void init_webidoidc_base64 (void);
+
+SCM_DEFINE (webidoidc_base64_encode_g, "base64-encode", 1, 0, 0, (SCM data),
+	    "Encode @var{data} as base64. If @var{data} is a string, first encode it to UTF-8.")
+{
+  size_t c_size;
+  uint8_t *c_data;
+  if (scm_is_string (data))
+    {
+      return webidoidc_base64_encode_g (scm_string_to_utf8 (data));
+    }
+  c_size = scm_c_bytevector_length (data);
+  c_data = scm_gc_malloc_pointerless (c_size, "data");
+  memcpy (c_data, SCM_BYTEVECTOR_CONTENTS (data), c_size);
+  return wrap_bytevector (c_size, c_data);
+}
+
+SCM_DEFINE (webidoidc_base64_decode_g, "base64-decode", 1, 0, 0, (SCM data),
+	    "Decode @var{data} from base64.")
+{
+  size_t c_size;
+  uint8_t *c_data = get_as_bytevector (data, &c_size, 1);
+  SCM ret = scm_c_make_bytevector (c_size);
+  memcpy (SCM_BYTEVECTOR_CONTENTS (ret), c_data, c_size);
+  return ret;
+}
+
+void
+init_webidoidc_base64 (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libwebidoidc-base64.x"
+#endif /* not SCM_MAGIC_SNARFER */
+}
diff --git a/src/libwebidoidc.c b/src/libwebidoidc.c
index 213cbcd..09af3fd 100644
--- a/src/libwebidoidc.c
+++ b/src/libwebidoidc.c
@@ -1,7 +1,9 @@
 #define N_(s)
+void init_webidoidc_base64 (void);
 
 void
 init_webidoidc (void)
 {
   N_("This is the main function.");
+  init_webidoidc_base64 ();
 }
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 4a28425..98859c9 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -14,18 +14,58 @@
 ;; This is a collection of all errors that can happen, and a function
 ;; to log them.
 
-(define*-public (error->str error #:key (max-depth #f))
-  (if (record? error)
-      (let* ((type (record-type-descriptor error))
+(define-public &not-base64
+  (make-exception-type
+   '&not-base64
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-base64 value cause)
+  (raise-exception
+   ((record-constructor &not-base64) value cause)))
+
+(define*-public (error->str err #:key (max-depth #f))
+  (if (record? err)
+      (let* ((type (record-type-descriptor err))
              (get
               (lambda (slot)
-                ((record-accessor type slot) error)))
+                ((record-accessor type slot) err)))
              (recurse
               (if (eqv? max-depth 0)
                   (lambda (err) (G_ "that’s how it is"))
                   (lambda (err)
                     (error->str err #:max-depth (and max-depth (- max-depth 1)))))))
         (case (record-type-name type)
+          ((&not-base64)
+           (format #f (G_ "the value ~s is not a base64 string (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&compound-exception)
+           (let ((components (get 'components)))
+             (if (null? components)
+                 (G_ "that’s it")
+                 (if (null? (cdr components))
+                     (recurse (car components))
+                     (if (null? (cddr components))
+                         (format #f (G_ "~a and ~a")
+                                 (recurse (car components))
+                                 (recurse (cadr components)))
+                         (format #f (G_ "~a, ~a")
+                                 (recurse (car components))
+                                 (recurse (apply make-exception (cdr components)))))))))
+          ((&undefined-variable)
+           (G_ "there is an undefined variable"))
+          ((&origin)
+           (format #f (G_ "the origin is ~a")
+                   (exception-origin err)))
+          ((&message)
+           (format #f (G_ "a message is attached: ~a")
+                   (exception-message err)))
+          ((&irritants)
+           (format #f (G_ "the values ~s are problematic")
+                   (exception-irritants err)))
+          ((&exception-with-kind-and-args)
+           (format #f (G_ "there is a kind and args")))
           (else
-           (error (format #f "Unhandled exception type ~a." (record-type-name type))))))
-      (format #f "~a" error)))
+           (error (format #f (G_ "Unhandled exception type ~a.")
+                          (record-type-name type))))))
+      (format #f "~a" err)))
diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index 273546c..12006e6 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -5,3 +5,14 @@
 (load-extension
  (format #f "~a/libwebidoidc" libdir)
  "init_webidoidc")
+
+(define (fix-base64-decode data)
+  (catch 'base64-decoding-error
+    (lambda ()
+      (base64-decode data))
+    (lambda error
+      (raise-not-base64 data error))))
+
+(export
+ base64-encode
+ (fix-base64-decode . base64-decode))
diff --git a/src/utilities.h b/src/utilities.h
new file mode 100644
index 0000000..b5b91f9
--- /dev/null
+++ b/src/utilities.h
@@ -0,0 +1,88 @@
+#ifndef H_UTILITIES_INCLUDED
+#define H_UTILITIES_INCLUDED
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif /* HAVE_CONFIG_H */
+
+#include <libguile.h>
+#include <assert.h>
+#include <string.h>
+#include <stdlib.h>
+#include <nettle/base64.h>
+#include <nettle/ecc.h>
+#include <nettle/ecdsa.h>
+#include <nettle/rsa.h>
+#include <nettle/ecc-curve.h>
+#include <nettle/yarrow.h>
+#include <gettext.h>
+#include <stdio.h>
+#include <unistd.h>
+
+/* Return a base64 encoding of some raw data. */
+static SCM wrap_bytevector (size_t length, uint8_t * data);
+
+/* Decode a base64 of binary data. */
+static uint8_t *get_as_bytevector (SCM data, size_t *size, int throw_if_fail);
+
+static inline SCM
+wrap_bytevector (size_t length, uint8_t * data)
+{
+  char *head;
+  char tail[BASE64_ENCODE_FINAL_LENGTH];
+  size_t head_size, tail_size;
+  char *full;
+  struct base64_encode_ctx encoder;
+  SCM ret;
+  base64url_encode_init (&encoder);
+  scm_dynwind_begin (0);
+  head = scm_malloc (BASE64_ENCODE_LENGTH (length));
+  scm_dynwind_free (head);
+  head_size = base64_encode_update (&encoder, head, length, data);
+  tail_size = base64_encode_final (&encoder, tail);
+  while (tail_size != 0 && tail[tail_size - 1] == '=')
+    {
+      tail_size--;
+    }
+  full = scm_malloc (head_size + tail_size);
+  memcpy (full, head, head_size);
+  memcpy (full + head_size, tail, tail_size);
+  ret = scm_from_utf8_stringn (full, head_size + tail_size);
+  scm_dynwind_end ();
+  return ret;
+}
+
+static inline uint8_t *
+get_as_bytevector (SCM data, size_t *size, int throw_if_fail)
+{
+  uint8_t *ret = NULL;
+  size_t data_length;
+  char *data_str = NULL;
+  struct base64_decode_ctx decoder;
+  int ok = 1;
+  if (!scm_is_bytevector (data) && !throw_if_fail)
+    {
+      return NULL;
+    }
+  base64url_decode_init (&decoder);
+  scm_dynwind_begin (0);
+  data_str = scm_to_utf8_stringn (data, &data_length);
+  scm_dynwind_free (data_str);
+  ret = scm_malloc (BASE64_DECODE_LENGTH (data_length));
+  /* Not protected! Nothing will throw until scm_dynwind_end. */
+  ok = base64_decode_update (&decoder, size, ret, data_length, data_str);
+  scm_dynwind_end ();
+  if (!ok)
+    {
+      ret = NULL;
+      if (throw_if_fail)
+	{
+	  SCM base64_decoding_error =
+	    scm_from_utf8_symbol ("base64-decoding-error");
+	  scm_throw (base64_decoding_error, scm_list_1 (data));
+	}
+    }
+  return ret;
+}
+
+#endif /* not H_UTILITIES_INCLUDED */
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 1e4b2df..12699f9 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -1,4 +1,7 @@
-TESTS = %reldir%/load-library.scm
+TESTS = \
+  %reldir%/load-library.scm \
+  %reldir%/base64-ok.scm \
+  %reldir%/base64-error.scm
 
 EXTRA_DIST += $(TESTS)
 
@@ -7,3 +10,9 @@ TEST_EXTENSIONS = .scm
 AM_TESTS_ENVIRONMENT = $(top_builddir)/pre-inst-env
 SCM_LOG_COMPILER = $(GUILE)
 AM_SCM_LOG_FLAGS = --no-auto-compile -s
+
+clean-local: %canon_reldir%-clean-local
+
+%canon_reldir%-clean-local:
+	rm -rf %reldir%/*.cache
+	rm -rf %reldir%/*.home
diff --git a/tests/base64-error.scm b/tests/base64-error.scm
new file mode 100644
index 0000000..096e1e8
--- /dev/null
+++ b/tests/base64-error.scm
@@ -0,0 +1,22 @@
+(use-modules
+ (webid-oidc testing)
+ ((webid-oidc stubs) #:prefix stubs:)
+ (webid-oidc errors)
+ (rnrs bytevectors))
+
+(with-test-environment
+ "base64-error"
+ (lambda ()
+   (let ((test "hello :)"))
+     (unless
+         (with-exception-handler
+             (lambda (error)
+               (unless ((record-predicate &not-base64) error)
+                 (exit 1))
+               #t)
+           (lambda ()
+             (stubs:base64-decode test)
+             #f)
+           #:unwind? #t
+           #:unwind-for-type &not-base64)
+       (exit 2)))))
diff --git a/tests/base64-ok.scm b/tests/base64-ok.scm
new file mode 100644
index 0000000..724f2db
--- /dev/null
+++ b/tests/base64-ok.scm
@@ -0,0 +1,17 @@
+(use-modules
+ (webid-oidc testing)
+ ((webid-oidc stubs) #:prefix stubs:)
+ (rnrs bytevectors))
+
+(with-test-environment
+ "base64-ok"
+ (lambda ()
+   (let ((test "hello :)"))
+     (let ((encoded (stubs:base64-encode test)))
+       (unless (string? encoded)
+         (exit 1))
+       (let ((decoded (stubs:base64-decode encoded)))
+         (unless (bytevector? decoded)
+           (exit 2))
+         (unless (equal? test (utf8->string decoded))
+           (exit 3)))))))