From 7e125cc85c79e0854ca300dec6f819598e3fc6b0 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Fri, 27 Nov 2020 19:28:50 +0100
Subject: Add a base64 encoder and decoder

---
 src/scm/webid-oidc/errors.scm | 52 ++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 46 insertions(+), 6 deletions(-)

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

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