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

;; 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 <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 ((webid-oidc parameters) #:prefix p:)
  #:use-module (webid-oidc web-i18n)
  #:use-module (web uri)
  #: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 (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (

   &cannot-fetch-group
   make-cannot-fetch-group
   cannot-fetch-group?
   cannot-fetch-group-uri

   &forbidden
   make-forbidden
   forbidden?
   forbidden-path
   forbidden-user
   forbidden-owner
   forbidden-expected-mode

   wac-get-modes

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

   ))

(define-exception-type
  &cannot-fetch-group
  &external-error
  make-cannot-fetch-group
  cannot-fetch-group?
  (group-uri cannot-fetch-group-uri))

(define-exception-type
  &forbidden
  &external-error
  make-forbidden
  forbidden?
  (path forbidden-path)
  (user forbidden-user)
  (owner forbidden-owner)
  (expected-mode forbidden-expected-mode))

(define (group-member? 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)
          (let ((final-message
                 (if (exception-with-message? error)
                     (format #f (G_ "cannot fetch group ~s: ~a")
                             (uri->string group-uri)
                             (exception-message error))
                     (format #f (G_ "cannot fetch group ~s")
                             (uri->string group-uri)))))
            (raise-exception
             (make-exception
              (make-cannot-fetch-group group-uri)
              (make-exception-with-message final-message)
              error)
             #:continuable? #t))
          #f)
      (lambda ()
        (let ((data (fetch group-doc-uri)))
          (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 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? 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 user rdf-match
                              allowed-modes authorizations)
  (if (null? authorizations)
      (reverse allowed-modes)
      (let ((new-modes
             (check-authorization path check-default? server-name final-path user rdf-match
                                  (car authorizations))))
        (check-authorizations
         path check-default? server-name final-path 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)
  (define (wac-check-recursive path check-default?)
    (receive (main 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 (assoc-ref auxiliary acl-aux)))
        (if acl
            (with-rdf-source
             server-name path (content-type acl) (static-content acl)
             (lambda (rdf-match)
               (check-authorizations
                path check-default? server-name final-path 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)))
    (let accumulate-unique ((accumulated '())
                            (list (sort all-modes
                                        (match-lambda*
                                          (((? uri? (= uri->string a))
                                            (? uri? (= uri->string b)))
                                           (string< a b))))))
      (match list
        (() (reverse accumulated))
        ((hd list ...)
         (match accumulated
           ((or () ;; Nothing accumulated, can’t be unique
                ((? (lambda (head) (not (equal? head hd)))) _ ...))
            (accumulate-unique `(,hd ,@accumulated) list))
           (else
            (accumulate-unique accumulated list))))))))

(define (check-mode server-name path owner user 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)))
      (define (check-modes modes)
        (if (null? modes)
            (let ((final-message
                   (format #f (G_ "the resource under ~s is owned by ~s, and ~s can’t access it with ~s")
                           path
                           (uri->string owner)
                           (if user
                               (uri->string user)
                               (G_ "is owned by ..., and <> can’t access it|an anonymous user"))
                           (uri->string expected-mode))))
              (raise-exception
               (make-exception
                (make-forbidden path user owner expected-mode)
                (make-exception-with-message final-message))))
            (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)
  (check-mode server-name path owner user
              (string->uri "http://www.w3.org/ns/auth/acl#Read")))

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

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

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