From fd8608644cda11b6cd48d313dc89ad0135240e19 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Sun, 6 Dec 2020 18:57:33 +0100
Subject: Add a function to fetch linked data.

---
 src/scm/webid-oidc/Makefile.am |  6 ++++--
 src/scm/webid-oidc/errors.scm  | 26 +++++++++++++++++++++++++
 src/scm/webid-oidc/fetch.scm   | 44 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 74 insertions(+), 2 deletions(-)
 create mode 100644 src/scm/webid-oidc/fetch.scm

(limited to 'src')

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index ecb3f0a..31c23ab 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -8,7 +8,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/oidc-configuration.scm \
   %reldir%/access-token.scm \
   %reldir%/jti.scm \
-  %reldir%/dpop-proof.scm
+  %reldir%/dpop-proof.scm \
+  %reldir%/fetch.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -19,4 +20,5 @@ webidoidcgo_DATA += \
   %reldir%/oidc-configuration.go \
   %reldir%/access-token.go \
   %reldir%/jti.go \
-  %reldir%/dpop-proof.go
+  %reldir%/dpop-proof.go \
+  %reldir%/fetch.go
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 959b04e..2dc9edc 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -37,6 +37,16 @@
   (raise-exception
    ((record-constructor &not-json) value cause)))
 
+(define-public &not-turtle
+  (make-exception-type
+   '&not-turtle
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-turtle value cause)
+  (raise-exception
+   ((record-constructor &not-turtle) value cause)))
+
 (define-public &unsupported-crv
   (make-exception-type
    '&unsupported-crv
@@ -529,6 +539,16 @@
   (raise-exception
    ((record-constructor &cannot-encode-dpop-proof) dpop-proof key cause)))
 
+(define-public &cannot-fetch-linked-data
+  (make-exception-type
+   '&cannot-fetch-linked-data
+   &external-error
+   '(uri cause)))
+
+(define-public (raise-cannot-fetch-linked-data uri cause)
+  (raise-exception
+   ((record-constructor &cannot-fetch-linked-data) uri cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -547,6 +567,9 @@
           ((&not-json)
            (format #f (G_ "the value ~s is not JSON (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((&not-turtle)
+           (format #f (G_ "the value ~s is not Turtle (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
           ((&unsupported-crv)
            (format #f (G_ "the value ~s does not identify an elleptic curve")
                    (get 'crv)))
@@ -761,6 +784,9 @@
           ((&cannot-encode-dpop-proof)
            (format #f (G_ "I cannot encode ~s as a DPoP proof (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((&cannot-fetch-linked-data)
+           (format #f (G_ "I could not fetch a RDF graph at ~a (because ~a)")
+                   (uri->string (get 'uri)) (recurse (get 'cause))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/fetch.scm b/src/scm/webid-oidc/fetch.scm
new file mode 100644
index 0000000..6642ed1
--- /dev/null
+++ b/src/scm/webid-oidc/fetch.scm
@@ -0,0 +1,44 @@
+(define-module (webid-oidc fetch)
+  #:use-module (webid-oidc errors)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (turtle tordf))
+
+(define*-public (fetch uri #:key (http-get http-get))
+  (unless (uri? uri)
+    (set! uri (string->uri uri)))
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-fetch-linked-data uri error))
+    (lambda ()
+      (receive (response response-body)
+          (http-get uri
+                    #:headers `((accept (text/turtle))))
+        (with-exception-handler
+            (lambda (error)
+              (raise-unexpected-response response error))
+          (lambda ()
+            (unless (eqv? (response-code response) 200)
+              (raise-request-failed-unexpectedly (response-code response)
+                                                 (response-reason-phrase response)))
+            (let ((content-type (response-content-type response)))
+              (unless (and content-type
+                           (eq? (car content-type) 'text/turtle)
+                           (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))))))))))
-- 
cgit v1.2.3