Content API: use GOOPS for the cache

3 files changed, 266 insertions, 180 deletions

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)