From f2c75420d982cd44ba67278b8ce01fb73438c865 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Sun, 6 Dec 2020 19:43:34 +0100
Subject: Implement Solid oidc provider confirmation

---
 src/scm/webid-oidc/Makefile.am               |  6 ++-
 src/scm/webid-oidc/errors.scm                | 13 ++++++
 src/scm/webid-oidc/provider-confirmation.scm | 69 ++++++++++++++++++++++++++++
 3 files changed, 86 insertions(+), 2 deletions(-)
 create mode 100644 src/scm/webid-oidc/provider-confirmation.scm

(limited to 'src')

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 6676fe9..42c65b6 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -18,7 +18,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/authorization-page-unsafe.scm \
   %reldir%/authorization-endpoint.scm \
   %reldir%/token-endpoint.scm \
-  %reldir%/identity-provider.scm
+  %reldir%/identity-provider.scm \
+  %reldir%/provider-confirmation.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -40,6 +41,7 @@ webidoidcgo_DATA += \
   %reldir%/authorization-page-unsafe.go \
   %reldir%/authorization-endpoint.go \
   %reldir%/token-endpoint.go \
-  %reldir%/identity-provider.go
+  %reldir%/identity-provider.go \
+  %reldir%/provider-confirmation.go
 
 EXTRA_DIST += %reldir%/ChangeLog
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 69077b2..45da79a 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -818,6 +818,16 @@
   (raise-exception
    ((record-constructor &no-refresh-token))))
 
+(define-public &unconfimed-provider
+  (make-exception-type
+   '&unconfirmed-provider
+   &external-error
+   '(subject provider)))
+
+(define-public (raise-unconfirmed-provider subject provider)
+  (raise-exception
+   ((record-constructor &unconfirmed-provider) subject provider)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -1138,6 +1148,9 @@
           ((&unknown-client-locale)
            (format #f (G_ "I couldn’t set the locale to ~s as an approximation of the client locale ~s")
                    (get 'c-locale) (get 'web-locale)))
+          ((&unconfirmed-provider)
+           (format #f (G_ "~s does not admit ~s as an identity provider")
+                   (get 'subject) (get 'provider)))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/provider-confirmation.scm b/src/scm/webid-oidc/provider-confirmation.scm
new file mode 100644
index 0000000..5e9357c
--- /dev/null
+++ b/src/scm/webid-oidc/provider-confirmation.scm
@@ -0,0 +1,69 @@
+(define-module (webid-oidc provider-confirmation)
+  #: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))))
-- 
cgit v1.2.3