From a601c74354f7cb659fcfd05ec9a40392df7c2aa7 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Tue, 15 Jun 2021 19:02:39 +0200 Subject: Implement WAC --- tests/Makefile.am | 3 +- tests/acl-with-group.scm | 11 +++ tests/acl.scm | 249 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 262 insertions(+), 1 deletion(-) create mode 100644 tests/acl-with-group.scm create mode 100644 tests/acl.scm (limited to 'tests') diff --git a/tests/Makefile.am b/tests/Makefile.am index e83da31..fd2c47c 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -43,7 +43,8 @@ TESTS = %reldir%/load-library.scm \ %reldir%/client-manifest-not-modified.scm \ %reldir%/server-content.scm \ %reldir%/server-path.scm \ - %reldir%/http-link.scm + %reldir%/http-link.scm \ + %reldir%/acl.scm EXTRA_DIST += $(TESTS) %reldir%/ChangeLog diff --git a/tests/acl-with-group.scm b/tests/acl-with-group.scm new file mode 100644 index 0000000..210cc21 --- /dev/null +++ b/tests/acl-with-group.scm @@ -0,0 +1,11 @@ +(define (http-get uri) + (unless (equal? uri + (string->uri "https://group-server.example.com/the#group")) + (exit 1) + (values + (build-response #:headers '((content-type text/turtle))) + "@prefix vcard: . + +<#group> a vcard:Group; + vcard:hasMember . +"))) diff --git a/tests/acl.scm b/tests/acl.scm new file mode 100644 index 0000000..b582b17 --- /dev/null +++ b/tests/acl.scm @@ -0,0 +1,249 @@ +(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/webid-oidc/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 + ;; /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 + ;; /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 "/private-docs/" RWC X X X) + (run-test "/private-docs/file1" RWC X RW X) + (run-test "/private-docs/file2" RWC X X X))))))))) -- cgit v1.2.3