;; disfluid, 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 (tests acl)
#:use-module (webid-oidc server resource wac)
#:use-module (webid-oidc server resource content)
#:use-module (webid-oidc server resource path)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (webid-oidc testing)
#:use-module (web http)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (oop goops)
#:duplicates (merge-generics)
#:declarative? #t)
(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"))
(parameterize ((current-content-cache (make )))
;; 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 ((/
(make
#:content-type 'text/turtle
#:contained '("docs" "private-docs")
#:static-content ""))
(/docs/
(make
#:content-type 'text/turtle
#:contained '("file1" "file2")
#:static-content ""))
(/docs/file1
(make
#:content-type 'text/plain
#:static-content "Hello :)"))
(/docs/file2
(make
#:content-type 'text/plain
#:static-content "You’re authenticated :)"))
(/private-docs/
(make
#:content-type 'text/turtle
#:contained '("file1")
#:static-content ""))
(/private-docs/file1
(make
#:content-type 'text/plain
#:static-content "Private, but FBI can read!"))
(/private-docs/file2
(make
#:content-type 'text/plain
#:static-content "Private!"))
(/.acl
(make
#:content-type 'text/turtle
#:static-content "@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
(make
#:content-type 'text/turtle
#:static-content "@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
(make
#:content-type 'text/turtle
#:static-content "@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
(make
#:content-type 'text/turtle
#:static-content "@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)))))
(update-path
"/docs/"
(lambda (main auxiliary)
(values /docs/
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/docs/.acl)))))
(update-path
"/docs/file1"
(lambda (main auxiliary)
(values /docs/file1
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/docs/file1.acl)))))
(update-path
"/docs/file2"
(lambda (main auxiliary)
(values /docs/file2
`((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl")
. ,/docs/file2.acl)))))
(update-path
"/private-docs/"
(lambda (main auxiliary)
(values /private-docs/ '())))
(update-path
"/private-docs/file1"
(lambda (main auxiliary)
(values /private-docs/file1 '())))
(update-path
"/private-docs/file2"
(lambda (main auxiliary)
(values /private-docs/file2 '())))
(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)))
(parameterize
((p:anonymous-http-request http-get))
(let ((alice (wac-get-modes
server-name path
(string->uri "https://alice.databox.me/profile/card#me")))
(bob (wac-get-modes
server-name path
(string->uri "https://bob.databox.me/profile/card#me")))
(fbi (wac-get-modes
server-name path
(string->uri "https://the-spy.databox.me/profile/card#me")))
(anonymous (wac-get-modes
server-name path
#f)))
(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))))))))