Support for json-ld

12 files changed, 95 insertions, 54 deletions

diff --git a/configure.ac b/configure.ac
index b43b5d0..cce3239 100644
--- a/configure.ac
+++ b/configure.ac
@@ -42,7 +42,7 @@ GUILE_MODULE_REQUIRED([rdf rdf])
 GUILE_MODULE_REQUIRED([turtle tordf])
 GUILE_MODULE_REQUIRED([turtle fromrdf])
 GUILE_MODULE_REQUIRED([nquads tordf])
-GUILE_MODULE_REQUIRED([nquads fromrdf])
+GUILE_MODULE_REQUIRED([jsonld])
 
 AC_CONFIG_FILES([Makefile po/Makefile.in man/Makefile])
 AC_CONFIG_FILES([man/reset-env], [chmod +x man/reset-env])
diff --git a/guix/vkraus/packages/webid-oidc.scm b/guix/vkraus/packages/webid-oidc.scm
index 0fd3146..902903c 100644
--- a/guix/vkraus/packages/webid-oidc.scm
+++ b/guix/vkraus/packages/webid-oidc.scm
@@ -105,6 +105,7 @@
       ("guile" ,guile-3.0)
       ("guile-json" ,guile-json-4)
       ("guile-rdf" ,guile-rdf)
+      ("guile-jsonld" ,guile-jsonld)
       ("texinfo" ,texinfo)
       ("autoconf" ,autoconf)
       ("autoconf-archive" ,autoconf-archive)
diff --git a/po/fr.po b/po/fr.po
index e5c562d..35b9d88 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -2,7 +2,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-07-22 11:08+0200\n"
+"POT-Creation-Date: 2021-07-27 11:32+0200\n"
 "PO-Revision-Date: 2021-07-22 11:10+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
@@ -1006,7 +1006,7 @@ msgstr ""
 msgid "~a: authentication failure: ~a\n"
 msgstr "~a : échec d’authentificationn : ~a\n"
 
-#: src/scm/webid-oidc/resource-server.scm:261
+#: src/scm/webid-oidc/resource-server.scm:275
 #, scheme-format
 msgid "Warning: ~a\n"
 msgstr "Avertissement : ~a\n"
diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot
index 5651551..5ed53e5 100644
--- a/po/webid-oidc.pot
+++ b/po/webid-oidc.pot
@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc SNAPSHOT\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-07-22 11:08+0200\n"
+"POT-Creation-Date: 2021-07-27 11:32+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
@@ -963,7 +963,7 @@ msgstr ""
 msgid "~a: authentication failure: ~a\n"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:261
+#: src/scm/webid-oidc/resource-server.scm:275
 #, scheme-format
 msgid "Warning: ~a\n"
 msgstr ""
