1 files changed, 70 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/provider-confirmation.scm b/src/scm/webid-oidc/provider-confirmation.scm
new file mode 100644
index 0000000..f767fee
--- /dev/null
+++ b/src/scm/webid-oidc/provider-confirmation.scm
@@ -0,0 +1,70 @@
+(define-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc fetch)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (rdf rdf)
+  #:use-module (turtle tordf))
+
+(define (find-confirmations subject graph)
+  (cond ((null? graph) '())
+        ((and (string=? (rdf-triple-predicate (car graph))
+                        "http://www.w3.org/ns/solid/terms#oidcIssuer")
+              (string? (rdf-triple-subject (car graph)))
+              (string=? (rdf-triple-subject (car graph)) subject)
+              (string? (rdf-triple-object (car graph)))
+              (string->uri (rdf-triple-object (car graph)))
+              (eq? (uri-scheme (string->uri (rdf-triple-object (car graph))))
+                   'https))
+         (cons (string->uri (rdf-triple-object (car graph)))
+               (find-confirmations subject (cdr graph))))
+        (else (find-confirmations subject (cdr graph)))))
+
+(define (serve-confirmations expiration-date subject cnf)
+  (let ((resource (format #f "@prefix solid: <http://www.w3.org/ns/solid/terms#> .
+
+<~a> solid:oidcIssuer ~a .
+"
+                          (uri->string subject)
+                          (string-join (map (lambda (uri)
+                                              (format #f "<~a>" (uri->string uri)))
+                                            cnf)
+                                       ", "))))
+    (values (build-response #:headers `((content-type text/turtle)
+                                        (expires . ,expiration-date)))
+            resource)))
+
+(define*-public (get-provider-confirmations subject
+                                            #:key
+                                            (http-get http-get))
+  (unless (equal? (uri-scheme subject) 'https)
+    (set! subject (build-uri 'https
+                             #:userinfo (uri-userinfo subject)
+                             #:host (uri-host subject)
+                             #:port (uri-port subject)
+                             #:path (uri-path subject)
+                             #:query (uri-query subject)
+                             #:fragment (uri-fragment subject))))
+  (let ((graph (fetch subject #:http-get http-get)))
+    (cons (build-uri 'https
+                     #:userinfo (uri-userinfo subject)
+                     #:host (uri-host subject)
+                     #:port (uri-port subject))
+          (find-confirmations (uri->string subject) graph))))
+
+(define*-public (confirm-provider subject issuer
+                                  #:key (http-get http-get))
+  (define (search lst)
+    (if (null? lst)
+        (raise-unconfirmed-provider subject issuer)
+        (or (string=? (car lst) (uri->string issuer))
+            (search (cdr lst)))))
+  (unless (string=? (uri-host subject) (uri-host issuer))
+    (search (get-provider-confirmations
+             subject
+             #:http-get http-get))))