;; 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 .
(use-modules (webid-oidc server create)
(webid-oidc server read)
(webid-oidc server update)
(webid-oidc server delete)
(webid-oidc server resource content)
(webid-oidc server resource path)
(webid-oidc errors)
(webid-oidc testing)
(webid-oidc fetch)
(webid-oidc rdf-index)
(web http)
(web request)
(web response)
(web uri)
(ice-9 receive)
(rnrs bytevectors))
(with-test-environment
"crud"
(lambda ()
(for-each
(lambda (f)
(false-if-exception
(delete-file
(string-append
"tests/crud.home/disfluid/server/content/"
f))))
'("6/8OMG_V5x-KmI6TI"
"X/hqM_2Avn5_egTzs"
"5/n1KPgAd3ng4wSqn"
"D/wxU0ogx5rzRrvu2"
"F/BQKBGrtq6U_M0L7"
"n/U46BXbknEaLWZpH"
"A/fkGTJRCHc-jHk-V"
"a/68pTwiImTWTpjQl"
"H/y4S5p1BqTEJi-Jb"
"b/k7RqZevpCHAumba"
"y/29x0MEOMybxUqDU"
"5/KVojpXDg0Aob3_v"
"S/9kvZXAg1UQojIal"
"B/JadnRZKhcTKHHZU"
"_/VhVgLvE4J9JwpIP"
"l/ljOph3RCCWJJW5K"
"o/UmwpeCFbPoc9PCL"))
(for-each
(lambda (f)
(false-if-exception
(delete-file
(string-append
"tests/crud.home/disfluid/server/path/"
f))))
'("L/uhr1159jdGYjIj_tpM6FDiW4rUZDQQKUnT35lhAR-s"
"8/jgewChguz6YRPCTBOkx_9CW94iH_X88rP6Os4aM8jg"
"n/PQ_3L8lXCsqpz1tkUhsJnVC9rcyqgDD41DnFPIDG1Q"
"i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE"
"4/Hkcb0hNCFXVdxfiSfpg9D2LPLelSWBw7rM1xyQkI_M"
"1/8Jb3gOzbpL-A0o4MaBd4Iw41W1c0t3fgywwryZ8vBw"
"P/6DoRBgELS5Hrr0E-sQgRsjN-apgr3GsKZpL9K-NMHs"))
(let ((server-name (string->uri "https://example.com"))
(owner (string->uri "https://alice.databox.me")))
;; CREATE
(unless
(create-root server-name owner)
(exit 1))
(let ((inbox (create server-name owner owner "/"
(list (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
"inbox"
'text/turtle
"")))
(unless (equal? inbox (string->uri "https://example.com/inbox/"))
(exit 2))
(let ((inbox-2 (create server-name owner owner "/"
(list (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
"inbox"
'text/turtle
"")))
(when (equal? inbox-2 (string->uri "https://example.com/inbox/"))
(exit 3)))
(let ((notif-1 (create server-name owner owner "/inbox"
'()
#f
'text/turtle
"")))
(unless (equal? notif-1
(string->uri "https://example.com/inbox/NgnO8RAS9FpPiO5j"))
(format (current-error-port) "Notif 1: ~s\n" notif-1)
(exit 4))))
(for-each
(lambda (slug)
(with-exception-handler
(lambda (error)
(unless (path-is-auxiliary? error)
(raise-exception error)))
(lambda ()
(create server-name owner owner "/" '() slug 'text/turtle "")
(exit 5))
#:unwind? #t
#:unwind-for-type &path-is-auxiliary))
'(".acl" ".meta"))
;; READ
(receive (headers-root root) (read server-name owner owner "/")
;; For root, we’re looking for the following headers:
;; - link: ldp:BasicContainer; rel = "type", ; rel = "acl", pim:Storage; rel = "type", owner; rel = "solid:owner"
;; - allow: GET, HEAD, OPTIONS, PUT, POST, but not DELETE
;; - accept-put: 'text/turtle 'application/n-quads 'application/ld+json
;; - content-type: 'text/turtle
;; - etag: weak
;; The content is a RDF graph, it should contain 1 triple: > ldp:contains .
(when (bytevector? root)
(set! root (utf8->string root)))
(let ((links (assq-ref headers-root 'link))
(allow (assq-ref headers-root 'allow))
(accept-put (assq-ref headers-root 'accept-put))
(content-type (assq-ref headers-root 'content-type))
(etag (assq-ref headers-root 'etag)))
(unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
'((rel . "type")))
(exit 6))
(unless (equal? (assoc-ref links (string->uri "https://example.com/.acl"))
'((rel . "acl")))
(exit 7))
(unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/pim/space#Storage"))
'((rel . "type")))
(exit 8))
(unless (equal? (assoc-ref links owner)
'((rel . "http://www.w3.org/ns/solid/terms#owner")))
(exit 9))
(unless (and (memq 'GET allow)
(memq 'HEAD allow)
(memq 'OPTIONS allow)
(memq 'PUT allow)
(memq 'POST allow))
(exit 10))
(when (memq 'DELETE allow)
(exit 11))
(unless (equal? accept-put "text/turtle; application/n-quads; application/ld+json")
(exit 12))
(unless (equal? content-type '(text/turtle))
(exit 13))
(unless (string? (car etag))
(exit 14))
(when (cdr etag)
(exit 15))
(with-index
(fetch "https://example.com/"
#:http-get
(lambda (uri . rest)
(values
(build-response #:headers `((content-type . ,content-type)))
root)))
(lambda (rdf-match)
(when (null? (rdf-match "https://example.com/"
"http://www.w3.org/ns/ldp#contains"
"https://example.com/inbox/"))
(exit 16))))))
(receive (headers-/.acl /.acl) (read server-name owner owner "/.acl")
;; The ACL has the following headers:
;; - allow: GET, HEAD, OPTIONS, PUT, DELETE, but not POST
;; - accept-put: 'text/turtle
;; - content-type: 'text/turtle
;; - etag: weak
;; The content is a RDF graph containing at least one authorization.
(when (bytevector? /.acl)
(set! /.acl (utf8->string /.acl)))
(let ((allow (assq-ref headers-/.acl 'allow))
(accept-put (assq-ref headers-/.acl 'accept-put))
(content-type (assq-ref headers-/.acl 'content-type))
(etag (assq-ref headers-/.acl 'etag)))
(unless (and (memq 'GET allow)
(memq 'HEAD allow)
(memq 'OPTIONS allow)
(memq 'PUT allow)
(memq 'DELETE allow))
(exit 17))
(when (memq 'POST allow)
(exit 18))
(unless (equal? accept-put "text/turtle; application/n-quads; application/ld+json")
(exit 19))
(unless (equal? content-type '(text/turtle))
(exit 20))
(unless (string? (car etag))
(exit 21))
(when (cdr etag)
(exit 22))
(with-index
(fetch "https://example.com/.acl"
#:http-get
(lambda (uri . rest)
(values
(build-response #:headers `((content-type . ,content-type)))
/.acl)))
(lambda (rdf-match)
(when (null? (rdf-match #f
"http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
"http://www.w3.org/ns/auth/acl#Authorization"))
(exit 23))))))
(update server-name owner owner "/inbox/.acl" #f '* 'text/turtle "@prefix acl: .
@prefix foaf: .
<#default>
a acl:Authorization;
acl:accessTo ;
acl:agent ;
acl:mode acl:Read, acl:Write, acl:Control;
acl:default .
<#public>
a acl:Authorization;
acl:accessTo ;
acl:default ;
acl:agentClass foaf:Agent;
acl:mode acl:Append.
")
(update server-name owner #f "/inbox/test-notifications/welcome" #f '* 'text/plain "Hello :)")
(with-exception-handler
(lambda (error)
;; The containment triples are not correct
(unless (incorrect-containment-triples? error)
(exit 24)))
(lambda ()
(update server-name owner owner "/inbox/" #f #f 'text/turtle "@prefix ldp: .
@prefix rdfs: .
<> rdfs:comment \"Alice’s inbox, drop your notifications there and I’ll ignore them.\" .
"))
#:unwind? #t
#:unwind-for-type &incorrect-containment-triples)
(let ((exact-content
"@prefix ldp: .
@prefix rdfs: .
# This is the exact content submitted to the server, however this
# comment will disappear because the server will re-write the turtle
# representation to change the containment triples.
<> rdfs:comment \"Alice’s inbox, drop your notifications there and I’ll ignore them.\" ;
ldp:contains .
"))
(update server-name owner owner "/inbox/" #f #f 'text/turtle exact-content)
(receive (headers content)
(read server-name owner owner "/inbox/")
(when (bytevector? content)
(set! content (utf8->string content)))
(when (equal? content exact-content)
(exit 25))))
(delete server-name owner owner "/inbox/test-notifications/welcome" #f #f)
(delete server-name owner owner "/inbox/test-notifications" #f #f))))