1 files changed, 186 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/resource.scm b/src/scm/webid-oidc/server/resource.scm
new file mode 100644
index 0000000..7a8ca0b
--- /dev/null
+++ b/src/scm/webid-oidc/server/resource.scm
@@ -0,0 +1,186 @@
+(define-module (webid-oidc server resource)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (web uri)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (oop goops)
+  #:export
+  (
+   <explicit-acl>
+   allowed-users
+   allowed-groups
+   public?
+
+   <t>
+   path
+   etag set-etag!
+   acl set-acl!
+   content-type set-content-type!
+   content set-content!
+   metadata set-matadata!
+   contained set-contained!
+
+   (my:read . read)
+   load
+   (my:write . write)
+   save
+   delete
+   ))
+
+(define-class <explicit-acl> ()
+  (allowed-users #:init-keyword #:allowed-users #:getter allowed-users)
+  (allowed-groups #:init-keyword #:allowed-groups #:getter allowed-groups)
+  (public? #:init-keyword #:public? #:getter public?))
+
+(define-class <t> ()
+  (path #:init-keyword #:path #:getter path)
+  (etag #:init-keyword #:etag #:getter etag #:setter set-etag!)
+  (acl #:init-keyword #:acl #:getter acl #:setter set-acl!)
+  (content-type #:init-keyword #:content-type #:getter content-type #:setter set-content-type!)
+  (content #:init-keyword #:content #:getter content #:setter set-content!)
+  (metadata #:init-keyword #:metadata #:getter metadata #:setter set-metadata!)
+  ;; contained is a list of paths
+  (contained #:init-keyword #:contained #:getter contained #:setter set-contained!))
+
+(define (path->file-system uri-path)
+  (let ((normalized (encode-and-join-uri-path
+                     (split-and-decode-uri-path uri-path)))
+        (xdg-data-home
+         (or (getenv "XDG_DATA_HOME")
+             (format #f "~a/.local/share" (getenv "HOME")))))
+    (let ((hash (stubs:hash 'SHA-256 normalized)))
+      (let ((directory (substring hash 0 1))
+            (base (substring hash 1)))
+        (string-append xdg-data-home "/webid-oidc/server/" directory "/" base)))))
+
+(define (my:read path port)
+  (let ((data (read port)))
+    (let ((etag (assq-ref data 'etag))
+          (acl (assq-ref data 'acl))
+          (content-type (assq-ref data 'content-type))
+          (metadata (assq-ref data 'metadata))
+          (contained (assq-ref data 'contained)))
+      (unless (and etag (string? etag))
+        (raise-exception (make-missing-etag data)))
+      (unless (and content-type (symbol? content-type))
+        (raise-exception (make-missing-content-type data)))
+      (set-port-encoding! port "ISO-8859-1")
+      (let ((content (get-bytevector-all port))
+            (explicit-acl
+             (and acl
+                  (if (eq? acl 'public)
+                      (make <explicit-acl>
+                        #:public? #t
+                        #:allowed-users '()
+                        #:allowed-groups '())
+                      (let ((groups (assq-ref acl 'groups))
+                            (users (assq-ref acl 'users)))
+                        (make <explicit-acl>
+                          #:public? #f
+                          #:allowed-users (map string->uri users)
+                          #:allowed-groups (map string->relative-ref groups))))))
+            (normalized-path
+             (let ((components (reverse (split-and-decode-uri-path path))))
+               (when (and (not (null? components))
+                          (equal? (car components) ""))
+                 ;; Load path with a trailing / -> it is ignored
+                 (set! components (cdr components)))
+               (string-append
+                (encode-and-join-uri-path (reverse components))
+                (if contained "/" "")))))
+        (make <t>
+          #:path (string-append "/" normalized-path)
+          #:etag etag
+          #:acl explicit-acl
+          #:content-type content-type
+          #:content content
+          #:metadata (or metadata "")
+          #:contained contained)))))
+
+(define (load uri-path)
+  (with-exception-handler
+      (lambda (error)
+        (raise-exception (make-resource-not-found uri-path error)))
+    (lambda ()
+      (call-with-input-file (path->file-system uri-path)
+        (lambda (port) (my:read uri-path port))))))
+
+(define-method (my:write (obj <t>) port)
+  (let ((data `((etag . ,(etag obj))
+                (acl . ,(let ((explicit-acl (acl obj)))
+                          (and explicit-acl
+                               (if (public? explicit-acl)
+                                   'public
+                                   `((users . ,(map uri->string (allowed-users explicit-acl)))
+                                     (groups . ,(map uri->string (allowed-groups explicit-acl))))))))
+                (content-type . ,(content-type obj))
+                (metadata . ,(metadata obj))
+                (contained . ,(contained obj)))))
+    (let ((data-stripped (filter cdr data)))
+      (write data-stripped port)
+      (set-port-encoding! port "ISO-8859-1")
+      (let ((c (content obj)))
+        (unless (string? c)
+          (set! c (bytevector->string c "ISO-8859-1")))
+        (display c port)))))
+
+(define (car-or-id x)
+  (if (pair? x) (car x) x))
+
+(define (check-precondition path if-match if-none-match)
+  (with-exception-handler
+      (lambda (not-found)
+        (unless (resource-not-found? not-found)
+          ;; This is a programming error
+          (error "This should not happen"))
+        (when if-match
+          (raise-exception (make-precondition-failed #f if-match if-none-match))))
+    (lambda ()
+      (let ((previous (load path)))
+        (let ((previous-etag (etag previous)))
+          (unless (or (not if-match)
+                      (eq? if-match '*)
+                      (member previous-etag (map car-or-id if-match)))
+            (raise-exception (make-precondition-failed previous-etag if-match if-none-match)))
+          (when (or (eq? if-none-match '*)
+                    (and if-none-match
+                         (member previous-etag (map car-or-id if-none-match))))
+            (raise-exception (make-precondition-failed previous-etag if-match if-none-match))))))
+    #:unwind? #t
+    #:unwind-for-type &resource-not-found))
+
+(define* (save obj #:key (if-match #f) (if-none-match #f))
+  (let ((fs (path->file-system (path obj))))
+    (stubs:call-with-output-file*
+     (string-append fs "~")
+     (lambda (port)
+       (flock port LOCK_EX)
+       (with-exception-handler
+           (lambda (error)
+             (flock port LOCK_UN)
+             (raise-exception error))
+         (lambda ()
+           (my:write obj port)
+           (check-precondition (path obj) if-match if-none-match)
+           (rename-file (string-append fs "~") fs)
+           (flock port LOCK_UN)))))))
+
+(define* (delete path #:key (if-match #f) (if-none-match #f))
+  (let ((fs (path->file-system path)))
+    (stubs:call-with-output-file*
+     (string-append fs "~")
+     (lambda (port)
+       (flock port LOCK_EX)
+       (with-exception-handler
+           (lambda (error)
+             (flock port LOCK_UN)
+             (raise-exception error))
+         (lambda ()
+           (check-precondition path if-match if-none-match)
+           (delete-file fs)
+           (delete-file (string-append fs "~"))
+           (flock port LOCK_UN)))))))