path: root/src/scm/webid-oidc/server/create.scm

(define-module (webid-oidc server create)
  #: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)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (rdf rdf)
  #:use-module (turtle tordf)
  #:use-module (turtle fromrdf)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:export
  (

   create
   create-root

   ))

(define (without-containment-triples doc-uri content-type content)
  (case content-type
    ((text/turtle)
     #t)
    (else
     (raise-exception (make-unsupported-media-type content-type))))
  (let ((graph (fetch
                doc-uri
                #:http-get
                (lambda (uri . args)
                  (values
                   (build-response #:headers `((content-type ,content-type)))
                   content)))))
    (with-index
     graph
     (lambda (rdf-match)
       (unless (null? (rdf-match (uri->string doc-uri)
                                 "http://www.w3.org/ns/auth/acl#contains"
                                 #f))
         (raise-exception (make-incorrect-containment-triples
                           (uri-path doc-uri))))))))

(define (types-indicate-container? types)
  (and (not (null? types))
       (let ((next (car types)))
         (when (uri? next)
           (set! next (uri->string next)))
         (or (equal? next "http://www.w3.org/ns/ldp#BasicContainer")
             (types-indicate-container? (cdr types))))))

(define* (create server-name owner user container types slug content-type content
                 #:key
                 (http-get http-get))
  (check-acl-can-append server-name container owner user #:http-get http-get)
  (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))
        (raise-exception (make-path-is-auxiliary (uri-path doc-uri))))
      (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
                     #:http-get http-get))))))))

(define (create-root server-name owner)
  (define (fix-angle-aux accu chars)
    (if (null? chars)
        (list->string (reverse accu))
        (let ((next (car chars))
              (rest (cdr chars)))
          (let ((next-accu
                 (if (eqv? next #\>)
                     (reverse (string->list "%3E"))
                     (list next))))
            (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#> .

<#default>
  a acl:Authorization;
  acl:accessTo <~a>;
  acl:agent <~a>;
  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 root-uri)))))))))
          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/> .
@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)))))))))))