Set up content negociation

To add support for new conversion strategies, edit serve.scm and fetch.scm.

4 files changed, 179 insertions, 62 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 867d2ee..bdb3af8 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -26,6 +26,7 @@ dist_webidoidcmod_DATA += \
   %reldir%/jti.scm \
   %reldir%/dpop-proof.scm \
   %reldir%/fetch.scm \
+  %reldir%/serve.scm \
   %reldir%/client-manifest.scm \
   %reldir%/authorization-code.scm \
   %reldir%/refresh-token.scm \
@@ -57,6 +58,7 @@ webidoidcgo_DATA += \
   %reldir%/jti.go \
   %reldir%/dpop-proof.go \
   %reldir%/fetch.go \
+  %reldir%/serve.go \
   %reldir%/client-manifest.go \
   %reldir%/authorization-code.go \
   %reldir%/refresh-token.go \
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index c969a40..522e563 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -1036,6 +1036,22 @@
         precondition-failed-if-none-match
         precondition-failed-real-etag)
 
+(define-exception-type
+  &not-acceptable
+  &external-error
+  make-not-acceptable
+  not-acceptable?
+  (client-accepts not-acceptable-client-accepts)
+  (path not-acceptable-path)
+  (content-type not-acceptable-content-type))
+
+(export &not-acceptable
+        make-not-acceptable
+        not-acceptable?
+        not-acceptable-client-accepts
+        not-acceptable-path
+        not-acceptable-content-type)
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -1422,6 +1438,11 @@
                        (get 'path) (get 'if-match) (get 'if-none-match) (get 'real-etag))
                (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has no representation")
                        (get 'path) (get 'if-match) (get 'if-none-match))))
+          ((&not-acceptable)
+           (format #f (G_ "the client wanted a response with a content type among ~s, but the resource at ~s has content-type ~s which cannot be converted to one of them")
+                   (get 'client-accepts)
+                   (get 'path)
+                   (get 'content-type)))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 9988cba..7f9c8f9 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -20,6 +20,7 @@
   #:use-module (webid-oidc provider-confirmation)
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc serve)
   #:use-module (webid-oidc server create)
   #:use-module (webid-oidc server read)
   #:use-module (webid-oidc server update)
@@ -148,12 +149,27 @@
                         #:http-get http-get)
                 (with-exception-handler
                     (lambda (error)
-                      (return
-                       (build-response
-                        #:headers headers)
-                       (if (eq? method 'GET)
-                           content
-                           "")))
+                      (let ((true-content-type
+                             (car (assq-ref headers 'content-type)))
+                            (other-headers
+                             (filter
+                              (lambda (h)
+                                (not (eq? (car h) 'content-type)))
+                              headers)))
+                        (receive (negociated-content-type
+                                  negociated-content)
+                            (convert (request-accept request #f)
+                                     server-uri
+                                     (uri-path (request-uri request))
+                                     true-content-type
+                                     content)
+                          (return
+                           (build-response
+                            #:headers (cons `(content-type ,negociated-content-type)
+                                            other-headers))
+                           (if (eq? method 'GET)
+                               negociated-content
+                               "")))))
                   (lambda ()
                     (unless (or (request-if-match request)
                                 (request-if-none-match request))
@@ -220,59 +236,64 @@
          (if (cannot-fetch-group? error)
              (format (current-error-port) (G_ "Warning: ~a\n")
                      (error->str error))
-             (begin
-               (format (current-error-port) (G_ "Error: ~a\n")
-                       (error->str error))
-               (cond
-                ((uri-slash-semantics-error? error)
-                 (return
-                  (build-response
-                   #:code 301
-                   #:reason-phrase "Found"
-                   #:headers
-                   `((location
-                      . ,(build-uri
-                          (uri-scheme server-uri)
-                          #:userinfo (uri-userinfo server-uri)
-                          #:host (uri-host server-uri)
-                          #:port (uri-port server-uri)
-                          #:path (uri-slash-semantics-error-expected-path error)))))
-                  ""))
-                ((or (path-not-found? error)
-                     (auxiliary-resource-absent? error)
-                     (forbidden? error))
-                 (if user
-                     ;; That’s a forbidden
-                     (return
-                      (build-response #:code 403 #:reason-phrase "Forbidden")
-                      "")
-                     (return
-                      (build-response #:code 401 #:reason-phrase "Unauthorized"
-                                      #:headers `((www-authenticate . ((DPoP)))))
-                      "")))
-                ((or (cannot-delete-root? error))
-                 (return
-                  (build-response
-                   #:code 405
-                   #:reason-phrase "Method Not Allowed")
-                  ""))
-                ((or (container-not-empty? error)
-                     (incorrect-containment-triples? error)
-                     (path-is-auxiliary? error))
-                 (return
-                  (build-response
-                   #:code 409
-                   #:reason-phrase "Conflict")
-                  ""))
-                ((unsupported-media-type? error)
-                 (return
-                  (build-response
-                   #:code 415
-                   #:reason-phrase "Unsupported Media Type")
-                  ""))
-                ((precondition-failed? error)
-                 (return
-                  (build-response
-                   #:code 412
-                   #:reason-phrase "Precondition Failed")
-                  ""))))))))))
+             (cond
+              ((uri-slash-semantics-error? error)
+               (return
+                (build-response
+                 #:code 301
+                 #:reason-phrase "Found"
+                 #:headers
+                 `((location
+                    . ,(build-uri
+                        (uri-scheme server-uri)
+                        #:userinfo (uri-userinfo server-uri)
+                        #:host (uri-host server-uri)
+                        #:port (uri-port server-uri)
+                        #:path (uri-slash-semantics-error-expected-path error)))))
+                #f))
+              ((or (path-not-found? error)
+                   (auxiliary-resource-absent? error)
+                   (forbidden? error))
+               (if user
+                   ;; That’s a forbidden
+                   (return
+                    (build-response #:code 403 #:reason-phrase "Forbidden")
+                    #f)
+                   (return
+                    (build-response #:code 401 #:reason-phrase "Unauthorized"
+                                    #:headers `((www-authenticate . ((DPoP)))))
+                    #f)))
+              ((or (cannot-delete-root? error))
+               (return
+                (build-response
+                 #:code 405
+                 #:reason-phrase "Method Not Allowed")
+                #f))
+              ((or (container-not-empty? error)
+                   (incorrect-containment-triples? error)
+                   (path-is-auxiliary? error))
+               (return
+                (build-response
+                 #:code 409
+                 #:reason-phrase "Conflict")
+                #f))
+              ((unsupported-media-type? error)
+               (return
+                (build-response
+                 #:code 415
+                 #:reason-phrase "Unsupported Media Type")
+                #f))
+              ((precondition-failed? error)
+               (return
+                (build-response
+                 #:code 412
+                 #:reason-phrase "Precondition Failed")
+                #f))
+              ((not-acceptable? error)
+               (return
+                (build-response
+                 #:code 406
+                 #:reason-phrase "Not Acceptable")
+                #f))
+              (else
+               (raise-exception error)))))))))
diff --git a/src/scm/webid-oidc/serve.scm b/src/scm/webid-oidc/serve.scm
new file mode 100644
index 0000000..4f54495
--- /dev/null
+++ b/src/scm/webid-oidc/serve.scm
@@ -0,0 +1,73 @@
+;; webid-oidc, implementation of the Solid specification
+;; Copyright (C) 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 serve)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc fetch)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 exceptions)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (rdf rdf)
+  #:use-module (turtle fromrdf)
+  #:use-module (nquads fromrdf)
+  #:export
+  (
+   convert
+   ))
+
+(define (convert client-accepts server-name path content-type content)
+  (let ((data-as-rdf
+         (false-if-exception
+          (fetch
+           (build-uri (uri-scheme server-name)
+                      #:userinfo (uri-userinfo server-name)
+                      #:host (uri-host server-name)
+                      #:port (uri-port server-name)
+                      #:path path)
+           #:http-get
+           (lambda args
+             (values (build-response
+                      #:headers `((content-type ,content-type)))
+                     content))))))
+    (if client-accepts
+        ;; Content negociation is asked
+        (let try-satisfy ((accepts client-accepts))
+          (if (null? accepts)
+              (raise-exception (make-not-acceptable client-accepts path content-type))
+              (let ((request (caar accepts)))
+                (cond
+                 ((or (eq? request content-type)
+                      (eq? request '*/*))
+                  (values content-type content))
+                 ((and (eq? request 'text/turtle) data-as-rdf)
+                  (values 'text/turtle
+                          (rdf->turtle data-as-rdf)))
+                 ((and (or (eq? request 'application/n-quads)
+                           (eq? request 'text/x-nquads))
+                       data-as-rdf)
+                  (values request
+                          (rdf->nquads
+                           (make-rdf-dataset data-as-rdf '()))))
+                 ;; Add other conversion strategies here
+                 (else
+                  (try-satisfy (cdr accepts)))))))
+        ;; Content negociation is unwanted
+        (values content-type content))))