path: root/src/scm/webid-oidc/server/resource/wac.scm

;; 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 <https://www.gnu.org/licenses/>.

(define-module (webid-oidc server resource wac)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc server resource path)
  #:use-module (webid-oidc server resource content)
  #:use-module (webid-oidc cache)
  #:use-module (webid-oidc fetch)
  #: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 (rdf rdf)
  #:use-module (turtle tordf)
  #: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
  (

   wac-get-modes

   check-acl-can-read
   check-acl-can-write
   check-acl-can-append
   check-acl-can-control

   ))

(define (group-member? http-get group-uri agent)
  (when (string? group-uri)
    (set! group-uri (string->uri group-uri)))
  (when (string? agent)
    (set! group-uri (string->uri agent)))
  (let ((group-doc-uri
         (build-uri (uri-scheme group-uri)
                    #:userinfo (uri-userinfo group-uri)
                    #:host (uri-host group-uri)
                    #:port (uri-port group-uri)
                    #:path (uri-path group-uri)
                    #:query (uri-query group-uri))))
    (with-exception-handler
        (lambda (error)
          (raise-exception
           (make-cannot-fetch-group group-uri error)
           #:continuable? #t)
          #f)
      (lambda ()
        (let ((data (fetch group-doc-uri #:http-get http-get)))
          (with-index
           data
           (lambda (rdf-match)
             (not (null?
                   (rdf-match (uri->string group-uri)
                              "http://www.w3.org/2006/vcard/ns#hasMember"
                              (uri->string agent))))))))
      #:unwind? #t
      #:unwind-for-type &cannot-fetch-linked-data)))

(define (with-rdf-source server-name path content-type static-content f)
  (with-index
   (case content-type
     ((text/turtle)
      (turtle->rdf (string-append
                    "# This is not a file name\n"
                    (utf8->string static-content))
                   (uri->string
                    (build-uri (uri-scheme server-name)
                               #:userinfo (uri-userinfo server-name)
                               #:host (uri-host server-name)
                               #:port (uri-port server-name)
                               #:path (string-append path ".acl"))))))
   f))

(define (check-authorization path check-default? server-name final-path http-get user rdf-match id)
  ;; The authorization should give accessTo path,
  ;; or to a prefix of final-path; and it should
  ;; be for agent user, or a group that contains
  ;; user.
  (let ((access-to-ok
         (and
          ;; We’re looking for acl:accessTo targetting path
          (not
           (null?
            (rdf-match id "http://www.w3.org/ns/auth/acl#accessTo"
                       (uri->string
                        (build-uri (uri-scheme server-name)
                                   #:userinfo (uri-userinfo server-name)
                                   #:host (uri-host server-name)
                                   #:port (uri-port server-name)
                                   #:path path)))))
          (or (not check-default?)
              ;; We’re also looking for acl:default statement
              ;; targetting a prefix of final-path
              (let ((defaults
                      (map rdf-triple-object
                           (rdf-match id "http://www.w3.org/ns/auth/acl#default" #f))))
                (define (default-ok? uri)
                  (and (string? uri)
                       (string->uri uri)
                       (let ((uri (string->uri uri)))
                         (and (eq? (uri-scheme uri)
                                   (uri-scheme server-name))
                              (equal? (uri-userinfo uri)
                                      (uri-userinfo server-name))
                              (equal? (uri-host uri)
                                      (uri-host server-name))
                              (equal? (uri-port uri)
                                      (uri-port server-name))
                              (let ((final-path-components
                                     (split-and-decode-uri-path final-path))
                                    (default-components
                                      (split-and-decode-uri-path (uri-path uri))))
                                (define (prefix? x y)
                                  (or (null? x)
                                      (and (not (null? y))
                                           (equal? (car x) (car y))
                                           (prefix? (cdr x) (cdr y)))))
                                (prefix? default-components final-path-components))))))
                (not (null? (filter default-ok? defaults)))))))
        (agent-ok
         (let ((groups
                (map rdf-triple-object
                     (rdf-match id
                                "http://www.w3.org/ns/auth/acl#agentGroup"
                                #f)))
               (specific-agent-ok?
                (and user
                     (not (null?
                           (rdf-match id
                                      "http://www.w3.org/ns/auth/acl#agent"
                                      (uri->string user))))))
               (public-access?
                (not (null?
                      (rdf-match id
                                 "http://www.w3.org/ns/auth/acl#agentClass"
                                 "http://xmlns.com/foaf/0.1/Agent"))))
               (authenticated-access?
                (not (null?
                      (rdf-match id
                                 "http://www.w3.org/ns/auth/acl#agentClass"
                                 "http://www.w3.org/ns/auth/acl#AuthenticatedAgent")))))
           (or public-access?
               (and user authenticated-access?)
               specific-agent-ok?
               (and user
                    (not (null?
                          (filter (lambda (group)
                                    (group-member? http-get group user))
                                  groups))))))))
    (or
     (and access-to-ok
          agent-ok
          (filter
           (lambda (x) x)
           (map (lambda (triple)
                  (let ((mode (rdf-triple-object triple)))
                    (and (string? mode)
                         (string->uri mode))))
                (rdf-match id
                           "http://www.w3.org/ns/auth/acl#mode"
                           #f))))
     '())))

(define (check-authorizations path check-default? server-name final-path http-get user rdf-match
                              allowed-modes authorizations)
  (if (null? authorizations)
      (reverse allowed-modes)
      (let ((new-modes
             (check-authorization path check-default? server-name final-path http-get user rdf-match
                                  (car authorizations))))
        (check-authorizations
         path check-default? server-name final-path http-get user rdf-match
         (append (reverse new-modes) allowed-modes)
         (cdr authorizations)))))

(define acl-aux (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))

(define* (wac-get-modes server-name final-path user
                        #:key
                        (http-get http-get))
  (with-session
   (lambda (content-type contained static-content create delete)
     (define (wac-check-recursive path check-default?)
       (receive (main-etag auxiliary)
           (with-exception-handler
               (lambda (error)
                 (unless (path-not-found? error)
                   (raise-exception error))
                 (values #f '()))
             (lambda ()
               (read-path path))
             #:unwind? #t
             #:unwind-for-type &path-not-found)
         (let ((acl-etag (assoc-ref auxiliary acl-aux)))
           (if acl-etag
               (with-rdf-source
                server-name path (content-type acl-etag) (static-content acl-etag)
                (lambda (rdf-match)
                  (check-authorizations
                   path check-default? server-name final-path http-get user rdf-match
                   '()
                   (map rdf-triple-subject
                        (rdf-match #f
                                   "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
                                   "http://www.w3.org/ns/auth/acl#Authorization")))))
               ;; No existing ACL.
               (let ((parent-path
                      (string-append
                       "/"
                       (encode-and-join-uri-path
                        (reverse
                         (cdr
                          (reverse
                           (split-and-decode-uri-path path)))))
                       "/")))
                 (when (equal? parent-path "//")
                   ;; The parent is the root
                   (set! parent-path "/"))
                 (wac-check-recursive parent-path #t))))))
     (let ((all-modes (wac-check-recursive final-path #f)))
       (define (accumulate-unique accumulated list)
         (cond
          ((null? list)
           (reverse accumulated))
          ((or (null? accumulated) (not (equal? (car accumulated) (car list))))
           (accumulate-unique (cons (car list) accumulated) (cdr list)))
          (else
           (accumulate-unique accumulated (cdr list)))))
       (accumulate-unique
        '()
        (sort all-modes
              (lambda (a b)
                (string< (uri->string a) (uri->string b)))))))))

(define (check-mode server-name path owner user http-get expected-mode)
  (unless (equal? owner user)
    (receive (base-path type)
        (base-path path)
      (when (equal? type (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby"))
        ;; We’re checking the description resource, which is an alias
        ;; for the real resource.
        (set! path base-path))
      (when (equal? type (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))
        ;; We’re checking access modes for the ACL, so we’re looking
        ;; for Control over the base resource.
        (set! path base-path)
        (set! expected-mode (string->uri "http://www.w3.org/ns/auth/acl#Control"))))
    (let ((modes (wac-get-modes server-name path user #:http-get http-get)))
      (define (check-modes modes)
        (if (null? modes)
            (raise-exception
             (make-forbidden path user owner expected-mode))
            (or
             (equal? (car modes) expected-mode)
             ;; It is also OK if we’re asking for acl:Append but
             ;; acl:Write is provided.
             (and (equal? expected-mode (string->uri "http://www.w3.org/ns/auth/acl#Append"))
                  (equal? (car modes) (string->uri "http://www.w3.org/ns/auth/acl#Write")))
             (check-modes (cdr modes)))))
      (check-modes modes))))

(define* (check-acl-can-read server-name path owner user
                             #:key
                             (http-get http-get))
  (check-mode server-name path owner user http-get
              (string->uri "http://www.w3.org/ns/auth/acl#Read")))

(define* (check-acl-can-write server-name path owner user
                             #:key
                             (http-get http-get))
  (check-mode server-name path owner user http-get
              (string->uri "http://www.w3.org/ns/auth/acl#Write")))

(define* (check-acl-can-append server-name path owner user
                             #:key
                             (http-get http-get))
  (check-mode server-name path owner user http-get
              (string->uri "http://www.w3.org/ns/auth/acl#Append")))

(define* (check-acl-can-control server-name path owner user
                             #:key
                             (http-get http-get))
  (check-mode server-name path owner user http-get
              (string->uri "http://www.w3.org/ns/auth/acl#Control")))