;; 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 resource wac)
(webid-oidc server resource content)
(webid-oidc server resource path)
(webid-oidc testing)
(web http)
(web request)
(web response)
(web uri))
(define (http-get uri . other-args)
(when (string? uri)
(set! uri (string->uri uri)))
(unless (equal? uri
(string->uri "https://fbi.databox.me/group"))
(format (current-error-port)
"Expected:\n ~s, got:\n ~s\n" uri (string->uri "https://fbi.databox.me/group"))
(exit 1))
(values
(build-response #:headers '((content-type text/turtle)))
"@prefix vcard: .
<#spies> a vcard:Group;
vcard:hasMember .
"))
(with-test-environment
"direct-acl"
(lambda ()
(for-each
(lambda (f)
(false-if-exception
(delete-file
(string-append
"tests/direct-acl.home/disfluid/server/content/"
f))))
'("6/8OMG_V5x-KmI6TI"
"X/hqM_2Avn5_egTzs"
"a/68pTwiImTWTpjQl"
"5/n1KPgAd3ng4wSqn"
"D/wxU0ogx5rzRrvu2"
"F/BQKBGrtq6U_M0L7"
"n/U46BXbknEaLWZpH"
"N/gnO8RAS9FpPiO5j"
"A/fkGTJRCHc-jHk-V"
"H/y4S5p1BqTEJi-Jb"
"b/k7RqZevpCHAumba"
"y/29x0MEOMybxUqDU"
"5/KVojpXDg0Aob3_v"))
(with-session
(lambda (content-type contained static-content create delete)
;; In this little scenario:
;; / can only be listed by Alice and the FBI
;; /docs/ can only be updated by Alice and the public can list
;; /docs/file1 can only be updated by Alice, but public
;; /docs/file2 same, but authenticated
;; /fiction/file does not exist, so /#default applies
;; /private-docs/ private to Alice, no ACL
;; /private-docs/file1 no ACL (so, readable by the FBI as inherited in /)
;; /private/docs/file2 no ACL (so, not readable by the FBI)
(let ((/ (create 'text/turtle '("docs" "private-docs") ""))
(/docs/ (create 'text/turtle '("file1" "file2") ""))
(/docs/file1 (create 'text/plain #f "Hello :)"))
(/docs/file2 (create 'text/plain #f "You’re authenticated :)"))
(/private-docs/ (create 'text/turtle '("file1") ""))
(/private-docs/file1 (create 'text/plain #f "Private, but FBI can read!"))
(/private-docs/file2 (create 'text/plain #f "Private!"))
(/.acl (create 'text/turtle #f "@prefix acl: .
<#default>
a acl:Authorization;
acl:accessTo ;
acl:agent ;
acl:mode acl:Read, acl:Write, acl:Control;
acl:default .
<#for-the-fbi>
a acl:Authorization;
acl:accessTo ;
acl:agentGroup ;
acl:mode acl:Read, acl:Write;
acl:default .
"))
(/docs/.acl (create 'text/turtle #f "@prefix acl: .
@prefix foaf: .
<#default>
a acl:Authorization;
acl:accessTo ;
acl:agent ;
acl:mode acl:Read, acl:Write, acl:Control.
<#anyone-can-list-files>
a acl:Authorization;
acl:accessTo ;
acl:agentClass foaf:Agent;
acl:mode acl:Read.
"))
(/docs/file1.acl (create 'text/turtle #f "@prefix acl: .
@prefix foaf: .
<#default>
a acl:Authorization;
acl:accessTo ;
acl:agent ;
acl:mode acl:Read, acl:Write, acl:Control.
<#public>
a acl:Authorization;
acl:accessTo ;
acl:agentClass foaf:Agent;
acl:mode acl:Read.
"))
(/docs/file2.acl (create 'text/turtle #f "@prefix acl: .
<#default>
a acl:Authorization;
acl:accessTo ;
acl:agent ;
acl:mode acl:Read, acl:Write, acl:Control.
<#public>
a acl:Authorization;
acl:accessTo ;
acl:agentClass acl:AuthenticatedAgent;
acl:mode acl:Read.
")))
(update-path
"/"
(lambda (main auxiliary)
(values /
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/.acl))))
content-type contained static-content create delete)
(update-path
"/docs/"
(lambda (main auxiliary)
(values /docs/
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/docs/.acl))))
content-type contained static-content create delete)
(update-path
"/docs/file1"
(lambda (main auxiliary)
(values /docs/file1
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/docs/file1.acl))))
content-type contained static-content create delete)
(update-path
"/docs/file2"
(lambda (main auxiliary)
(values /docs/file2
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/docs/file2.acl))))
content-type contained static-content create delete)
(update-path
"/private-docs/"
(lambda (main auxiliary)
(values /private-docs/ '()))
content-type contained static-content create delete)
(update-path
"/private-docs/file1"
(lambda (main auxiliary)
(values /private-docs/file1 '()))
content-type contained static-content create delete)
(update-path
"/private-docs/file2"
(lambda (main auxiliary)
(values /private-docs/file2 '()))
content-type contained static-content create delete)
(let ((server-name
(string->uri "https://alice.databox.me")))
;; Who can access what?
;; Alice: https://alice.databox.me/profile/card#me
;; Bob: https://bob.databox.me/profile/card#me (authenticated)
;; FBI: https://the-spy.databox.me/profile/card#me
;; Anonymous
;;
;; Alice Bob FBI Anonymous
;; / RWC X RW X
;; /docs/ RWC R R R
;; /docs/file1 RWC R R R
;; /docs/file2 RWC R R X
;; /fiction/file RWC X X X
;; /private-docs/ RWC X X X
;; /private-docs/file1 RWC X RW X
;; /private-docs/file2 RWC X X X
(define (run-test path modes-alice modes-bob modes-fbi modes-anonymous)
(define (uri< a b)
(string< (uri->string a) (uri->string b)))
(let ((alice (wac-get-modes
server-name path
(string->uri "https://alice.databox.me/profile/card#me")
#:http-get http-get))
(bob (wac-get-modes
server-name path
(string->uri "https://bob.databox.me/profile/card#me")
#:http-get http-get))
(fbi (wac-get-modes
server-name path
(string->uri "https://the-spy.databox.me/profile/card#me")
#:http-get http-get))
(anonymous (wac-get-modes
server-name path
#f
#:http-get http-get)))
(unless (equal? alice
modes-alice)
(format (current-error-port)
"Alice’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n"
path
(map uri->string modes-alice)
(map uri->string alice))
(exit 2))
(unless (equal? bob
modes-bob)
(format (current-error-port)
"Bob’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n"
path
(map uri->string modes-bob)
(map uri->string bob))
(exit 3))
(unless (equal? fbi
modes-fbi)
(format (current-error-port)
"Spy’s modes for path ~s:\n expected:\n ~s\n got:\n ~s\n"
path
(map uri->string modes-fbi)
(map uri->string fbi))
(exit 4))
(unless (equal? anonymous
modes-anonymous)
(format (current-error-port)
"Anonymous modes for path ~s:\n expected:\n ~s\n got:\n ~s\n"
path
(map uri->string modes-anonymous)
(map uri->string anonymous))
(exit 5))))
(let ((read (string->uri "http://www.w3.org/ns/auth/acl#Read"))
(write (string->uri "http://www.w3.org/ns/auth/acl#Write"))
(control (string->uri "http://www.w3.org/ns/auth/acl#Control")))
(let ((RWC (list control read write))
(R (list read))
(RW (list read write))
(X '()))
(run-test "/" RWC X RW X)
(run-test "/docs/" RWC R R R)
(run-test "/docs/file1" RWC R R R)
(run-test "/docs/file2" RWC R R X)
(run-test "/fiction/file" RWC X X X)
(run-test "/private-docs/" RWC X X X)
(run-test "/private-docs/file1" RWC X RW X)
(run-test "/private-docs/file2" RWC X X X)))))))))