summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorVivien Kraus <vivien@planete-kraus.eu>2021-04-26 13:11:11 +0200
committerVivien Kraus <vivien@planete-kraus.eu>2021-06-18 15:43:46 +0200
commit7f1ff0572aa8f7f9c7c65332f695d7d7c07f31e0 (patch)
treef8d2fe8be2a0a55d3e9501cd97bb54d6f24e25c9 /src
parent768488735bbb1ccc905109b4c763e659d961bef0 (diff)
Export a JSON API that is compatible with SRFI-180
SRFI-180 represents JSON objects as alists from symbols to values, while guile-json represents them as alists from strings to values. Since alists are everywhere in the API, we need them to be as standard as possible. So, we need them in SRFI-180 format.
Diffstat (limited to 'src')
-rw-r--r--src/scm/webid-oidc/errors.scm13
-rw-r--r--src/scm/webid-oidc/stubs.scm56
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..0ef3fb5 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 "(input)" 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))