path: root/src/scm/webid-oidc/errors.scm

(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)
  #:use-module (web response))

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

(define-public (raise-not-a-public-jwk value cause)
  (raise-exception
   ((record-constructor &not-a-public-jwk) value cause)))

(define-public &not-a-private-jwk
  (make-exception-type
   '&not-a-private-jwk
   &external-error
   '(value cause)))

(define-public (raise-not-a-private-jwk value cause)
  (raise-exception
   ((record-constructor &not-a-private-jwk) value cause)))

(define-public &not-a-jwks
  (make-exception-type
   '&not-a-jwks
   &external-error
   '(value cause)))

(define-public (raise-not-a-jwks value cause)
  (raise-exception
   ((record-constructor &not-a-jwks) value cause)))

(define-public &unsupported-alg
  (make-exception-type
   '&unsupported-alg
   &external-error
   '(value)))

(define-public (raise-unsupported-alg value)
  (raise-exception
   ((record-constructor &unsupported-alg) value)))

(define-public &invalid-signature
  (make-exception-type
   '&invalid-signature
   &external-error
   '(key payload signature)))

(define-public (raise-invalid-signature key payload signature)
  (raise-exception
   ((record-constructor &invalid-signature) key payload signature)))

(define-public &not-a-jws-header
  (make-exception-type
   '&not-a-jws-header
   &external-error
   '(value cause)))

(define-public (raise-not-a-jws-header value cause)
  (raise-exception
   ((record-constructor &not-a-jws-header) value cause)))

(define-public &not-a-jws-payload
  (make-exception-type
   '&not-a-jws-payload
   &external-error
   '(value cause)))

(define-public (raise-not-a-jws-payload value cause)
  (raise-exception
   ((record-constructor &not-a-jws-payload) value cause)))

(define-public &not-a-jws
  (make-exception-type
   '&not-a-jws
   &external-error
   '(value cause)))

(define-public (raise-not-a-jws value cause)
  (raise-exception
   ((record-constructor &not-a-jws-payload) value cause)))

(define-public &not-in-3-parts
  (make-exception-type
   '&not-in-3-parts
   &external-error
   '(string separator)))

(define-public (raise-not-in-3-parts string separator)
  (raise-exception
   ((record-constructor &not-in-3-parts) string separator)))

(define-public &missing-alist-key
  (make-exception-type
   '&missing-alist-key
   &external-error
   '(value key)))

(define-public (raise-missing-alist-key value key)
  (raise-exception
   ((record-constructor &missing-alist-key) value key)))

(define-public &no-matching-key
  (make-exception-type
   '&no-matching-key
   &external-error
   '(candidates alg payload signature other-problems)))

(define-public (raise-no-matching-key candidates alg payload signature)
  (raise-exception
   ((record-constructor &no-matching-key) candidates alg payload signature)))

(define-public &cannot-decode-jws
  (make-exception-type
   '&cannot-decode-jws
   &external-error
   '(value cause)))

(define-public (raise-cannot-decode-jws value cause)
  (raise-exception
   ((record-constructor &cannot-decode-jws) value cause)))

(define-public &cannot-encode-jws
  (make-exception-type
   '&cannot-encode-jws
   &external-error
   '(jws key cause)))

(define-public (raise-cannot-encode-jws jws key cause)
  (raise-exception
   ((record-constructor &cannot-encode-jws) jws key cause)))

(define-public &request-failed-unexpectedly
  (make-exception-type
   '&request-failed-unexpectedly
   &external-error
   '(response-code response-reason-phrase)))

(define-public (raise-request-failed-unexpectedly
                response-code response-reason-phrase)
  (raise-exception
   ((record-constructor &request-failed-unexpectedly)
    response-code response-reason-phrase)))

(define-public &unexpected-header-value
  (make-exception-type
   '&unexpected-header-value
   &external-error
   '(header value)))

(define-public (raise-unexpected-header-value header value)
  (raise-exception
   ((record-constructor &unexpected-header-value) header value)))

(define-public &unexpected-response
  (make-exception-type
   '&unexpected-response
   &external-error
   '(response cause)))

(define-public (raise-unexpected-response response cause)
  (raise-exception
   ((record-constructor &unexpected-response) response cause)))

(define-public &not-an-oidc-configuration
  (make-exception-type
   '&not-an-oidc-configuration
   &external-error
   '(value cause)))

(define-public (raise-not-an-oidc-configuration value cause)
  (raise-exception
   ((record-constructor &not-an-oidc-configuration) 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) (recurse cause))
                 (format #f (G_ "the value ~s does not identify a JWK")
                         (get 'value)))))
          ((&not-a-public-jwk)
           (let ((cause (get 'cause)))
             (if cause
                 (format #f (G_ "the value ~s does not identify a public JWK (because ~a)")
                         (get 'value) (recurse cause))
                 (format #f (G_ "the value ~s does not identify a public JWK")
                         (get 'value)))))
          ((&not-a-private-jwk)
           (let ((cause (get 'cause)))
             (if cause
                 (format #f (G_ "the value ~s does not identify a private JWK (because ~a)")
                         (get 'value) cause)
                 (format #f (G_ "the value ~s does not identify a private JWK")
                         (get 'value)))))
          ((&not-a-jwks)
           (let ((cause (get 'cause)))
             (if cause
                 (format #f (G_ "the value ~s does not identify a JWKS (because ~a)")
                         (get 'value) (recurse cause))
                 (format #f (G_ "the value ~s does not identify a JWKS")
                         (get 'value)))))
          ((&unsupported-alg)
           (format #f (G_ "the value ~s does not identify a hash algorithm")
                   (get 'value)))
          ((&missing-alist-key)
           (format #f (G_ "the value ~s is not an alist or misses key ~s")
                   (get 'value) (get 'key)))
          ((&not-a-jws-header)
           (format #f (G_ "the value ~s is not a JWS header (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-a-jws-payload)
           (format #f (G_ "the value ~s is not a JWS payload (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-a-jws)
           (format #f (G_ "the value ~s is not a JWS (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-in-3-parts)
           (format #f (G_ "the string ~s cannot be split in 3 parts with ~s")
                   (get 'string) (get 'separator)))
          ((&no-matching-key)
           (format #f (G_ "all key candidates failed to verify signature ~s with algorithm ~s and payload ~a (there were ~a: ~s)")
                   (get 'signature) (get 'alg) (get 'payload) (length (get 'candidates)) (get 'candidates)))
          ((&cannot-decode-jws)
           (format #f (G_ "I cannot decode JWS ~a (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&cannot-encode-jws)
           (format #f (G_ "I cannot encode JWS ~a (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&response-failed-unexpectedly)
           (format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s")
                   (get 'response-code) (get 'response-reason-phrase)))
          ((&unexpected-header-value)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the header ~a should not have the value ~s")
                         (get 'header) value)
                 (format #f (G_ "the header ~a should be present")
                         (get 'header)))))
          ((&unexpected-response)
           (format #f (G_ "the server response wasn't expected: ~s (because ~a)")
                   (call-with-output-string
                     (lambda (port)
                       (write-response (get 'response) port)))
                   (recurse (get 'cause))))
          ((&not-an-oidc-configuration)
           (format #f (G_ "the value ~s is not an OIDC configuration (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)))))))))
          ((&invalid-signature)
           (format #f (G_ "the signature ~a does not match key ~s with payload ~a")
                   (get 'signature) (get 'key) (get 'payload)))
          ((&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")))
          ((&assertion-failure)
           (format #f (G_ "there is an assertion failure")))
          ((&quit-exception)
           (format #f (G_ "the program quits with code ~a")
                   (get 'code)))
          (else
           (error (format #f (G_ "Unhandled exception type ~a.")
                          (record-type-name type))))))
      (format #f "~a" err)))