diff --git a/src/scm/webid-oidc/fetch.scm b/src/scm/webid-oidc/fetch.scm
index f998ba2..c027787 100644
--- a/src/scm/webid-oidc/fetch.scm
+++ b/src/scm/webid-oidc/fetch.scm
@@ -23,7 +23,11 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web uri)
-  #:use-module (turtle tordf))
+  #:use-module (rdf rdf)
+  #:use-module (turtle tordf)
+  #:use-module (nquads tordf)
+  #:use-module (json)
+  #:use-module (jsonld))
 
 (define*-public (fetch uri #:key (http-get http-get))
   (unless (uri? uri)
@@ -34,7 +38,7 @@
     (lambda ()
       (receive (response response-body)
           (http-get uri
-                    #:headers `((accept (text/turtle))))
+                    #:headers `((accept (text/turtle application/n-quads application/ld+json))))
         (with-exception-handler
             (lambda (error)
               (raise-unexpected-response response error))
@@ -44,17 +48,30 @@
                                                  (response-reason-phrase response)))
             (let ((content-type (response-content-type response)))
               (unless (and content-type
-                           (eq? (car content-type) 'text/turtle)
+                           (or
+                            (eq? (car content-type) 'text/turtle)
+                            (eq? (car content-type) 'application/n-quads)
+                            (eq? (car content-type) 'text/x-nquads)
+                            (eq? (car content-type) 'application/ld+json))
                            (or (not (assq-ref (cdr content-type) 'charset))
                                (equal? (assq-ref (cdr content-type) 'charset) "utf-8")))
-                (raise-unexpected-header-value 'content-type content-type)))
-            (when (bytevector? response-body)
-              (set! response-body (utf8->string response-body)))
-            (with-exception-handler
-                (lambda (rdf-error)
-                  (raise-not-turtle response-body rdf-error))
-              (lambda ()
-                (turtle->rdf (string-append
-                              "# This is not a file name\n"
-                              response-body)
-                             (uri->string uri))))))))))
+                (raise-unexpected-header-value 'content-type content-type))
+              (when (bytevector? response-body)
+                (set! response-body (utf8->string response-body)))
+              (with-exception-handler
+                  (lambda (rdf-error)
+                    (raise-not-turtle response-body rdf-error))
+                (lambda ()
+                  (case (car content-type)
+                    ((text/turtle)
+                     (turtle->rdf (string-append
+                                   "# This is not a file name\n"
+                                   response-body)
+                                  (uri->string uri)))
+                    ((application/ld+json)
+                     (rdf-dataset-default-graph
+                      (jsonld->rdf (json-string->scm response-body))))
+                    ((application/n-quads text/x-nquads)
+                     (nquads->rdf  (string-append
+                                    "# This is not a file name\n"
+                                    response-body)))))))))))))
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 2d1c798..a6c111e 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -120,6 +120,16 @@
        (lambda ()
          (f return))))))
 
+(define (nonrdf-or-turtle server-uri request request-body)
+  ;; If the request is an exotic RDF serialization
+  ;; format, we want to convert it to Turtle,
+  ;; otherwise we will consider it non-rdf.
+  (convert '(text/turtle */*)
+           server-uri
+           (uri-path (request-uri request))
+           (request-content-type request)
+           request-body))
+
 (define (serve-get return path if-match if-none-match content-type content etag headers user)
   (define (respond-normal)
     (return
@@ -213,39 +223,43 @@
                            other-headers)
                      user)))))
              ((PUT)
-              (return
-               (build-response
-                #:headers
-                `((etag . (,(update server-uri owner user
-                                    (uri-path (request-uri request))
-                                    (request-if-match request)
-                                    (request-if-none-match request)
-                                    (request-content-type request)
-                                    request-body
-                                    #:http-get http-get)
-                           . #f))))
-               ""
-               user))
-             ((POST)
-              (let ((types
-                     (map car
-                          (filter
-                           (lambda (link)
-                             (equal? (assq-ref link 'rel) "type"))
-                           (request-links request)))))
+              (receive (content-type content)
+                  (nonrdf-or-turtle server-uri request request-body)
                 (return
                  (build-response
-                  #:code 201 #:reason-phrase "Created"
                   #:headers
-                  `((location . ,(create server-uri owner user
-                                         (uri-path (request-uri request))
-                                         types
-                                         (assq-ref (request-headers request) 'slug)
-                                         (request-content-type request)
-                                         request-body
-                                         #:http-get http-get))))
+                  `((etag . (,(update server-uri owner user
+                                      (uri-path (request-uri request))
+                                      (request-if-match request)
+                                      (request-if-none-match request)
+                                      content-type
+                                      content
+                                      #:http-get http-get)
+                             . #f))))
                  ""
                  user)))
+             ((POST)
+              (receive (content-type content)
+                  (nonrdf-or-turtle server-uri request request-body)
+                (let ((types
+                       (map car
+                            (filter
+                             (lambda (link)
+                               (equal? (assq-ref link 'rel) "type"))
+                             (request-links request)))))
+                  (return
+                   (build-response
+                    #:code 201 #:reason-phrase "Created"
+                    #:headers
+                    `((location . ,(create server-uri owner user
+                                           (uri-path (request-uri request))
+                                           types
+                                           (assq-ref (request-headers request) 'slug)
+                                           content-type
+                                           content
+                                           #:http-get http-get))))
+                   ""
+                   user))))
              ((DELETE)
               (delete server-uri owner user
                       (uri-path (request-uri request))
diff --git a/src/scm/webid-oidc/serve.scm b/src/scm/webid-oidc/serve.scm
index 4f54495..c46ab8c 100644
--- a/src/scm/webid-oidc/serve.scm
+++ b/src/scm/webid-oidc/serve.scm
@@ -28,6 +28,8 @@
   #:use-module (rdf rdf)
   #:use-module (turtle fromrdf)
   #:use-module (nquads fromrdf)
+  #:use-module (json)
+  #:use-module (jsonld)
   #:export
   (
    convert
@@ -66,6 +68,11 @@
                   (values request
                           (rdf->nquads
                            (make-rdf-dataset data-as-rdf '()))))
+                 ((and (eq? request 'application/ld+json) data-as-rdf)
+                  (values 'application/ld+json
+                          (scm->json-string
+                           (rdf->jsonld
+                            (make-rdf-dataset data-as-rdf '())))))
                  ;; Add other conversion strategies here
                  (else
                   (try-satisfy (cdr accepts)))))))
diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm
index 6cd1a01..aecde36 100644
--- a/src/scm/webid-oidc/server/read.scm
+++ b/src/scm/webid-oidc/server/read.scm
@@ -88,7 +88,9 @@
              (unless relevant-etag
                (raise-exception
                 (make-auxiliary-resource-absent base-path path-type)))
-             (let ((accept-put (if (or container? path-type) "text/turtle" "*/*")))
+             (let ((accept-put (if (or container? path-type)
+                                   "text/turtle; application/n-quads; application/ld+json"
+                                   "*/*")))
                (values
                 ;; Headers
                 (let ((links
diff --git a/tests/client-manifest-fraudulent.scm b/tests/client-manifest-fraudulent.scm
index 96cabf4..a43039d 100644
--- a/tests/client-manifest-fraudulent.scm
+++ b/tests/client-manifest-fraudulent.scm
@@ -53,7 +53,7 @@
     }\"\"\" .
 ")
    (define headers-to-expect
-     '((accept (text/turtle))))
+     '((accept (text/turtle application/n-quads application/ld+json))))
    (define uri-to-expect
      (string->uri "https://fraudulent-app.example.com/id#app"))
    (define* (respond uri #:key (headers '()))
diff --git a/tests/client-manifest.scm b/tests/client-manifest.scm
index 12453ce..ba8a79a 100644
--- a/tests/client-manifest.scm
+++ b/tests/client-manifest.scm
@@ -47,7 +47,7 @@
     }\"\"\" .
 ")
    (define* (respond uri #:key (headers '()))
-     (unless (equal? headers '((accept (text/turtle))))
+     (unless (equal? headers '((accept (text/turtle application/n-quads application/ld+json))))
        (exit 1))
      (when (string? uri)
        (set! uri (string->uri uri)))
diff --git a/tests/crud.scm b/tests/crud.scm
index 6f5a3c0..17a0ac4 100644
--- a/tests/crud.scm
+++ b/tests/crud.scm
@@ -118,7 +118,7 @@
        ;; For root, we’re looking for the following headers:
        ;; - link: ldp:BasicContainer; rel = "type", </.acl>; rel = "acl", pim:Storage; rel = "type", owner; rel = "solid:owner"
        ;; - allow: GET, HEAD, OPTIONS, PUT, POST, but not DELETE
-       ;; - accept-put: 'text/turtle
+       ;; - accept-put: 'text/turtle 'application/n-quads 'application/ld+json
        ;; - content-type: 'text/turtle
        ;; - etag: weak
        ;; The content is a RDF graph, it should contain 1 triple: </> ldp:contains </inbox>.
@@ -149,7 +149,7 @@
            (exit 10))
          (when (memq 'DELETE allow)
            (exit 11))
-         (unless (equal? accept-put "text/turtle")
+         (unless (equal? accept-put "text/turtle; application/n-quads; application/ld+json")
            (exit 12))
          (unless (equal? content-type '(text/turtle))
            (exit 13))
@@ -190,7 +190,7 @@
            (exit 17))
          (when (memq 'POST allow)
            (exit 18))
-         (unless (equal? accept-put "text/turtle")
+         (unless (equal? accept-put "text/turtle; application/n-quads; application/ld+json")
            (exit 19))
          (unless (equal? content-type '(text/turtle))
            (exit 20))
diff --git a/tests/provider-confirmation.scm b/tests/provider-confirmation.scm
index 4a240e2..fe9f4a2 100644
--- a/tests/provider-confirmation.scm
+++ b/tests/provider-confirmation.scm
@@ -28,7 +28,7 @@
    (define what-uri-to-expect
      (string->uri "https://provider-confirmation.scm/id#webid"))
    (define what-headers-to-expect
-     '((accept (text/turtle))))
+     '((accept (text/turtle application/n-quads application/ld+json))))
    (define what-to-respond
      (build-response #:headers '((content-type text/turtle))))
    (define what-to-respond-body