From 6bc2ce4c55af6d3f3af7be494c149cbe33d6e08e 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 strip function

---
 src/scm/webid-oidc/errors.scm | 34 ++++++++++++++++++++++++++++++++--
 src/scm/webid-oidc/stubs.scm  | 21 ++++++++++++++++++++-
 2 files changed, 52 insertions(+), 3 deletions(-)

(limited to 'src/scm')

diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 9d08ed5..27dc6e2 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -26,7 +26,7 @@
 
 (define-public &not-json
   (make-exception-type
-   'not-json
+   '&not-json
    &external-error
    '(value cause)))
 
@@ -34,6 +34,26 @@
   (raise-exception
    ((record-constructor &not-json) value cause)))
 
+(define-public &unsupported-crv
+  (make-exception-type
+   '&unsupported-crv
+   &external-error
+   '(crv)))
+
+(define-public (raise-unsupported-crv crv)
+  (raise-exception
+   ((record-constructor &unsupported-crv) crv)))
+
+(define-public &not-a-jwk
+  (make-exception-type
+   '&not-a-jwk
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-jwk value cause)
+  (raise-exception
+   ((record-constructor &not-a-jwk) value cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -49,9 +69,19 @@
           ((&not-base64)
            (format #f (G_ "the value ~s is not a base64 string (because ~a)")
                    (get 'value) (recurse (get 'cause))))
-          ((not-json)
+          ((&not-json)
            (format #f (G_ "the value ~s is not JSON (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((&unsupported-crv)
+           (format #f (G_ "the value ~s does not identify an elleptic curve")
+                   (get 'crv)))
+          ((&not-a-jwk)
+           (let ((cause (get 'cause)))
+             (if cause
+                 (format #f (G_ "the value ~s does not identify a JWK (because ~a)")
+                         (get 'value) cause)
+                 (format #f (G_ "the value ~s does not identify a JWK")
+                         (get 'value)))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index 0ef3fb5..ff94497 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -14,12 +14,31 @@
     (lambda error
       (raise-not-base64 data error))))
 
+(define (fix-generate-key . args)
+  (catch 'unsupported-crv
+    (lambda ()
+      (apply generate-key args))
+    (lambda (error)
+      (raise-unsupported-crv (cadr error)))))
+
+(define (fix-kty key)
+  (catch 'unsupported-crv
+    (lambda ()
+      (let ((ret (kty key)))
+        (unless ret
+          (raise-not-a-jwk key #f))
+        ret))
+    (lambda (error)
+      (raise-unsupported-crv (cadr error)))))
+
 (export
  base64-encode
  (fix-base64-decode . base64-decode)
  random
  random-init!
- generate-key)
+ (fix-generate-key . generate-key)
+ (fix-kty . kty)
+ strip-key)
 
 ;; 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