2 files changed, 68 insertions, 1 deletions
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 98859c9..9d08ed5 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -24,6 +24,16 @@
   (raise-exception
    ((record-constructor &not-base64) value cause)))
 
+(define-public &not-json
+  (make-exception-type
+   'not-json
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-json value cause)
+  (raise-exception
+   ((record-constructor &not-json) value cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -39,6 +49,9 @@
           ((&not-base64)
            (format #f (G_ "the value ~s is not a base64 string (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((not-json)
+           (format #f (G_ "the value ~s is not JSON (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
           ((&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 5858986..2bcc14e 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -1,6 +1,7 @@
 (define-module (webid-oidc stubs)
   #:use-module (webid-oidc config)
-  #:use-module (webid-oidc errors))
+  #:use-module (webid-oidc errors)
+  #:use-module (json))
 
 (load-extension
  (format #f "~a/libwebidoidc" libdir)
@@ -19,3 +20,56 @@
  random
  random-init!
  generate-key)
+
+;; json reader from guile-json will not behave consistently with
+;; SRFI-180 with objects: keys will be mapped to strings, not
+;; symbols. So we fix alist keys to be symbols.
+(define-public (fix-alists data)
+  (define (fix-an-alist rest alist)
+    (if (null? alist)
+        (reverse rest)
+        (let ((k/v (car alist))
+              (tail (cdr alist)))
+          (let ((key (car k/v))
+                (value (cdr k/v)))
+            (fix-an-alist
+             (acons (string->symbol key)
+                    (fix-alists value)
+                    rest)
+             tail)))))
+  (define (fix-a-vector vec)
+    (list->vector
+     (map fix-alists
+          (vector->list vec))))
+  (cond
+   ((list? data)
+    (fix-an-alist '() data))
+   ((vector? data)
+    (fix-a-vector data))
+   (else data)))
+
+(define (fixed:json-string->scm str)
+  (with-exception-handler
+      (lambda (err)
+        (raise-not-json str err))
+    (lambda ()
+      (fix-alists (json-string->scm str)))))
+
+(export (fixed:json-string->scm . json-string->scm))
+
+(define (fixed:json->scm port)
+  (with-exception-handler
+      (lambda (err)
+        (raise-not-json str err))
+    (lambda ()
+      (fix-alists (json->scm port)))))
+
+(export (fixed:json->scm . json->scm))
+
+(define fixed:scm->json-string scm->json-string)
+
+(export (fixed:scm->json-string . scm->json-string))
+
+(define fixed:scm->json scm->json)
+
+(export (fixed:scm->json . scm->json))