Switch to a more sensible error reporting system

1 files changed, 191 insertions, 51 deletions

diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index 08d15aa..e029b7c 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -16,84 +16,201 @@
 
 (define-module (webid-oidc stubs)
   #:use-module (webid-oidc config)
-  #:use-module (webid-oidc errors)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 i18n)
   #:use-module (webid-oidc parameters)
-  #:use-module (json))
+  #:use-module (json)
+  #:export
+  (
+
+   &invalid-base64-data
+   make-invalid-base64-data
+   invalid-base64-data?
+   error-base64-data
+
+   &unsupported-elliptic-curve
+   make-unsupported-elliptic-curve
+   unsupported-elliptic-curve?
+   unsupported-elliptic-curve-value
+
+   &unsupported-algorithm
+   make-unsupported-algorithm
+   unsupported-algorithm?
+   unsupported-algorithm-alg
+   unsupported-algorithm-application
+
+   &invalid-signature
+   make-invalid-signature
+   invalid-signature?
+   invalid-signature-alg
+   invalid-signature-key
+   invalid-signature-payload
+   invalid-signature-signature
+
+   &invalid-json
+   make-invalid-json
+   invalid-json?
+   invalid-json-input
+   
+   base64-encode
+   (fix-base64-decode . base64-decode)
+   random
+   (fix-random-init! . random-init!)
+   (fix-generate-key . generate-key)
+   kty
+   strip-key
+   (fix-hash . hash)
+   jkt
+   (fix-sign . sign)
+   (fix-verify . verify)
+   (fixed:json-string->scm . json-string->scm)
+   (fixed:json->scm . json->scm)
+   (fixed:scm->json-string . scm->json-string)
+   (fixed:scm->json . scm->json)
+
+   mkdir-p
+   open-output-file*
+   call-with-output-file*
+   atomically-update-file
+   
+   ))
+
+(define (G_ text)
+  (let ((out (gettext text)))
+    (if (string=? out text)
+        ;; No translation, disambiguate
+        (car (reverse (string-split text #\|)))
+        out)))
 
 (load-extension
  (format #f "~a/libwebidoidc" libdir)
  "init_webidoidc")
 
+(define-exception-type
+  &invalid-base64-data
+  &external-error
+  make-invalid-base64-data
+  invalid-base64-data?
+  (data error-base64-data))
+
+(define (summarize str)
+  (if (> (string-length str) 10)
+      (format #f "~s"
+              (string-append
+               (substring str 0 10)
+               "..."))
+      (format #f "~s" str)))
+
 (define (fix-base64-decode data)
   (catch 'base64-decoding-error
     (lambda ()
       (base64-decode data))
     (lambda error
-      (raise-not-base64 data error))))
+      (let ((final-message
+             (format #f (G_ "invalid base64 data: ~a")
+                     (summarize data))))
+        (raise-exception
+         (make-exception
+          (make-invalid-base64-data data)
+          (make-exception-with-message final-message)
+          (make-exception-with-irritants (list data))))))))
+
+(define-exception-type
+  &unsupported-elliptic-curve
+  &external-error
+  make-unsupported-elliptic-curve
+  unsupported-elliptic-curve?
+  (curve unsupported-elliptic-curve-value))
+
+(define (unsupported-crv crv)
+  (let ((final-message
+         (format #f (G_ "~s is not a recognized elliptic curve")
+                 crv)))
+    (raise-exception
+     (make-exception
+      (make-unsupported-elliptic-curve crv)
+      (make-exception-with-message final-message)
+      (make-exception-with-irritants (list crv))))))
 
 (define (fix-generate-key . args)
   (catch 'unsupported-crv
     (lambda ()
       (apply generate-key args))
-    (lambda (error)
-      (raise-unsupported-crv (cadr error)))))
-
-(define (fix-kty key)
-  (catch 'unsupported-crv
-    (lambda ()
-      (let ((ret (kty key)))
-        (unless ret
-          (raise-not-a-jwk key #f))
-        ret))
     (lambda error
-      (raise-unsupported-crv (cadr error)))))
+      (unsupported-crv (cadr error)))))
+
+(define-exception-type
+  &unsupported-algorithm
+  &external-error
+  make-unsupported-algorithm
+  unsupported-algorithm?
+  (alg unsupported-algorithm-alg)
+  ;; 'sign or 'hash:
+  (application unsupported-algorithm-application))
+
+(define (unsupported-alg alg application)
+  (let ((final-message
+         (case application
+           ((sign)
+            (format #f (G_ "~s is not a supported signature algorithm")
+                    alg))
+           ((hash)
+            (format #f (G_ "~s is not a supported hash algorithm")
+                    alg)))))
+    (raise-exception
+     (make-exception
+      (make-unsupported-algorithm alg application)
+      (make-exception-with-message final-message)
+      (make-exception-with-irritants (list alg))))))
 
 (define (fix-hash alg payload)
   (catch 'unsupported-alg
     (lambda ()
       (hash alg payload))
     (lambda error
-      (raise-unsupported-alg (cadr error)))))
+      (unsupported-alg alg 'hash))))
 
 (define (fix-sign alg key payload)
   (catch 'unsupported-alg
     (lambda ()
       (sign alg key payload))
     (lambda error
-      (raise-unsupported-alg (cadr error)))))
+      (unsupported-alg alg 'sign))))
+
+(define-exception-type
+  &invalid-signature
+  &external-error
+  make-invalid-signature
+  invalid-signature?
+  (alg invalid-signature-alg)
+  (key invalid-signature-key)
+  (payload invalid-signature-payload)
+  (signature invalid-signature-signature))
 
 (define (fix-verify alg key payload signature)
   (catch 'unsupported-alg
     (lambda ()
-      (let ((ok
-             (verify alg key payload signature)))
+      (let ((ok (verify alg key payload signature)))
         (unless ok
-          (raise-invalid-signature key payload signature))))
+          (let ((final-message
+                 (format #f (G_ "the signature is invalid"))))
+            (raise-exception
+             (make-exception
+              (make-invalid-signature alg key payload signature)
+              (make-exception-with-message final-message)
+              (make-exception-with-irritants (list alg key payload signature))))))))
     (lambda error
-      (raise-unsupported-alg (cadr error)))))
+      (unsupported-alg alg 'sign))))
 
 (define (fix-random-init!)
   (setenv "XDG_CACHE_HOME" (cache-home))
   (setenv "DISFLUID_APPLICATION_NAME" ".")
   (random-init!))
 
-(export
- base64-encode
- (fix-base64-decode . base64-decode)
- random
- (fix-random-init! . random-init!)
- (fix-generate-key . generate-key)
- (fix-kty . kty)
- strip-key
- (fix-hash . hash)
- jkt
- (fix-sign . sign)
- (fix-verify . verify))
-
 ;; json reader from guile-json will not behave consistently with
 ;; SRFI-180 with objects: keys will be mapped to strings, not
 ;; symbols. So we fix alist keys to be symbols.
-(define-public (fix-alists data)
+(define (fix-alists data)
   (define (fix-an-alist rest alist)
     (if (null? alist)
         (reverse rest)
@@ -117,33 +234,47 @@
     (fix-a-vector data))
    (else data)))
 
+(define-exception-type
+  &invalid-json
+  &external-error
+  make-invalid-json
+  invalid-json?
+  (input invalid-json-input))
+
 (define (fixed:json-string->scm str)
   (with-exception-handler
-      (lambda (err)
-        (raise-not-json str err))
+      (lambda (exn)
+        (let ((final-message
+               (format #f (G_ "invalid JSON data: ~a")
+                       (summarize str))))
+          (raise-exception
+           (make-exception
+            (make-invalid-json str)
+            (make-exception-with-message final-message)
+            (make-exception-with-irritants (list str))
+            exn))))
     (lambda ()
       (fix-alists (json-string->scm str)))))
 
-(export (fixed:json-string->scm . json-string->scm))
-
 (define (fixed:json->scm port)
   (with-exception-handler
       (lambda (err)
-        (raise-not-json "(input)" err))
+        (let ((final-message 
+               (format #f (G_ "invalid JSON data in input port"))))
+          (raise-exception
+           (make-exception
+            (make-invalid-json "(input)")
+            (make-exception-with-message final-message)
+            (make-exception-with-irritants (list port))
+            exn))))
     (lambda ()
       (fix-alists (json->scm port)))))
 
-(export (fixed:json->scm . json->scm))
-
 (define fixed:scm->json-string scm->json-string)
 
-(export (fixed:scm->json-string . scm->json-string))
-
 (define fixed:scm->json scm->json)
 
-(export (fixed:scm->json . scm->json))
-
-(define-public (mkdir-p name)
+(define (mkdir-p name)
   (catch 'system-error
     (lambda ()
       (mkdir name))
@@ -159,15 +290,15 @@
         (else
          (throw key subr message args rest))))))
 
-(define-public (open-output-file* filename . args)
+(define (open-output-file* filename . args)
   (mkdir-p (dirname filename))
   (apply open-output-file filename args))
 
-(define-public (call-with-output-file* filename . args)
+(define (call-with-output-file* filename . args)
   (mkdir-p (dirname filename))
   (apply call-with-output-file filename args))
 
-(define-public (atomically-update-file file lock-file-name f)
+(define (atomically-update-file file lock-file-name f)
   ;; Call f with an output port. If f returns #f, delete the original
   ;; file. Otherwise, replace it.
   (let ((updating-file-name (string-append file "~")))
@@ -187,7 +318,16 @@
                 (with-exception-handler
                     (lambda (error)
                       (false-if-exception (delete-file updating-file-name))
-                      (raise-exception error))
+                      (let ((final-message
+                             (if (exception-with-message? error)
+                                 (format #f (G_ "while updating file ~s: ~a")
+                                         file (exception-message error))
+                                 (format #f (G_ "an error happened while updating file ~s")
+                                         file))))
+                        (raise-exception
+                         (make-exception
+                          (make-exception-with-message final-message)
+                          error))))
                   (lambda ()
                     (let ((ok (f port)))
                       (fsync port)