Switch to a more sensible error reporting system

8 files changed, 260 insertions, 34 deletions

diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm
index b7b208d..dc9651e 100644
--- a/src/scm/webid-oidc/server/create.scm
+++ b/src/scm/webid-oidc/server/create.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
@@ -21,6 +21,7 @@
   #:use-module (webid-oidc server read)
   #:use-module (webid-oidc cache)
   #:use-module (webid-oidc fetch)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (webid-oidc rdf-index)
   #:use-module (webid-oidc server resource wac)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
@@ -42,20 +43,51 @@
   #:use-module (ice-9 threads)
   #:use-module (rnrs bytevectors)
   #:use-module (oop goops)
+  #:declarative? #t
   #:export
   (
 
+   &incorrect-containment-triples
+   make-incorrect-containment-triples
+   incorrect-containment-triples?
+   incorrect-containment-triples-path
+
+   &unsupported-media-type
+   make-unsupported-media-type
+   unsupported-media-type?
+   unsupported-media-type-content-type
+
    create
    create-root
 
    ))
 
+(define-exception-type
+  &incorrect-containment-triples
+  &external-error
+  make-incorrect-containment-triples
+  incorrect-containment-triples?
+  (path incorrect-containment-triples-path))
+
+(define-exception-type
+  &unsupported-media-type
+  &external-error
+  make-unsupported-media-type
+  unsupported-media-type?
+  (content-type unsupported-media-type-content-type))
+
 (define (without-containment-triples doc-uri content-type content)
   (case content-type
     ((text/turtle)
      #t)
     (else
-     (raise-exception (make-unsupported-media-type content-type))))
+     (let ((final-message
+            (format #f (G_ "only text/turtle is allowed for the target of a POST request, not ~s")
+                    content-type)))
+       (raise-exception
+        (make-exception
+         (make-unsupported-media-type content-type)
+         (make-exception-with-message final-message))))))
   (let ((graph (fetch
                 doc-uri
                 #:http-get
@@ -69,8 +101,13 @@
        (unless (null? (rdf-match (uri->string doc-uri)
                                  "http://www.w3.org/ns/auth/acl#contains"
                                  #f))
-         (raise-exception (make-incorrect-containment-triples
-                           (uri-path doc-uri))))))))
+         (let ((final-message
+                (format #f (G_ "the created resource cannot have containment triples"))))
+           (raise-exception
+            (make-exception
+             (make-incorrect-containment-triples
+              (uri-path doc-uri))
+             (make-exception-with-message final-message)))))))))
 
 (define (types-indicate-container? types)
   (and (not (null? types))
@@ -106,7 +143,13 @@
              ;; non-empty.
              (if container? "/" "")))))
       (when (auxiliary-path? (uri-path doc-uri))
-        (raise-exception (make-path-is-auxiliary (uri-path doc-uri))))
+        (let ((final-message
+               (format #f (G_ "cannot POST to an auxiliary resource path, ~s")
+                       (uri-path doc-uri))))
+          (raise-exception
+           (make-exception
+            (make-path-is-auxiliary (uri-path doc-uri))
+            (make-exception-with-message final-message)))))
       (when container?
         (without-containment-triples doc-uri content-type content))
       (with-session
diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm
index b5fb3a9..4e4ce66 100644
--- a/src/scm/webid-oidc/server/delete.scm
+++ b/src/scm/webid-oidc/server/delete.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
@@ -43,6 +43,7 @@
   #:use-module (ice-9 hash-table)
   #:use-module (rnrs bytevectors)
   #:use-module (oop goops)
+  #:declarative? #t
   #:export
   (
 
diff --git a/src/scm/webid-oidc/server/log.scm b/src/scm/webid-oidc/server/log.scm
index f7dfa48..23c13c6 100644
--- a/src/scm/webid-oidc/server/log.scm
+++ b/src/scm/webid-oidc/server/log.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -16,6 +16,7 @@
 
 (define-module (webid-oidc server log)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:declarative? #t
   #:export
   (
    prepare-log-file
diff --git a/src/scm/webid-oidc/server/precondition.scm b/src/scm/webid-oidc/server/precondition.scm
index 6912a7a..03ee967 100644
--- a/src/scm/webid-oidc/server/precondition.scm
+++ b/src/scm/webid-oidc/server/precondition.scm
@@ -44,10 +44,28 @@
   #:export
   (
 
+   &precondition-failed
+   make-precondition-failed
+   precondition-failed?
+   precondition-failed-path
+   precondition-failed-if-match
+   precondition-failed-if-none-match
+   precondition-failed-etag
+
    check-precondition
 
    ))
 
+(define-exception-type
+  &precondition-failed
+  &external-error
+  make-precondition-failed
+  precondition-failed?
+  (path precondition-failed-path)
+  (if-match precondition-failed-if-match)
+  (if-none-match precondition-failed-if-none-match)
+  (etag precondition-failed-etag))
+
 (define (the-etag object)
   ;; Sometimes the user passes a pair as an etag (just like what
   ;; request-if-match may return).
diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm
index aecde36..e672b15 100644
--- a/src/scm/webid-oidc/server/read.scm
+++ b/src/scm/webid-oidc/server/read.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
@@ -22,6 +22,7 @@
   #:use-module (webid-oidc fetch)
   #:use-module (webid-oidc http-link)
   #:use-module (webid-oidc server resource wac)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
@@ -44,10 +45,24 @@
   #:export
   (
 
+   &auxiliary-resource-absent
+   make-auxiliary-resource-absent
+   auxiliary-resource-absent?
+   auxiliary-resource-absent-base-path
+   auxiliary-resource-absent-path-type
+
    read
 
    ))
 
+(define-exception-type
+  &auxiliary-resource-absent
+  &external-error
+  make-auxiliary-resource-absent
+  auxiliary-resource-absent?
+  (base-path auxiliary-resource-absent-base-path)
+  (path-type auxiliary-resource-absent-path-type))
+
 (define* (read server-name owner user path
                #:key
                (http-get http-get))
@@ -86,8 +101,14 @@
                               (container? '(GET HEAD OPTIONS POST PUT DELETE))
                               (else '(GET HEAD OPTIONS PUT DELETE)))))
              (unless relevant-etag
-               (raise-exception
-                (make-auxiliary-resource-absent base-path path-type)))
+               (let ((final-message
+                      (format #f (G_ "the auxiliary resource of type ~s at ~s is absent")
+                              (uri->string path-type)
+                              (uri->string base-path))))
+                 (raise-exception
+                  (make-exception
+                   (make-auxiliary-resource-absent base-path path-type)
+                   (exception-with-message final-message)))))
              (let ((accept-put (if (or container? path-type)
                                    "text/turtle; application/n-quads; application/ld+json"
                                    "*/*")))
diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm
index 55c4274..b8a9472 100644
--- a/src/scm/webid-oidc/server/resource/path.scm
+++ b/src/scm/webid-oidc/server/resource/path.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
@@ -18,6 +18,7 @@
   #:use-module (webid-oidc errors)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
@@ -31,9 +32,35 @@
   #:use-module (ice-9 threads)
   #:use-module (rnrs bytevectors)
   #:use-module (oop goops)
+  #:declarative? #t
   #:export
   (
 
+   &path-not-found
+   make-path-not-found
+   path-not-found?
+   path-not-found-path
+
+   &uri-slash-semantics-error
+   make-uri-slash-semantics-error
+   uri-slash-semantics-error?
+   uri-slash-semantics-error-requested
+   uri-slash-semantics-error-existing
+
+   &container-not-empty
+   make-container-not-empty
+   container-not-empty?
+   container-not-empty-path
+
+   &cannot-delete-root
+   make-cannot-delete-root
+   cannot-delete-root?
+
+   &path-is-auxiliary
+   make-path-is-auxiliary
+   path-is-auxiliary?
+   path-is-auxiliary-path
+
    read-path
    update-path
 
@@ -48,6 +75,41 @@
 
    ))
 
+(define-exception-type
+  &path-not-found
+  &external-error
+  make-path-not-found
+  path-not-found?
+  (path path-not-found-path))
+
+(define-exception-type
+  &uri-slash-semantics-error
+  &external-error
+  make-uri-slash-semantics-error
+  uri-slash-semantics-error?
+  (requested uri-slash-semantics-error-requested)
+  (existing uri-slash-semantics-error-existing))
+
+(define-exception-type
+  &container-not-empty
+  &external-error
+  make-container-not-empty
+  container-not-empty?
+  (path container-not-empty-path))
+
+(define-exception-type
+  &cannot-delete-root
+  &external-error
+  make-cannot-delete-root
+  cannot-delete-root?)
+
+(define-exception-type
+  &path-is-auxiliary
+  &external-error
+  make-path-is-auxiliary
+  path-is-auxiliary?
+  (path path-is-auxiliary-path))
+
 (define (hash-path/lock path)
   (let ((h (stubs:hash 'SHA-256 path))
         (dir (p:data-home)))
@@ -78,17 +140,30 @@
                   (without-slash-exists (file-exists? (hash-path without-slash))))
               (cond
                (with-slash-exists
-                (raise-exception
-                 (make-exception
-                  (make-path-not-found path)
-                  (make-uri-slash-semantics-error path with-slash))))
+                (let ((final-message
+                       (format #f (G_ "incorrect slash semantics: path ~s should have a slash")
+                               path)))
+                  (raise-exception
+                   (make-exception
+                    (make-path-not-found path)
+                    (make-uri-slash-semantics-error path with-slash)
+                    (make-exception-with-message final-message)))))
                (without-slash-exists
-                (raise-exception
-                 (make-exception
-                  (make-path-not-found path)
-                  (make-uri-slash-semantics-error path with-slash))))
+                (let ((final-message
+                       (format #f (G_ "incorrect slash semantics: path ~s should not have a slash")
+                               path)))
+                  (raise-exception
+                   (make-exception
+                    (make-path-not-found path)
+                    (make-uri-slash-semantics-error path without-slash)
+                    (make-exception-with-message final-message)))))
                (else
-                (raise-exception (make-path-not-found path)))))))
+                (let ((final-message
+                       (format #f (G_ "path ~s does not exist") path)))
+                  (raise-exception
+                   (make-exception
+                    (make-path-not-found path)
+                    (make-exception-with-message final-message)))))))))
       (lambda ()
         (call-with-input-file h
           (lambda (port)
@@ -152,19 +227,28 @@
            (case-lambda
              ((false)
               (when false
-                (error "You’re using the API wrong."))
+                (fail (G_ "You’re using the API wrong.")))
               ;; Delete the resource
               (unless (or (not etag)
                           (not (contained etag))
                           (null? (contained etag)))
-                (raise-exception (make-container-not-empty path)))
+                (raise-exception
+                 (make-exception
+                  (make-container-not-empty path)
+                  (make-exception-with-message
+                   (format #f (G_ "the path ~s exists, it has contained paths, and it is not empty")
+                           path)))))
               (when (equal? path "/")
-                (raise-exception (make-cannot-delete-root)))
+                (raise-exception
+                 (make-exception
+                  (make-cannot-delete-root)
+                  (make-exception-with-message
+                   (format #f (G_ "you cannot delete the root"))))))
               (set! has-been-deleted? #t)
               #f)
              ((new-etag new-auxiliary)
               (unless (and (string? new-etag) (list? new-auxiliary))
-                (error "You’re using the API wrong."))
+                (fail (G_ "You’re using the API wrong.")))
               (hash-remove! garbage new-etag)
               (when new-auxiliary
                 (for-each
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
diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm
index 2e811ae..3eec8f8 100644
--- a/src/scm/webid-oidc/server/update.scm
+++ b/src/scm/webid-oidc/server/update.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
@@ -43,6 +43,7 @@
   #:use-module (ice-9 hash-table)
   #:use-module (rnrs bytevectors)
   #:use-module (oop goops)
+  #:declarative? #t
   #:export
   (
 
@@ -55,7 +56,9 @@
     ((text/turtle)
      #t)
     (else
-     (raise-exception (make-unsupported-media-type content-type))))
+     (raise-exception
+      (make-exception
+       (make-unsupported-media-type content-type)))))
   (let ((graph (fetch
                 doc-uri
                 #:http-get