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 &incorrect-webid-field
  (make-exception-type
   '&incorrect-webid-field
   &external-error
   '(value)))

(define-public (raise-incorrect-webid-field value)
  (raise-exception
   ((record-constructor &incorrect-webid-field) value)))

(define-public &incorrect-iss-field
  (make-exception-type
   '&incorrect-iss-field
   &external-error
   '(value)))

(define-public (raise-incorrect-iss-field value)
  (raise-exception
   ((record-constructor &incorrect-iss-field) value)))

(define-public &incorrect-aud-field
  (make-exception-type
   '&incorrect-aud-field
   &external-error
   '(value)))

(define-public (raise-incorrect-aud-field value)
  (raise-exception
   ((record-constructor &incorrect-aud-field) value)))

(define-public &incorrect-iat-field
  (make-exception-type
   '&incorrect-iat-field
   &external-error
   '(value)))

(define-public (raise-incorrect-iat-field value)
  (raise-exception
   ((record-constructor &incorrect-iat-field) value)))

(define-public &incorrect-exp-field
  (make-exception-type
   '&incorrect-exp-field
   &external-error
   '(value)))

(define-public (raise-incorrect-exp-field value)
  (raise-exception
   ((record-constructor &incorrect-exp-field) value)))

(define-public &incorrect-cnf/jkt-field
  (make-exception-type
   '&incorrect-cnf/jkt-field
   &external-error
   '(value)))

(define-public (raise-incorrect-cnf/jkt-field value)
  (raise-exception
   ((record-constructor &incorrect-cnf/jkt-field) value)))

(define-public &incorrect-client-id-field
  (make-exception-type
   '&incorrect-client-id-field
   &external-error
   '(value)))

(define-public (raise-incorrect-client-id-field value)
  (raise-exception
   ((record-constructor &incorrect-client-id-field) value)))

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

(define-public (raise-not-an-access-token value cause)
  (raise-exception
   ((record-constructor &not-an-access-token) value cause)))

(define-public &not-an-access-token-header
  (make-exception-type
   '&not-an-access-token-header
   &external-error
   '(value cause)))

(define-public (raise-not-an-access-token-header value cause)
  (raise-exception
   ((record-constructor &not-an-access-token-header) value cause)))

(define-public &not-an-access-token-payload
  (make-exception-type
   '&not-an-access-token-payload
   &external-error
   '(value cause)))

(define-public (raise-not-an-access-token-payload value cause)
  (raise-exception
   ((record-constructor &not-an-access-token-payload) value cause)))

(define-public &cannot-fetch-issuer-configuration
  (make-exception-type
   '&cannot-fetch-issuer-configuration
   &external-error
   '(issuer cause)))

(define-public (raise-cannot-fetch-issuer-configuration issuer cause)
  (raise-exception
   ((record-constructor &cannot-fetch-issuer-configuration) issuer cause)))

(define-public &cannot-fetch-jwks
  (make-exception-type
   '&cannot-fetch-jwks
   &external-error
   '(issuer uri cause)))

(define-public (raise-cannot-fetch-jwks issuer uri cause)
  (raise-exception
   ((record-constructor &cannot-fetch-jwks) issuer uri cause)))

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

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

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

(define-public (raise-cannot-encode-access-token access-token key cause)
  (raise-exception
   ((record-constructor &cannot-encode-access-token) access-token key 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))))
          ((&incorrect-webid-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the webid field is incorrect: ~s") value)
                 (format #f (G_ "the webid field is missing")))))
          ((&incorrect-iss-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the iss field is incorrect: ~s") value)
                 (format #f (G_ "the iss field is missing")))))
          ((&incorrect-aud-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the aud field is incorrect: ~s") value)
                 (format #f (G_ "the aud field is missing")))))
          ((&incorrect-iat-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the iat field is incorrect: ~s") value)
                 (format #f (G_ "the iat field is missing")))))
          ((&incorrect-exp-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the exp field is incorrect: ~s") value)
                 (format #f (G_ "the exp field is missing")))))
          ((&incorrect-cnf/jkt-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the cnf/jkt field is incorrect: ~s") value)
                 (format #f (G_ "the cnf/jkt field is missing")))))
          ((&incorrect-client-id-field)
           (let ((value (get 'value)))
             (if value
                 (format #f (G_ "the client-id field is incorrect: ~s") value)
                 (format #f (G_ "the client-id field is missing")))))
          ((&not-an-access-token)
           (format #f (G_ "~s is not an access token (because ~a)"
                          (get 'value) (recurse (get 'cause)))))
          ((&not-an-access-token-header)
           (format #f (G_ "~s is not an access token header (because ~a)"
                          (get 'value) (recurse (get 'cause)))))
          ((&not-an-access-token-payload)
           (format #f (G_ "~s is not an access token payload (because ~a)"
                          (get 'value) (recurse (get 'cause)))))
          ((&cannot-fetch-issuer-configuration)
           (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)"
                          (let ((iss (get 'issuer)))
                            (when (uri? iss)
                              (set! iss (uri->string iss)))
                            iss)
                          (recurse (get 'cause)))))
          ((&cannot-fetch-jwks)
           (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)"
                          (let ((iss (get 'issuer)))
                            (when (uri? iss)
                              (set! iss (uri->string iss)))
                            iss)
                          (let ((uri (get 'uri)))
                            (when (uri? uri)
                              (set! uri (uri->string uri)))
                            uri)
                          (recurse (get 'cause)))))
          ((&cannot-decode-access-token)
           (format #f (G_ "I cannot decode ~s as an access token (because ~a)"
                          (get 'value) (recurse (get 'cause)))))
          ((&cannot-encode-access-token)
           (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)")
                   (get 'access-token) (get 'key) (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)))