diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-09 18:46:48 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-13 01:06:38 +0200 |
commit | ded10e28782f289ad3db15320bcf619ab4336876 (patch) | |
tree | 32609fd9f1eb0d2f8a23105e09f193827d16a275 /src/scm/webid-oidc/server | |
parent | 7b62790238902e10edb83c07286cf0643b097997 (diff) |
Switch to a more sensible error reporting system
Diffstat (limited to 'src/scm/webid-oidc/server')
-rw-r--r-- | src/scm/webid-oidc/server/create.scm | 53 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/delete.scm | 3 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/log.scm | 3 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/precondition.scm | 18 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/read.scm | 27 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/resource/path.scm | 112 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/resource/wac.scm | 71 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/update.scm | 7 |
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 |