diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-30 10:30:40 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-04 22:51:36 +0200 |
commit | 4a144d76950ac002996c3941c1eb4a5a6de6a661 (patch) | |
tree | cb7d3ec06647d1ceff2cb638064fc650c0f98622 /src | |
parent | 668aa5736b2709e15e3ea14381e010c8646a4c38 (diff) |
Content API: use GOOPS for the cache
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/server/create.scm | 279 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/delete.scm | 53 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/read.scm | 301 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/resource/content.scm | 209 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/resource/path.scm | 129 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/resource/wac.scm | 108 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/update.scm | 153 |
7 files changed, 656 insertions, 576 deletions
diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm index 0558ff3..6c2a619 100644 --- a/src/scm/webid-oidc/server/create.scm +++ b/src/scm/webid-oidc/server/create.scm @@ -119,58 +119,58 @@ (types-indicate-container? (cdr types)))))) (define* (create server-name owner user container types slug content-type content) - (check-acl-can-append server-name container owner user) - (unless (and slug (not (equal? slug ""))) - (set! slug (stubs:random 12))) - (when (string-contains slug "/") - (let ((i (string-contains slug "/"))) - (set! slug (substring slug 0 i)))) - (let ((container? (types-indicate-container? types))) - (let ((doc-uri - (build-uri - (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path - (string-append - "/" - (encode-and-join-uri-path - (append (split-and-decode-uri-path container) - (list slug))) - ;; There’s no risk to have // here, because slug is - ;; non-empty. - (if container? "/" ""))))) - (when (auxiliary-path? (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 - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (catch 'slug-already-exists - (lambda () - (update-path - (uri-path doc-uri) - (lambda (etag auxiliary) - (when etag - (throw 'slug-already-exists)) - (values - (do-create content-type (and container? '()) content) - '())) - load-content-type load-contained load-static-content - do-create do-delete) - doc-uri) - (lambda error - (create server-name owner user container types - (string-append slug "-" (stubs:random 12)) - content-type content)))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-append server-name container owner user) + (unless (and slug (not (equal? slug ""))) + (set! slug (stubs:random 12))) + (when (string-contains slug "/") + (let ((i (string-contains slug "/"))) + (set! slug (substring slug 0 i)))) + (let ((container? (types-indicate-container? types))) + (let ((doc-uri + (build-uri + (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path + (string-append + "/" + (encode-and-join-uri-path + (append (split-and-decode-uri-path container) + (list slug))) + ;; There’s no risk to have // here, because slug is + ;; non-empty. + (if container? "/" ""))))) + (when (auxiliary-path? (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)) + (parameterize ((current-content-cache (make <content-cache>))) + (catch 'slug-already-exists + (lambda () + (update-path + (uri-path doc-uri) + (lambda (main auxiliary) + (when main + (throw 'slug-already-exists)) + (values + (make <content> + #:content-type content-type + #:contained (and container? '()) + #:static-content content) + '()))) + doc-uri) + (lambda error + (create server-name owner user container types + (string-append slug "-" (stubs:random 12)) + content-type content)))))))) (define (create-root server-name owner) (define (fix-angle-aux accu chars) @@ -185,29 +185,32 @@ (fix-angle-aux (append next-accu accu) rest))))) (define (fix-angle str) (fix-angle-aux '() (string->list str))) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (catch 'already-exists - (lambda () - (update-path - "/" - (lambda (etag auxiliary) - (when etag - (throw 'already-exists)) - (let ((root-uri - (build-uri - (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path "/"))) - (values - (do-create 'text/turtle '() "") - (list - (cons (string->uri "http://www.w3.org/ns/auth/acl#accessControl") - (do-create 'text/turtle #f - (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (parameterize ((current-content-cache (make <content-cache>))) + (catch 'already-exists + (lambda () + (update-path + "/" + (lambda (main auxiliary) + (when main + (throw 'already-exists)) + (let ((root-uri + (build-uri + (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path "/"))) + (values + (make <content> + #:content-type 'text/turtle + #:contained '() + #:static-content "") + (list + `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,(make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . <#default> a acl:Authorization; @@ -216,66 +219,68 @@ acl:mode acl:Read, acl:Write, acl:Control; acl:default <~a>. " - (fix-angle (uri->string root-uri)) - (fix-angle (uri->string owner)) - (fix-angle - (uri->string - (build-uri (uri-scheme root-uri) - #:userinfo (uri-userinfo root-uri) - #:host (uri-host root-uri) - #:port (uri-port root-uri) - #:path "/")))))))))) - load-content-type load-contained load-static-content - do-create do-delete) - #t) - (lambda error - #f)) - (when (and (equal? (uri-scheme server-name) - (uri-scheme owner)) - (equal? (uri-userinfo server-name) - (uri-userinfo owner)) - (equal? (uri-host server-name) - (uri-host owner)) - (equal? (uri-port server-name) - (uri-port owner))) - ;; We need to make sure that the profile exists - (catch 'already-exists - (lambda () - (update-path - (uri-path owner) - (lambda (etag auxiliary) - (when etag - (throw 'already-exists)) - (values - (do-create 'text/turtle #f - (format #f "@prefix foaf: <http://xmlns.com/foaf/0.1/> . + (fix-angle (uri->string root-uri)) + (fix-angle (uri->string owner)) + (fix-angle + (uri->string + (build-uri (uri-scheme root-uri) + #:userinfo (uri-userinfo root-uri) + #:host (uri-host root-uri) + #:port (uri-port root-uri) + #:path "/"))))))))))) + #t) + (lambda error + #f)) + (when (and (equal? (uri-scheme server-name) + (uri-scheme owner)) + (equal? (uri-userinfo server-name) + (uri-userinfo owner)) + (equal? (uri-host server-name) + (uri-host owner)) + (equal? (uri-port server-name) + (uri-port owner))) + ;; We need to make sure that the profile exists + (catch 'already-exists + (lambda () + (update-path + (uri-path owner) + (lambda (main auxiliary) + (when main + (throw 'already-exists)) + (values + (make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix foaf: <http://xmlns.com/foaf/0.1/> . @prefix ldp: <http://www.w3.org/ns/ldp#> . <~a~a> a foaf:Person . " - (if (uri-query owner) - (string-append - "?" - (fix-angle - (uri-encode (uri-query owner)))) - "") - (if (uri-fragment owner) - (string-append - "#" - (fix-angle - (uri-encode (uri-fragment owner)))) - ""))) - (list - (cons (string->uri "http://www.w3.org/ns/auth/acl#accessControl") - (let ((doc-uri - (build-uri - (uri-scheme owner) - #:userinfo (uri-userinfo owner) - #:host (uri-host owner) - #:port (uri-port owner) - #:path (uri-path owner)))) - (do-create 'text/turtle #f - (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . + (if (uri-query owner) + (string-append + "?" + (fix-angle + (uri-encode (uri-query owner)))) + "") + (if (uri-fragment owner) + (string-append + "#" + (fix-angle + (uri-encode (uri-fragment owner)))) + ""))) + (list + `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,(let ((doc-uri + (build-uri + (uri-scheme owner) + #:userinfo (uri-userinfo owner) + #:host (uri-host owner) + #:port (uri-port owner) + #:path (uri-path owner)))) + (make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . @prefix foaf: <http://xmlns.com/foaf/0.1/> . <#public> @@ -290,10 +295,8 @@ acl:agent <~a>; acl:mode acl:Read, acl:Write, acl:Control. " - (fix-angle (uri->string doc-uri)) - (fix-angle (uri->string doc-uri)) - (fix-angle (uri->string owner))))))))) - load-content-type load-contained load-static-content - do-create do-delete - #:create-intermediate-containers? #t)) - (lambda error #f)))))) + (fix-angle (uri->string doc-uri)) + (fix-angle (uri->string doc-uri)) + (fix-angle (uri->string owner))))))))) + #:create-intermediate-containers? #t)) + (lambda error #f))))) diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm index 02344ad..445622c 100644 --- a/src/scm/webid-oidc/server/delete.scm +++ b/src/scm/webid-oidc/server/delete.scm @@ -41,6 +41,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 threads) #:use-module (ice-9 hash-table) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t @@ -52,30 +53,28 @@ )) (define* (delete server-name owner user path if-match if-none-match) - (check-acl-can-write server-name path owner user) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (receive (base-path path-type) - (base-path path) - (update-path - base-path - (lambda (main-etag auxiliary) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag))) - (check-precondition path if-match if-none-match relevant-etag) - (if path-type - ;; Delete an auxiliary resource - (values - main-etag - (filter - (lambda (auxiliary) - (not (equal? (car auxiliary) path-type))) - auxiliary)) - ;; Delete the main resource, if it’s not the root and - ;; it’s not a non-empty container (those things are - ;; checked by update-path). - #f))) - load-content-type load-contained load-static-content do-create do-delete))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-write server-name path owner user) + (receive (base-path path-type) + (base-path path) + (update-path + base-path + (lambda (main auxiliary) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main))) + (check-precondition path if-match if-none-match (and relevant (etag relevant))) + (if path-type + ;; Delete an auxiliary resource + (values + main + (filter + (match-lambda + ((type . content) + (not (equal? type path-type)))) + auxiliary)) + ;; Delete the main resource, if it’s not the root and + ;; it’s not a non-empty container (those things are + ;; checked by update-path). + #f))))))) diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm index 0cd49fd..73d32e3 100644 --- a/src/scm/webid-oidc/server/read.scm +++ b/src/scm/webid-oidc/server/read.scm @@ -65,157 +65,150 @@ (define* (read server-name owner user path) (declare-link-header!) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (check-acl-can-read server-name path owner user) - (receive (base-path path-type) - (base-path path) - (let ((container? (container-path? path)) - (root? (root-path? path)) - (acl? - (equal? path-type - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - (description? - (equal? - path-type - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby")))) - (receive (main-etag auxiliary) - (read-path base-path) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag)) - (needs-meta? - (case (load-content-type main-etag) - ((text/turtle) - #f) - (else #t))) - (needs-acl? - (not acl?)) - (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) - (container? '(GET HEAD OPTIONS POST PUT DELETE)) - (else '(GET HEAD OPTIONS PUT DELETE))))) - (unless relevant-etag - (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) - (make-exception-with-message final-message))))) - (let ((accept-put (if (or container? path-type) - "text/turtle; application/n-quads; application/ld+json" - "*/*"))) - (values - ;; Headers - (let ((links - (let ((type - (cons - (if container? - (string->uri "http://www.w3.org/ns/ldp#BasicContainer") - (string->uri "http://www.w3.org/ns/ldp#Resource")) - '((rel . "type")))) - (acl - (and needs-acl? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - '((rel . "acl"))))) - (describedby - (and needs-meta? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) - '((rel . "describedby"))))) - (describes - (and description? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path base-path) - '((rel . "https://www.w3.org/ns/iana/link-relations/relation#describes"))))) - (storage - (and root? - (list - (list - (string->uri "http://www.w3.org/ns/pim/space#Storage") - '(rel . "type")) - (list - owner - '(rel . "http://www.w3.org/ns/solid/terms#owner")))))) - (append - (list type) - (if acl (list acl) '()) - (if describedby (list describedby) '()) - (if describes (list describes) '()) - (or storage '()))))) - `((link . ,links) - (allow . ,allow) - (accept-put . ,accept-put) - (content-type - . (,(if container? - 'text/turtle - (load-content-type relevant-etag)))) - (etag . (,relevant-etag . #f)))) - ;; Content - (if container? - (let ((static-graph - (parameterize - ((p:anonymous-http-request - (lambda (uri . args) - (values - (build-response - #:headers `((content-type ,(load-content-type relevant-etag)))) - (load-static-content relevant-etag))))) - (fetch - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path))))) - (let ((final-graph - (reverse - (append - (map (lambda (contained-path) - (make-rdf-triple - (uri->string - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path)) - "http://www.w3.org/ns/ldp#contains" - (uri->string - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path contained-path)))) - (load-contained relevant-etag)) - static-graph)))) - (rdf->turtle final-graph))) - (load-static-content relevant-etag))))))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-read server-name path owner user) + (receive (base-path path-type) + (base-path path) + (let ((container? (container-path? path)) + (root? (root-path? path)) + (acl? + (equal? path-type + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + (description? + (equal? + path-type + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby")))) + (receive (main auxiliary) + (read-path base-path) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main)) + (needs-meta? + (case (content-type main) + ((text/turtle) + #f) + (else #t))) + (needs-acl? + (not acl?)) + (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) + (container? '(GET HEAD OPTIONS POST PUT DELETE)) + (else '(GET HEAD OPTIONS PUT DELETE))))) + (unless relevant + (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) + (make-exception-with-message final-message))))) + (let ((accept-put (if (or container? path-type) + "text/turtle; application/n-quads; application/ld+json" + "*/*"))) + (values + ;; Headers + (let ((links + (let ((type + `(,(string->uri + (string-append "http://www.w3.org/ns/ldp#" + (if container? + "BasicContainer" + "Resource"))) + (rel . "type"))) + (acl + (and needs-acl? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + (rel . "acl")))) + (describedby + (and needs-meta? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + (rel . "describedby")))) + (describes + (and needs-meta? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path base-path) + (rel . "https://www.w3.org/ns/iana/link-relations/relation#describes")))) + (storage + (and root? + `((,(string->uri "http://www.w3.org/ns/pim/space#Storage") + (rel . "type")) + (,owner + (rel . "http://www.w3.org/ns/solid/terms#owner")))))) + (append + (list type) + (if acl (list acl) '()) + (if describedby (list describedby) '()) + (if describes (list describes) '()) + (or storage '()))))) + `((link . ,links) + (allow . ,allow) + (accept-put . ,accept-put) + (content-type + . (,(if container? + 'text/turtle + (content-type relevant)))) + (etag . (,(etag relevant) . #f)))) + ;; Content + (if container? + (let ((static-graph + (parameterize + ((p:anonymous-http-request + (lambda (uri . args) + (values + (build-response + #:headers `((content-type ,(content-type relevant)))) + (static-content relevant))))) + (fetch + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path))))) + (let ((final-graph + (reverse + (append + (map (lambda (contained-path) + (make-rdf-triple + (uri->string + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path)) + "http://www.w3.org/ns/ldp#contains" + (uri->string + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path contained-path)))) + (contained relevant)) + static-graph)))) + (rdf->turtle final-graph))) + (static-content relevant)))))))))) diff --git a/src/scm/webid-oidc/server/resource/content.scm b/src/scm/webid-oidc/server/resource/content.scm index 57c51dd..f0d12a5 100644 --- a/src/scm/webid-oidc/server/resource/content.scm +++ b/src/scm/webid-oidc/server/resource/content.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,6 +16,7 @@ (define-module (webid-oidc server resource content) #:use-module (webid-oidc errors) + #: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:) @@ -28,79 +29,165 @@ #:use-module (ice-9 iconv) #:use-module (ice-9 textual-ports) #:use-module (ice-9 binary-ports) - #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) #:use-module (oop goops) + #:declarative? #t #:export ( - with-session + <content> + etag + content-type + contained + static-content + + <content-cache> + cache + delete-content + + current-content-cache )) (define-class <content> () + (etag #:init-keyword #:etag #:getter etag) (content-type #:init-keyword #:content-type #:getter content-type) (contained #:init-keyword #:contained #:getter contained) (static-content #:init-keyword #:static-content #:getter static-content)) -(define (load-content session etag) - (let ((first-char (substring etag 0 1)) - (rest (substring etag 1))) - (call-with-input-file (format #f "~a/server/content/~a/~a" - (p:data-home) - first-char - rest) - (lambda (port) - (let ((properties (read port))) - (set-port-encoding! port "ISO-8859-1") - (let ((ret - (make <content> - #:content-type (assq-ref properties 'content-type) - #:contained (assq-ref properties 'contained) - #:static-content - (string->bytevector (get-string-all port) "ISO-8859-1")))) - (hash-set! session etag ret) - ret)))))) - -(define (new-content session content-type contained static-content) - (when (string? static-content) - (set! static-content (string->utf8 static-content))) - (let ((etag (stubs:random 12))) - (let ((first-char (substring etag 0 1)) - (rest (substring etag 1))) - (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) - (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) - (logior O_WRONLY O_CREAT O_EXCL)))) - (write `((content-type . ,content-type) - (contained . ,contained)) port) - (set-port-encoding! port "ISO-8859-1") - (display (bytevector->string static-content "ISO-8859-1") port) - (close-port port) - (hash-set! session - etag - (make <content> - #:content-type content-type - #:contained contained - #:static-content static-content)) - etag)))) - -(define (delete-content etag) +(define-class <content-cache> () + (cache #:init-thunk make-hash-table #:getter cache)) + +(define current-content-cache + (make-parameter #f)) + +(define (filter-keyword check arguments) + (let scan ((arguments arguments) + (kept '())) + (match arguments + (() + (let reverse ((reversed kept) + (final '())) + (match reversed + (() final) + ((key value reversed ...) + (reverse reversed `(,key ,value ,@final)))))) + (((? check key) value arguments ...) + (scan arguments `(,key ,value ,@kept))) + ((_ _ arguments ...) + (scan arguments kept))))) + +(define-method (initialize (content <content>) initargs) + (let-keywords + initargs #t + ((etag #f) + (content-type #f) + (contained #f) + (static-content #f) + (cache (current-content-cache)) + (save-to-cache (current-content-cache))) + (cond + ((and (not (eq? content-type 'text/turtle)) + (list? contained)) + ;; Error: containers must be RDF + (fail (G_ "content with contained resources must be RDF"))) + ((and etag content-type static-content) + ;; Construct it the normal way + (unless (string? etag) + (scm-error 'wrong-type-arg "make" + (G_ "#:etag should be a string") + '() + (list etag))) + (unless (symbol? content-type) + (scm-error 'wrong-type-arg "make" + (G_ "#:content-type should be a symbol") + '() + (list content-type))) + (unless (or (not contained) + (list? contained)) + (scm-error 'wrong-type-arg "make" + (G_ "#:contained should be a list if not #f") + '() + (list contained))) + (when (string? static-content) + (set! static-content (string->utf8 static-content))) + (unless (bytevector? static-content) + (scm-error 'wrong-type-arg "make" + (G_ "#:static-content should be a bytevector") + '() + (list static-content))) + (slot-set! content 'etag etag) + (slot-set! content 'content-type content-type) + (slot-set! content 'contained contained) + (slot-set! content 'static-content static-content) + (when save-to-cache + (hash-set! (slot-ref save-to-cache 'cache) etag content))) + ((and cache etag) + ;; Load the content from disk or from the session + (let ((cached (hash-ref (slot-ref save-to-cache 'cache) etag))) + (if cached + (initialize content `(#:etag ,etag + #:content-type ,(slot-ref cached 'content-type) + #:contained ,(slot-ref cached 'contained) + #:static-content ,(slot-ref cached 'static-content) + ,@initargs)) + ;; The cache is useless, try again without it + (parameterize ((current-content-cache #f)) + (initialize + content + `(#:save-to-cache ,cache + ,@(filter-keyword (lambda (key) (not (equal? key #:cache))) + initargs))))))) + (etag + (let ((first-char (substring etag 0 1)) + (rest (substring etag 1))) + (call-with-input-file (format #f "~a/server/content/~a/~a" + (p:data-home) + first-char + rest) + (lambda (port) + (let ((properties (read port))) + (set-port-encoding! port "ISO-8859-1") + (initialize + content + `(#:etag ,etag + #:content-type ,(assq-ref properties 'content-type) + #:contained ,(assq-ref properties 'contained) + #:static-content + ,(string->bytevector (get-string-all port) "ISO-8859-1") + ,@initargs))))))) + ((and content-type static-content) + ;; Save it to disk and generate an ETag + (let ((etag (stubs:random 12))) + ;; Recursive call before touching the file system, so if + ;; there’s an error we won’t create garbage + (initialize content `(#:etag ,etag ,@initargs)) + ;; static-content may be a string converted to bytevector by + ;; the recursive call + (set! static-content (slot-ref content 'static-content)) + (let ((first-char (substring etag 0 1)) + (rest (substring etag 1))) + (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) + (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) + (logior O_WRONLY O_CREAT O_EXCL)))) + (write `((content-type . ,content-type) + (contained . ,contained)) port) + (set-port-encoding! port "ISO-8859-1") + (display (bytevector->string static-content "ISO-8859-1") port) + (close-port port) + (when save-to-cache + (hash-set! (slot-ref save-to-cache 'cache) etag content)))))) + (else + (fail (G_ "not enough arguments to create or load a <content>")))))) + +(define (delete-etag etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) (delete-file (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest)))) -(define (with-session f) - (let ((session (make-hash-table))) - (define (do-load etag) - (or (hash-ref session etag) - (load-content session etag))) - (define (get-content-type etag) - (content-type (do-load etag))) - (define (get-contained etag) - (contained (do-load etag))) - (define (get-static-content etag) - (static-content (do-load etag))) - (define (do-create content-type contained static-content) - (new-content session content-type contained static-content)) - (define (do-delete etag) - (delete-content etag)) - (f get-content-type get-contained get-static-content do-create do-delete))) +(define-method (delete-content (content <content>)) + (delete-etag (etag content))) + +(define-method (delete-content (etag <string>)) + (delete-etag etag)) diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm index b8a9472..667dd2f 100644 --- a/src/scm/webid-oidc/server/resource/path.scm +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -19,6 +19,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc server resource content) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) @@ -30,7 +31,9 @@ #: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 (srfi srfi-26) #:use-module (oop goops) #:declarative? #t #:export @@ -167,16 +170,16 @@ (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 (cdr cell))) - (cons key value))) - auxiliary)))))))))) + (let* ((main-etag (read port)) + (auxiliary (read port))) + (values (make <content> #:etag main-etag) + (map + (match-lambda + (((= string->uri key) . etag) + `(,key . ,(make <content> #:etag etag)))) + auxiliary))))))))) -(define* (update-path path f content-type contained static-content create delete +(define* (update-path path f #:key (create-intermediate-containers? #f)) (let ((h (hash-path path)) (lock (lock-file-name path)) @@ -202,7 +205,7 @@ h lock (lambda (port) - (receive (etag auxiliary) + (receive (main auxiliary) (with-exception-handler (lambda (error) (unless (path-not-found? error) @@ -213,25 +216,21 @@ (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)) + (when main + (hash-set! garbage (etag main) #t)) + (for-each + (match-lambda + ((_ . content) + (hash-set! garbage (etag content) #t))) + (or auxiliary '())) (call-with-values (lambda () - (f etag auxiliary)) - (case-lambda - ((false) - (when false - (fail (G_ "You’re using the API wrong."))) - ;; Delete the resource - (unless (or (not etag) - (not (contained etag)) - (null? (contained etag))) + (f main auxiliary)) + (match-lambda* + ((#f) + (unless (or (not main) + (not (contained main)) + (null? (contained main))) (raise-exception (make-exception (make-container-not-empty path) @@ -246,62 +245,64 @@ (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)) - (fail (G_ "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) + (((? (cute is-a? <> <content>) new-main) + new-auxiliary) + (hash-remove! garbage (etag new-main)) + (for-each + (match-lambda + ((_ . content) + (hash-remove! garbage (etag content)))) + (or new-auxiliary '())) + (write (etag new-main) port) + (write (map (match-lambda + (((= uri->string key) . (= etag etag)) + `(,key . ,etag))) + (or new-auxiliary '())) port) - #t)))))) + #t) + (else + (fail (G_ "you must return either #f to delete the path, or a new main content and alist from URI types to auxiliary content")))))))) (when (and parent-path has-been-created? (not has-been-deleted?)) (update-path parent-path - (lambda (etag auxiliary) + (lambda (main auxiliary) ;; Add path as a child of the resource at etag (unless create-intermediate-containers? - (unless etag + (unless main ;; 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 "")))) - (let ((new-etag - (create content-type (cons path other-children) static-content))) - (values new-etag auxiliary)))) - content-type contained static-content create delete + (let ((content-type (if main (content-type main) 'text/turtle)) + (other-children (if main (contained main) '())) + (static-content (if main (static-content main) (string->utf8 "")))) + (let ((new-content + (make <content> + #:content-type content-type + #:contained (cons path other-children) + #:static-content static-content))) + (values new-content auxiliary)))) #: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 + (lambda (main auxiliary) + (unless main (raise-exception (make-path-not-found parent-path))) - (let ((content-type (content-type etag)) - (all-children (contained etag)) - (static-content (static-content etag))) + (let ((content-type (content-type main)) + (all-children (contained main)) + (static-content (static-content main))) (values - (create content-type - (filter (lambda (x) - (not (equal? x path))) - all-children) - static-content) + (make <content> + #:content-type content-type + #:contained + (filter (lambda (x) (not (equal? x path))) all-children) + #:static-content 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)))) + delete-content + (hash-map->list (lambda (garbage _) garbage) garbage)))) (define (base-path path) (define (check-suffix suffix type) diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm index d3f4adf..fd0d81e 100644 --- a/src/scm/webid-oidc/server/resource/wac.scm +++ b/src/scm/webid-oidc/server/resource/wac.scm @@ -242,61 +242,59 @@ (define acl-aux (string->uri "http://www.w3.org/ns/auth/acl#accessControl")) (define (wac-get-modes server-name final-path user) - (with-session - (lambda (content-type contained static-content create delete) - (define (wac-check-recursive path check-default?) - (receive (main-etag auxiliary) - (with-exception-handler - (lambda (error) - (unless (path-not-found? error) - (raise-exception error)) - (values #f '())) - (lambda () - (read-path path)) - #:unwind? #t - #:unwind-for-type &path-not-found) - (let ((acl-etag (assoc-ref auxiliary acl-aux))) - (if acl-etag - (with-rdf-source - server-name path (content-type acl-etag) (static-content acl-etag) - (lambda (rdf-match) - (check-authorizations - path check-default? server-name final-path user rdf-match - '() - (map rdf-triple-subject - (rdf-match #f - "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" - "http://www.w3.org/ns/auth/acl#Authorization"))))) - ;; No existing ACL. - (let ((parent-path - (string-append - "/" - (encode-and-join-uri-path - (reverse - (cdr - (reverse - (split-and-decode-uri-path path))))) - "/"))) - (when (equal? parent-path "//") - ;; The parent is the root - (set! parent-path "/")) - (wac-check-recursive parent-path #t)))))) - (let ((all-modes (wac-check-recursive final-path #f))) - (define (accumulate-unique accumulated list) - (cond - ((null? list) - (reverse accumulated)) - ((or (null? accumulated) (not (equal? (car accumulated) (car list)))) - (accumulate-unique (cons (car list) accumulated) (cdr list))) - (else - (accumulate-unique accumulated (cdr list))))) - (accumulate-unique - '() - (sort all-modes - (match-lambda* - (((? uri? (= uri->string a)) - (? uri? (= uri->string b))) - (string< a b))))))))) + (define (wac-check-recursive path check-default?) + (receive (main auxiliary) + (with-exception-handler + (lambda (error) + (unless (path-not-found? error) + (raise-exception error)) + (values #f '())) + (lambda () + (read-path path)) + #:unwind? #t + #:unwind-for-type &path-not-found) + (let ((acl (assoc-ref auxiliary acl-aux))) + (if acl + (with-rdf-source + server-name path (content-type acl) (static-content acl) + (lambda (rdf-match) + (check-authorizations + path check-default? server-name final-path user rdf-match + '() + (map rdf-triple-subject + (rdf-match #f + "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" + "http://www.w3.org/ns/auth/acl#Authorization"))))) + ;; No existing ACL. + (let ((parent-path + (string-append + "/" + (encode-and-join-uri-path + (reverse + (cdr + (reverse + (split-and-decode-uri-path path))))) + "/"))) + (when (equal? parent-path "//") + ;; The parent is the root + (set! parent-path "/")) + (wac-check-recursive parent-path #t)))))) + (let ((all-modes (wac-check-recursive final-path #f))) + (let accumulate-unique ((accumulated '()) + (list (sort all-modes + (match-lambda* + (((? uri? (= uri->string a)) + (? uri? (= uri->string b))) + (string< a b)))))) + (match list + (() (reverse accumulated)) + ((hd list ...) + (match accumulated + ((or () ;; Nothing accumulated, can’t be unique + ((? (lambda (head) (not (equal? head hd)))) _ ...)) + (accumulate-unique `(,hd ,@accumulated) list)) + (else + (accumulate-unique accumulated list)))))))) (define (check-mode server-name path owner user expected-mode) (unless (equal? owner user) diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm index d568d06..9bca2e6 100644 --- a/src/scm/webid-oidc/server/update.scm +++ b/src/scm/webid-oidc/server/update.scm @@ -42,6 +42,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 threads) #:use-module (ice-9 hash-table) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t @@ -92,80 +93,78 @@ (define* (update server-name owner user path if-match if-none-match content-type content) - (define updated-etag #f) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (receive (base-path path-type) - (base-path path) - (update-path - base-path - (lambda (main-etag auxiliary) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag))) - (if relevant-etag - ;; The resource exists, so we need write permission - (check-acl-can-write server-name path owner user) - ;; The resource does not exist yet, so we only need - ;; append permission - (check-acl-can-append server-name path owner user)) - (check-precondition path if-match if-none-match relevant-etag) - (set! updated-etag - (do-create content-type - (if relevant-etag - (load-contained relevant-etag) - (if (container-path? path) - '() - #f)) - (if (container-path? path) - (remove-containment-triples - (build-uri (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path) - content-type content) - content))) - (let ((new-main-etag - (if path-type - main-etag - updated-etag)) - (new-auxiliary - (if path-type - (cons - `(,path-type . ,updated-etag) - (filter - (lambda (auxiliary) - (let ((needs-description? (not (eq? content-type 'text/turtle))) - (is-describedby? - (equal? - (car auxiliary) - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) - (is-path-type? - (equal? (car auxiliary) path-type))) - (and (not is-path-type?) - (or (not is-describedby?) needs-description?)))) - (or auxiliary '()))) - (if (eq? content-type 'text/turtle) - (or auxiliary '()) - (cons - `(,(string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby") - . ,(do-create 'text/turtle #f "")) - (or auxiliary '())))))) - (unless new-main-etag - ;; Trying to update an auxiliary resource for a - ;; resource that does not exist - (set! new-main-etag - (do-create 'text/turtle - (if (container-path? path) - '() - #f) - ""))) - (values new-main-etag new-auxiliary)))) - load-content-type load-contained load-static-content do-create do-delete - #:create-intermediate-containers? #t)))) - updated-etag) + (define updated #f) + (parameterize ((current-content-cache (make <content-cache>))) + (receive (base-path path-type) + (base-path path) + (update-path + base-path + (lambda (main auxiliary) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main))) + (if relevant + ;; The resource exists, so we need write permission + (check-acl-can-write server-name path owner user) + ;; The resource does not exist yet, so we only need + ;; append permission + (check-acl-can-append server-name path owner user)) + (check-precondition path if-match if-none-match (and relevant (etag relevant))) + (set! updated + (make <content> + #:content-type content-type + #:contained + (if relevant + (contained relevant) + (if (container-path? path) + '() + #f)) + #:static-content + (if (container-path? path) + (remove-containment-triples + (build-uri (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path) + content-type content) + content))) + (let ((new-main + (if path-type main updated)) + (new-auxiliary + (if path-type + `((,path-type . ,updated) + ,@(filter + (match-lambda + ((type . content) + (let ((needs-description? (not (eq? content-type 'text/turtle))) + (is-describedby? + (equal? + type + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + (is-path-type? + (equal? type path-type))) + (and (not is-path-type?) + (or (not is-describedby?) needs-description?))))) + (or auxiliary '()))) + (if (eq? content-type 'text/turtle) + (or auxiliary '()) + `((,(string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby") + . ,(make <content> + #:content-type 'text/turtle + #:static-content "")) + ,@(or auxiliary '())))))) + (unless new-main + ;; Trying to update an auxiliary resource for a + ;; resource that does not exist + (set! new-main + (make <content> + #:content-type 'text/turtle + #:contained (and (container-path? path) '()) + #:statitc-content ""))) + (values new-main new-auxiliary)))) + #:create-intermediate-containers? #t))) + updated) |