diff options
Diffstat (limited to 'src/scm/webid-oidc/provider-confirmation.scm')
-rw-r--r-- | src/scm/webid-oidc/provider-confirmation.scm | 69 |
1 files changed, 69 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..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)))) |