(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 &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 &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 &not-a-jwk
  (make-exception-type
   '&not-a-jwk
   &external-error
   '(value cause)))

(define-public (raise-not-a-jwk value cause)
  (raise-exception
   ((record-constructor &not-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)
          ((&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))))
          ((&unsupported-crv)
           (format #f (G_ "the value ~s does not identify an elleptic curve")
                   (get 'crv)))
          ((&not-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)))