src/scm/webid-oidc/errors.scm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

(define-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 i18n))

(define (G_ text)
  (let ((out (gettext text)))
    (if (string=? out text)
        ;; No translation, disambiguate
        (car (reverse (string-split text #\|)))
        out)))

;; This is a collection of all errors that can happen, and a function
;; to log them.

(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) 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 (G_ "Unhandled exception type ~a.")
                          (record-type-name type))))))
      (format #f "~a" err)))