Switch to a more sensible error reporting system

1 files changed, 63 insertions, 8 deletions

diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm
index 073d77b..e3ed089 100644
--- a/src/scm/webid-oidc/server/resource/wac.scm
+++ b/src/scm/webid-oidc/server/resource/wac.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
@@ -23,6 +23,7 @@
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (rdf rdf)
@@ -35,11 +36,26 @@
   #:use-module (ice-9 textual-ports)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 threads)
+  #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (oop goops)
+  #:declarative? #t
   #:export
   (
 
+   &cannot-fetch-group
+   make-cannot-fetch-group
+   cannot-fetch-group?
+   cannot-fetch-group-uri
+
+   &forbidden
+   make-forbidden
+   forbidden?
+   forbidden-path
+   forbidden-user
+   forbidden-owner
+   forbidden-expected-mode
+
    wac-get-modes
 
    check-acl-can-read
@@ -49,6 +65,23 @@
 
    ))
 
+(define-exception-type
+  &cannot-fetch-group
+  &external-error
+  make-cannot-fetch-group
+  cannot-fetch-group?
+  (group-uri cannot-fetch-group-uri))
+
+(define-exception-type
+  &forbidden
+  &external-error
+  make-forbidden
+  forbidden?
+  (path forbidden-path)
+  (user forbidden-user)
+  (owner forbidden-owner)
+  (expected-mode forbidden-expected-mode))
+
 (define (group-member? http-get group-uri agent)
   (when (string? group-uri)
     (set! group-uri (string->uri group-uri)))
@@ -63,9 +96,19 @@
                     #:query (uri-query group-uri))))
     (with-exception-handler
         (lambda (error)
-          (raise-exception
-           (make-cannot-fetch-group group-uri error)
-           #:continuable? #t)
+          (let ((final-message
+                 (if (exception-with-message? error)
+                     (format #f (G_ "cannot fetch group ~s: ~a")
+                             (uri->string group-uri)
+                             (exception-message error))
+                     (format #f (G_ "cannot fetch group ~s")
+                             (uri->string group-uri)))))
+            (raise-exception
+             (make-exception
+              (make-cannot-fetch-group group-uri)
+              (make-exception-with-message final-message)
+              error)
+             #:continuable? #t))
           #f)
       (lambda ()
         (let ((data (fetch group-doc-uri #:http-get http-get)))
@@ -252,8 +295,10 @@
        (accumulate-unique
         '()
         (sort all-modes
-              (lambda (a b)
-                (string< (uri->string a) (uri->string b)))))))))
+              (match-lambda*
+                (((? uri? (= uri->string a))
+                  (? uri? (= uri->string b)))
+                 (string< a b)))))))))
 
 (define (check-mode server-name path owner user http-get expected-mode)
   (unless (equal? owner user)
@@ -271,8 +316,18 @@
     (let ((modes (wac-get-modes server-name path user #:http-get http-get)))
       (define (check-modes modes)
         (if (null? modes)
-            (raise-exception
-             (make-forbidden path user owner expected-mode))
+            (let ((final-message
+                   (format #f (G_ "the resource under ~s is owned by ~s, and ~s can’t access it with ~s")
+                           path
+                           (uri->string owner)
+                           (if user
+                               (uri->string user)
+                               (G_ "is owned by ..., and <> can’t access it|an anonymous user"))
+                           (uri->string expected-mode))))
+              (raise-exception
+               (make-exception
+                (make-forbidden path user owner expected-mode)
+                (make-exception-with-message final-message))))
             (or
              (equal? (car modes) expected-mode)
              ;; It is also OK if we’re asking for acl:Append but