From 2fc254c809e42029f28982404870604633b35521 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Wed, 1 Jan 2020 00:00:00 +0100
Subject: Add a hash function

---
 src/scm/webid-oidc/errors.scm | 15 +++++++++++++++
 src/scm/webid-oidc/stubs.scm  | 12 ++++++++++--
 2 files changed, 25 insertions(+), 2 deletions(-)

(limited to 'src/scm/webid-oidc')

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
-- 
cgit v1.2.3