From b2bf048e7156685561343abab717242f24d9b54c Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Tue, 29 Jun 2021 05:32:20 +0200
Subject: Initialization: make sure that the profile and required resources
 exist

---
 src/scm/webid-oidc/server/create.scm | 152 ++++++++++++++++++++++++++++++++---
 1 file changed, 143 insertions(+), 9 deletions(-)

diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm
index 9209d70..dc12ff9 100644
--- a/src/scm/webid-oidc/server/create.scm
+++ b/src/scm/webid-oidc/server/create.scm
@@ -2,8 +2,10 @@
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc server resource path)
   #:use-module (webid-oidc server resource content)
+  #:use-module (webid-oidc server read)
   #:use-module (webid-oidc cache)
   #:use-module (webid-oidc fetch)
+  #:use-module (webid-oidc rdf-index)
   #:use-module (webid-oidc server resource wac)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc rdf-index)
@@ -126,11 +128,11 @@
             (fix-angle-aux (append next-accu accu) rest)))))
   (define (fix-angle str)
     (fix-angle-aux '() (string->list str)))
-  (catch 'already-exists
-    (lambda ()
-      (with-session
-       (lambda (load-content-type load-contained load-static-content
-                                  do-create do-delete)
+  (with-session
+   (lambda (load-content-type load-contained load-static-content
+                              do-create do-delete)
+     (catch 'already-exists
+       (lambda ()
          (update-path
           "/"
           (lambda (etag auxiliary)
@@ -161,7 +163,139 @@
                                          (fix-angle (uri->string owner))
                                          (fix-angle (uri->string root-uri)))))))))
           load-content-type load-contained load-static-content
-          do-create do-delete)))
-      #t)
-    (lambda error
-      #f)))
+          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/> .
+@prefix ldp: <http://www.w3.org/ns/ldp#> .
+
+<~a~a> a foaf:Person;
+  ldp:inbox </inbox/> .
+"
+                                  (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#> .
+@prefix foaf: <http://xmlns.com/foaf/0.1/> .
+
+<#public>
+  a acl:Authorization;
+  acl:accessTo <~a>;
+  acl:agentClass foaf:Agent;
+  acl:mode acl:Read.
+
+<#default>
+  a acl:Authorization;
+  acl:accessTo <~a>;
+  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))
+       ;; Also, we need an inbox: look up the profile to know where to
+       ;; put it
+       (receive (main-profile-etag rest)
+           (read-path (uri-path owner))
+         (when (and main-profile-etag
+                    (eq? (load-content-type main-profile-etag) 'text/turtle))
+           (false-if-exception
+            (with-index
+             (fetch 
+              (build-uri
+               (uri-scheme owner)
+               #:userinfo (uri-userinfo owner)
+               #:host (uri-host owner)
+               #:port (uri-port owner)
+               #:path (uri-path owner))
+              #:http-get
+              (lambda args
+                (values
+                 (build-response #:headers '((content-type text/turtle)))
+                 (load-static-content main-profile-etag))))
+             (lambda (rdf-match)
+               (let ((inboxes
+                      (map rdf-triple-object
+                           (rdf-match
+                            (string->uri owner)
+                            "http://www.w3.org/ns/ldp#inbox"
+                            #f))))
+                 (for-each
+                  (lambda (inbox-path)
+                    (catch 'already-exists
+                      (lambda ()
+                        (update-path
+                         inbox-path
+                         (lambda (etag auxiliary)
+                           (when etag
+                             (throw 'already-exists))
+                           (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#> .
+@prefix foaf: <http://xmlns.com/foaf/0.1/> .
+
+<#public>
+  a acl:Authorization;
+  acl:accessTo <~a>;
+  acl:agentClass foaf:Agent;
+  acl:mode acl:Read.
+
+<#default>
+  a acl:Authorization;
+  acl:accessTo <~a>;
+  acl:agent <~a>;
+  acl:mode acl:Read, acl:Write, acl:Control.
+"
+                                                      (fix-angle inbox-path)
+                                                      (fix-angle inbox-path)
+                                                      (fix-angle (uri->string owner))))))))
+                         load-content-type load-contained load-static-content
+                         do-create do-delete
+                         #:create-intermediate-containers? #t))
+                      (lambda error #f)))
+                  inboxes)))))))))))
-- 
cgit v1.2.3