;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(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: .
<#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
(build-uri (uri-scheme root-uri)
#:userinfo (uri-userinfo root-uri)
#:host (uri-host root-uri)
#:port (uri-port root-uri)
#:path "/"))))))))))
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: .
@prefix ldp: .
<~a~a> a foaf:Person .
"
(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: .
@prefix foaf: .
<#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))))))