diff options
Diffstat (limited to 'src/scm/webid-oidc')
| -rw-r--r-- | src/scm/webid-oidc/errors.scm | 105 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/Makefile.am | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/resource/path.scm | 185 |
3 files changed, 272 insertions, 24 deletions
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 52f5db8..60e45f7 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -870,6 +870,56 @@ (raise-exception ((record-constructor &no-provider-candidates) webid causes))) +;; Server-side exceptions + +(define-exception-type + &path-not-found + &external-error + make-path-not-found + path-not-found? + (path path-not-found-path)) + +(export &path-not-found + make-path-not-found + path-not-found? + path-not-found-path) + +(define-exception-type + &uri-slash-semantics-error + &external-error + make-uri-slash-semantics-error + uri-slash-semantics-error? + (path uri-slash-semantics-error-path) + (expected-path uri-slash-semantics-error-expected-path)) + +(export &uri-slash-semantics-error + make-uri-slash-semantics-error + uri-slash-semantics-error? + uri-slash-semantics-error-path + uri-slash-semantics-error-expected-path) + +(define-exception-type + &cannot-delete-root + &external-error + make-cannot-delete-root + cannot-delete-root?) + +(export &cannot-delete-root + make-cannot-delete-root + cannot-delete-root?) + +(define-exception-type + &container-not-empty + &external-error + make-container-not-empty + container-not-empty? + (path container-not-empty-path)) + +(export &container-not-empty + make-container-not-empty + container-not-empty? + container-not-empty-path) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -1193,28 +1243,39 @@ ((&unconfirmed-provider) (format #f (G_ "~s does not admit ~s as an identity provider") (get 'subject) (get 'provider))) - ((&neither-identity-provider-nor-webid) - (format #f (G_ "~a is neither an identity provider (because ~a) nor a webid (because ~a)") - (uri->string (get 'uri)) - (recurse (get 'why-not-identity-provider)) - (recurse (get 'why-not-webid)))) - ((&token-request-failed) - (format #f (G_ "the token request failed (because ~a)") - (recurse (get 'cause)))) - ((&profile-not-found) - (format #f (G_ "you don’t have a refresh token for identity ~a certified by ~a in ~s") - (uri->string (get 'webid)) - (uri->string (get 'iss)) - (get 'dir))) - ((&no-provider-candidates) - (format #f (G_ "all identity provider candidates for ~a failed: ~a") - (uri->string (get 'webid)) - (string-join - (map (lambda (cause) - (format #f (G_ "~s failed (because ~a)") - (uri->string (car cause)) (recurse (cdr cause)))) - (get 'causes)) - (G_ ", ")))) + ((&neither-identity-provider-nor-webid) + (format #f (G_ "~a is neither an identity provider (because ~a) nor a webid (because ~a)") + (uri->string (get 'uri)) + (recurse (get 'why-not-identity-provider)) + (recurse (get 'why-not-webid)))) + ((&token-request-failed) + (format #f (G_ "the token request failed (because ~a)") + (recurse (get 'cause)))) + ((&profile-not-found) + (format #f (G_ "you don’t have a refresh token for identity ~a certified by ~a in ~s") + (uri->string (get 'webid)) + (uri->string (get 'iss)) + (get 'dir))) + ((&no-provider-candidates) + (format #f (G_ "all identity provider candidates for ~a failed: ~a") + (uri->string (get 'webid)) + (string-join + (map (lambda (cause) + (format #f (G_ "~s failed (because ~a)") + (uri->string (car cause)) (recurse (cdr cause)))) + (get 'causes)) + (G_ ", ")))) + ((&path-not-found) + (format #f (G_ "no resource has been found to serve URI path ~s") + (get 'path))) + ((&uri-slash-semantics-error) + (format #f (G_ "no resource has been found to serve URI path ~s, but ~s exists") + (get 'path) (get 'expected-path))) + ((&cannot-delete-root) + (format #f (G_ "the root storage cannot be deleted"))) + ((&container-not-empty) + (format #f (G_ "the container ~s should be emptied before being deleted") + (get 'path))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/server/resource/Makefile.am b/src/scm/webid-oidc/server/resource/Makefile.am index 88103cc..49cc912 100644 --- a/src/scm/webid-oidc/server/resource/Makefile.am +++ b/src/scm/webid-oidc/server/resource/Makefile.am @@ -1,5 +1,7 @@ dist_resourceserverwebidoidcmod_DATA += \ - %reldir%/content.scm + %reldir%/content.scm \ + %reldir%/path.scm resourceserverwebidoidcgo_DATA += \ - %reldir%/content.go + %reldir%/content.go \ + %reldir%/path.go diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm new file mode 100644 index 0000000..a637d60 --- /dev/null +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -0,0 +1,185 @@ +(define-module (webid-oidc server resource path) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (webid-oidc rdf-index) + #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module (web uri) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (ice-9 iconv) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 threads) + #:use-module (rnrs bytevectors) + #:use-module (oop goops) + #:export + ( + + read-path + update-path + + )) + +(define (default-dir) + (string-append (refresh:default-dir) "/server")) + +(define (hash-path path) + (let ((h (stubs:hash 'SHA-256 path)) + (dir (default-dir))) + (let ((first-char (substring h 0 1)) + (rest (substring h 1))) + (format #f "~a/path/~a/~a" dir first-char rest)))) + +(define (read-path path) + (let ((h (hash-path path))) + (with-exception-handler + (lambda (error) + (let ((with-slash (string-append path "/")) + (without-slash + (if (string-suffix? "/" path) + (substring path 0 (- (string-length path) (string-length "/"))) + path))) + (let ((with-slash-exists (file-exists? (hash-path with-slash))) + (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)))) + (without-slash-exists + (raise-exception + (make-exception + (make-path-not-found path) + (make-uri-slash-semantics-error path with-slash)))) + (else + (raise-exception (make-path-not-found path))))))) + (lambda () + (call-with-input-file h + (lambda (port) + (let ((main-etag (read port))) + (let ((auxiliary (read port))) + (values main-etag + (map (lambda (cell) + (let ((key (string->uri (car cell))) + (value (string->uri (cdr cell)))) + (cons key value))) + auxiliary)))))))))) + +(define* (update-path path f content-type contained static-content create delete + #:key (create-intermediate-containers? #f)) + (let ((h (hash-path path)) + (garbage (make-hash-table)) + (has-been-created? #f) + (has-been-deleted? #f) + (parent-path + (let ((components (split-and-decode-uri-path path))) + (cond + ((null? components) + #f) + ((null? (cdr components)) + "/") + (else + (string-append + "/" + (encode-and-join-uri-path + (reverse + (cdr + (reverse components)))) + "/")))))) + (stubs:atomically-update-file + h + (lambda (port) + (receive (etag auxiliary) + (with-exception-handler + (lambda (error) + (unless (path-not-found? error) + (raise-exception error)) + (set! has-been-created? #t) + (values #f #f)) + (lambda () + (read-path path)) + #:unwind? #t + #:unwind-for-type &path-not-found) + (when etag + (hash-set! garbage etag #t)) + (when auxiliary + (for-each + (lambda (cell) + (when (cdr cell) + (hash-set! garbage (cdr cell) #t))) + auxiliary)) + (call-with-values + (lambda () + (f etag auxiliary)) + (case-lambda + ((false) + (when false + (error "You’re using the API wrong.")) + ;; Delete the resource + (unless (null? (contained etag)) + (raise-exception (make-container-not-empty path))) + (when (equal? path "/") + (raise-exception (make-cannot-delete-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.")) + (hash-remove! garbage new-etag) + (when new-auxiliary + (for-each + (lambda (cell) + (hash-remove! garbage (cdr cell))) + new-auxiliary)) + (write new-etag port) + (write (map (lambda (cell) + (cons (uri->string (car cell)) + (cdr cell))) + new-auxiliary) + port) + #t)))))) + (when (and parent-path has-been-created? (not has-been-deleted?)) + (update-path + parent-path + (lambda (etag auxiliary) + ;; Add path as a child of the resource at etag + (unless create-intermediate-containers? + (unless etag + ;; Typically, POST to a non-existing path + (raise-exception (make-path-not-found parent-path)))) + (unless auxiliary + (set! auxiliary '())) + (let ((content-type (if etag (content-type etag) 'text/turtle)) + (other-children (if etag (contained etag) '())) + (static-content (if etag (static-content etag) (string->utf8 "")))) + (unless (eq? content-type 'text/turtle) + (raise-exception (make-not-a-container parent-path content-type))) + (let ((new-etag + (create content-type (cons path other-children) static-content))) + (values new-etag auxiliary)))) + content-type contained static-content create delete + #:create-intermediate-containers? create-intermediate-containers?)) + (when (and parent-path has-been-deleted? (not has-been-created?)) + (update-path + parent-path + (lambda (etag auxiliary) + (unless etag + (raise-exception (make-path-not-found parent-path))) + (let ((content-type (content-type etag)) + (all-children (contained etag)) + (static-content (static-content etag))) + (values + (create content-type + (filter (lambda (x) + (not (equal? x path))) + all-children) + static-content) + auxiliary))) + content-type contained static-content create delete + #:create-intermediate-containers? create-intermediate-containers?)) + (for-each + delete + (hash-map->list (lambda (garbage false) garbage) garbage)))) |