blob: 98859c9d6eb7ddca737d451b2748426eb80f4e8f (
about) (
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
|
(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 (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))))
((&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)))
|