fixup! Implement the GET, HEAD, OPTIONS methods for the server

1 files changed, 142 insertions, 166 deletions

diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm
index bff241a..895be46 100644
--- a/src/scm/webid-oidc/server/read.scm
+++ b/src/scm/webid-oidc/server/read.scm
@@ -32,25 +32,6 @@
 
    ))
 
-(define (check-mode server-name path owner user http-get expected-mode)
-  (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)
-           (check-modes (cdr modes)))))
-    (check-modes modes)))
-
-(define (check-acl-can-read server-name path owner user 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-control server-name path owner user http-get)
-  (check-mode server-name path owner user http-get
-              (string->uri "http://www.w3.org/ns/auth/acl#Control")))
-
 (define* (read server-name owner user path
                #:key
                (http-get http-get))
@@ -58,150 +39,145 @@
   (with-session
    (lambda (load-content-type load-contained load-static-content
                               do-create do-delete)
-     (let ((acl? (string-suffix? ".acl" path))
-           (description? (string-suffix? ".meta" path))
-           (base-path
-            (cond
-             ((string-suffix? ".acl" path)
-              (substring path 0 (- (string-length path) (string-length ".acl"))))
-             ((string-suffix? ".meta" path)
-              (substring path 0 (- (string-length path) (string-length ".meta"))))
-             (else path)))
-           (container? (string-suffix? path "/"))
-           (root? (equal? path "/")))
-       (unless (equal? user owner)
-         (if acl?
-             (check-acl-can-control server-name base-path owner user http-get)
-             (check-acl-can-read server-name path owner user http-get)))
-       (receive (main-etag auxiliary)
-           (read-path base-path)
-         (let ((relevant-etag
-                (cond
-                 (acl?
-                  (assoc-ref auxiliary
-                             (string->uri "http://www.w3.org/ns/auth/acl#accessControl")))
-                 (description?
-                  (assoc-ref auxiliary
-                             (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby")))
-                 (else
-                  main-etag)))
-               (non-rdf? (not (eq? (load-content-type main-etag) 'text/turtle)))
-               (auxiliary? (or acl? description?))
-               (allow (cond (root? '(GET HEAD OPTIONS POST PUT))
-                            (container? '(GET HEAD OPTIONS POST PUT DELETE))
-                            (else '(GET HEAD OPTIONS PUT DELETE)))))
-           (unless relevant-etag
-             (raise-exception
-              (make-auxiliary-resource-absent
-               base-path
-               (cond
-                (acl?
-                 (assoc-ref auxiliary
-                            (string->uri "http://www.w3.org/ns/auth/acl#accessControl")))
-                (description?
-                 (assoc-ref auxiliary
-                            (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby")))))))
-           (let ((description (and non-rdf? (string-append path ".meta")))
-                 (accept-put (if (or container? auxiliary?) "text/turtle" "*/*")))
-             (values
-              ;; Headers
-              (let ((links
-                     (let ((type
-                            (cons
-                             (if container?
-                                 (string->uri "http://www.w3.org/ns/ldp#BasicContainer")
-                                 (string->uri "http://www.w3.org/ns/ldp#Resource"))
-                             '((rel . "type"))))
-                           (acl
-                            (and (not acl?)
-                                 (cons
-                                  (build-uri
-                                   'https
-                                   #:userinfo (uri-userinfo server-name)
-                                   #:host (uri-host server-name)
-                                   #:port (uri-port server-name)
-                                   #:path (string-append path ".acl"))
-                                  '((rel . "acl")))))
-                           (describedby
-                            (and non-rdf?
-                                 (cons
-                                  (build-uri
-                                   'https
-                                   #:userinfo (uri-userinfo server-name)
-                                   #:host (uri-host server-name)
-                                   #:port (uri-port server-name)
-                                   #:path (string-append path ".acl"))
-                                  '((rel . "describedby")))))
-                           (describes
-                            (and description?
-                                 (cons
-                                  (build-uri
-                                   'https
-                                   #:userinfo (uri-userinfo server-name)
-                                   #:host (uri-host server-name)
-                                   #:port (uri-port server-name)
-                                   #:path (string-append path ".acl"))
-                                  '((rel . "https://www.w3.org/ns/iana/link-relations/relation#describes")))))
-                           (storage
-                            (and root?
-                                 (list
-                                  (list
-                                   (string->uri "http://www.w3.org/ns/pim/space#Storage")
-                                   '(rel . "type"))
-                                  (list
-                                   owner
-                                   '(rel . "http://www.w3.org/ns/solid/terms#owner"))))))
-                       (append
-                        (list type)
-                        (if acl (list acl) '())
-                        (if describedby (list describedby) '())
-                        (if describes (list describes) '())
-                        (or storage '())))))
-                `((link . ,links)
-                  (allow . ,allow)
-                  (accept-put . ,accept-put)
-                  (content-type
-                   . (,(if container?
-                           'text/turtle
-                           (load-content-type relevant-etag))))
-                  (etag . (,relevant-etag . #f))))
-              ;; Content
-              (if container?
-                  (let ((static-graph
-                         (fetch
-                          (build-uri
-                           'https
-                           #:userinfo (uri-userinfo server-name)
-                           #:host (uri-host server-name)
-                           #:port (uri-port server-name)
-                           #:path path)
-                          #:http-get
-                          (lambda (uri . args)
-                            (values
-                             (build-response
-                              #:headers `((content-type ,(load-content-type relevant-etag))))
-                             (load-static-content relevant-etag))))))
-                    (let ((final-graph
-                           (reverse
-                            (append
-                             (map (lambda (contained-path)
-                                    (make-rdf-triple
-                                     (uri->string
-                                      (build-uri
-                                       'https
-                                       #:userinfo (uri-userinfo server-name)
-                                       #:host (uri-host server-name)
-                                       #:port (uri-port server-name)
-                                       #:path path))
-                                     "http://www.w3.org/ns/ldp#contains"
-                                     (uri->string
-                                      (build-uri
-                                       'https
-                                       #:userinfo (uri-userinfo server-name)
-                                       #:host (uri-host server-name)
-                                       #:port (uri-port server-name)
-                                       #:path contained-path))))
-                                  (load-contained relevant-etag))
-                             static-graph))))
-                      (rdf->turtle final-graph)))
-                  (load-static-content relevant-etag))))))))))
+     (check-acl-can-read server-name path owner user #:http-get http-get)
+     (receive (base-path path-type)
+         (base-path path)
+       (let ((container? (container-path? path))
+             (root? (root-path? path))
+             (acl?
+              (equal? path-type
+                      (string->uri
+                       "http://www.w3.org/ns/auth/acl#accessControl")))
+             (description?
+              (equal?
+               path-type
+               (string->uri
+                "https://www.w3.org/ns/iana/link-relations/relation#describedby"))))
+         (receive (main-etag auxiliary)
+             (read-path base-path)
+           (let ((relevant-etag
+                  (if path-type
+                      (assoc-ref auxiliary path-type)
+                      main-etag))
+                 (needs-meta?
+                  (case (load-content-type main-etag)
+                    ((text/turtle)
+                     #f)
+                    (else #t)))
+                 (needs-acl?
+                  (not acl?))
+                 (allow (cond (root? '(GET HEAD OPTIONS POST PUT))
+                              (container? '(GET HEAD OPTIONS POST PUT DELETE))
+                              (else '(GET HEAD OPTIONS PUT DELETE)))))
+             (unless relevant-etag
+               (raise-exception
+                (make-auxiliary-resource-absent base-path path-type)))
+             (let ((accept-put (if (or container? path-type) "text/turtle" "*/*")))
+               (values
+                ;; Headers
+                (let ((links
+                       (let ((type
+                              (cons
+                               (if container?
+                                   (string->uri "http://www.w3.org/ns/ldp#BasicContainer")
+                                   (string->uri "http://www.w3.org/ns/ldp#Resource"))
+                               '((rel . "type"))))
+                             (acl
+                              (and needs-acl?
+                                   (cons
+                                    (build-uri
+                                     'https
+                                     #:userinfo (uri-userinfo server-name)
+                                     #:host (uri-host server-name)
+                                     #:port (uri-port server-name)
+                                     #:path (derive-path
+                                             base-path
+                                             (string->uri
+                                              "http://www.w3.org/ns/auth/acl#accessControl")))
+                                    '((rel . "acl")))))
+                             (describedby
+                              (and needs-meta?
+                                   (cons
+                                    (build-uri
+                                     'https
+                                     #:userinfo (uri-userinfo server-name)
+                                     #:host (uri-host server-name)
+                                     #:port (uri-port server-name)
+                                     #:path (derive-path
+                                             base-path
+                                             (string->uri
+                                              "https://www.w3.org/ns/iana/link-relations/relation#describedby")))
+                                    '((rel . "describedby")))))
+                             (describes
+                              (and description?
+                                   (cons
+                                    (build-uri
+                                     'https
+                                     #:userinfo (uri-userinfo server-name)
+                                     #:host (uri-host server-name)
+                                     #:port (uri-port server-name)
+                                     #:path base-path)
+                                    '((rel . "https://www.w3.org/ns/iana/link-relations/relation#describes")))))
+                             (storage
+                              (and root?
+                                   (list
+                                    (list
+                                     (string->uri "http://www.w3.org/ns/pim/space#Storage")
+                                     '(rel . "type"))
+                                    (list
+                                     owner
+                                     '(rel . "http://www.w3.org/ns/solid/terms#owner"))))))
+                         (append
+                          (list type)
+                          (if acl (list acl) '())
+                          (if describedby (list describedby) '())
+                          (if describes (list describes) '())
+                          (or storage '())))))
+                  `((link . ,links)
+                    (allow . ,allow)
+                    (accept-put . ,accept-put)
+                    (content-type
+                     . (,(if container?
+                             'text/turtle
+                             (load-content-type relevant-etag))))
+                    (etag . (,relevant-etag . #f))))
+                ;; Content
+                (if container?
+                    (let ((static-graph
+                           (fetch
+                            (build-uri
+                             'https
+                             #:userinfo (uri-userinfo server-name)
+                             #:host (uri-host server-name)
+                             #:port (uri-port server-name)
+                             #:path path)
+                            #:http-get
+                            (lambda (uri . args)
+                              (values
+                               (build-response
+                                #:headers `((content-type ,(load-content-type relevant-etag))))
+                               (load-static-content relevant-etag))))))
+                      (let ((final-graph
+                             (reverse
+                              (append
+                               (map (lambda (contained-path)
+                                      (make-rdf-triple
+                                       (uri->string
+                                        (build-uri
+                                         'https
+                                         #:userinfo (uri-userinfo server-name)
+                                         #:host (uri-host server-name)
+                                         #:port (uri-port server-name)
+                                         #:path path))
+                                       "http://www.w3.org/ns/ldp#contains"
+                                       (uri->string
+                                        (build-uri
+                                         'https
+                                         #:userinfo (uri-userinfo server-name)
+                                         #:host (uri-host server-name)
+                                         #:port (uri-port server-name)
+                                         #:path contained-path))))
+                                    (load-contained relevant-etag))
+                               static-graph))))
+                        (rdf->turtle final-graph)))
+                    (load-static-content relevant-etag)))))))))))