Load and save resources for the server

5 files changed, 300 insertions, 26 deletions

diff --git a/src/Makefile.am b/src/Makefile.am
index 3dd6822..4310065 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -14,6 +14,9 @@ godir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
 webidoidcmoddir = $(moddir)/webid-oidc
 webidoidcgodir = $(godir)/webid-oidc
 
+serverwebidoidcmoddir = $(webidoidcmoddir)/server
+serverwebidoidcgodir = $(webidoidcgodir)/server
+
 dist_mod_DATA =
 mod_DATA =
 go_DATA =
@@ -22,8 +25,11 @@ dist_webidoidcmod_DATA =
 webidoidcmod_DATA =
 webidoidcgo_DATA =
 
-install_go_targets = install-webidoidcgoDATA
-install_mod_targets = install-webidoidcmodDATA install-dist_webidoidcmodDATA
+dist_serverwebidoidcmod_DATA =
+serverwebidoidcgo_DATA =
+
+install_go_targets = install-webidoidcgoDATA install-serverwebidoidcgoDATA
+install_mod_targets = install-webidoidcmodDATA install-dist_webidoidcmodDATA install-dist_serverwebidoidcmodDATA
 
 include %reldir%/base64/Makefile.am
 include %reldir%/random/Makefile.am
@@ -34,14 +40,15 @@ include %reldir%/pre-inst/Makefile.am
 include %reldir%/inst/Makefile.am
 include %reldir%/scm/Makefile.am
 
-CLEANFILES += $(go_DATA) $(webidoidcgo_DATA) $(mod_DATA) $(webidoidcmod_DATA)
+CLEANFILES += $(go_DATA) $(webidoidcgo_DATA) $(mod_DATA) $(webidoidcmod_DATA) \
+  $(serverwebidoidcgo_DATA)
 
 %canon_reldir%_libwebidoidc_la_SOURCES = %reldir%/gettext.h %reldir%/libwebidoidc.c %reldir%/utilities.h
 %canon_reldir%_libwebidoidc_la_LIBADD = $(noinst_LTLIBRARIES) $(GUILE_LIBS) $(NETTLE_LIBS)
 
 INDENTED += $(%canon_reldir%_libwebidoidc_la_SOURCES)
 
-$(go_DATA) $(webidoidcgo_DATA): %reldir%/libwebidoidc.la
+$(go_DATA) $(webidoidcgo_DATA) $(serverwebidoidcgo_DATA): %reldir%/libwebidoidc.la
 
 SUFFIXES += .c .x .scm .go
 .c.x:
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 6aeadfc..f248c47 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -55,3 +55,5 @@ webidoidcgo_DATA += \
   %reldir%/example-app.go
 
 EXTRA_DIST += %reldir%/ChangeLog
+
+include %reldir%/server/Makefile.am
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 32423ef..bbbbc1c 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -870,6 +870,62 @@
   (raise-exception
    ((record-constructor &no-provider-candidates) webid causes)))
 
+;; Server-side exceptions
+
+(define-exception-type
+  &resource-not-found
+  &external-error
+  make-resource-not-found
+  resource-not-found?
+  (path resource-not-found-path)
+  (cause resource-not-found-cause))
+
+(export &resource-not-found
+        make-resource-not-found
+        resource-not-found?
+        resource-not-found-path
+        resource-not-found-cause)
+
+(define-exception-type
+  &missing-etag
+  &external-error
+  make-missing-etag
+  missing-etag?
+  (data missing-etag-data))
+
+(export &missing-etag
+        make-missing-etag
+        missing-etag?
+        missing-etag-data)
+
+(define-exception-type
+  &missing-content-type
+  &external-error
+  make-missing-content-type
+  missing-content-type?
+  (data missing-content-type-data))
+
+(export &missing-content-type
+        make-missing-content-type
+        missing-content-type?
+        missing-content-type-data)
+
+(define-exception-type
+  &precondition-failed
+  &external-error
+  make-precondition-failed
+  precondition-failed?
+  (etag precondition-failed-etag)
+  (if-match precondition-failed-if-match)
+  (if-none-match precondition-failed-if-none-match))
+
+(export &precondition-failed
+        make-precondition-failed
+        precondition-failed?
+        precondition-failed-etag
+        precondition-failed-if-match
+        precondition-failed-if-none-match)
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -1193,28 +1249,44 @@
           ((&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_ ", "))))
+          ((&resource-not-found)
+           (format #f (G_ "the resource ~s could not be found (because ~a)")
+                   (get 'path)
+                   (recurse (get 'cause))))
+          ((&missing-etag)
+           (format #f (G_ "the resource is missing an etag (see ~s)")
+                   (get 'data)))
+          ((&missing-content-type)
+           (format #f (G_ "the resource is missing a content type (see ~s)")
+                   (get 'content-type)))
+          ((&precondition-failed)
+           (if (get 'etag)
+               (format #f (G_ "the precondition failed for etag ~s: if-match ~s and if-none-match ~s")
+                       (get 'etag) (get 'if-match) (get 'if-none-match))
+               (format #f (G_ "the precondition failed for a non-existing resource: if-match ~s and if-none-match ~s")
+                       (get 'if-match) (get 'if-none-match))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
@@ -1253,6 +1325,8 @@
            (format #f (G_ "the program cannot recover from this exception")))
           ((&error)
            (format #f (G_ "there is an error")))
+          ((&external-error)
+           (format #f (G_ "there is an external error")))
           (else
            (error (format #f (G_ "Unhandled exception type ~a.")
                           (record-type-name type))))))
diff --git a/src/scm/webid-oidc/server/Makefile.am b/src/scm/webid-oidc/server/Makefile.am
new file mode 100644
index 0000000..50708fb
--- /dev/null
+++ b/src/scm/webid-oidc/server/Makefile.am
@@ -0,0 +1,5 @@
+dist_serverwebidoidcmod_DATA += \
+  %reldir%/resource.scm
+
+serverwebidoidcgo_DATA += \
+  %reldir%/resource.go
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)))))))