blob: 27dc6e22b1978bd5b0e6d0a938267e3772dd19c5 (
plain)
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
(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 ¬-base64
(make-exception-type
'¬-base64
&external-error
'(value cause)))
(define-public (raise-not-base64 value cause)
(raise-exception
((record-constructor ¬-base64) value cause)))
(define-public ¬-json
(make-exception-type
'¬-json
&external-error
'(value cause)))
(define-public (raise-not-json value cause)
(raise-exception
((record-constructor ¬-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 ¬-a-jwk
(make-exception-type
'¬-a-jwk
&external-error
'(value cause)))
(define-public (raise-not-a-jwk value cause)
(raise-exception
((record-constructor ¬-a-jwk) 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)
((¬-base64)
(format #f (G_ "the value ~s is not a base64 string (because ~a)")
(get 'value) (recurse (get 'cause))))
((¬-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)))
((¬-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)
(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)))
|
