diff options
Diffstat (limited to 'src/scm/webid-oidc/identity-provider.scm')
-rw-r--r-- | src/scm/webid-oidc/identity-provider.scm | 132 |
1 files changed, 72 insertions, 60 deletions
diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index e22f1ef..7f1fb48 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -22,6 +22,7 @@ #:use-module (webid-oidc jwk) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc jti) #:use-module (web request) #:use-module (web response) @@ -31,34 +32,37 @@ #:use-module (webid-oidc cache) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) - #:use-module (ice-9 i18n) + #:use-module (webid-oidc web-i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) #:use-module (sxml simple) + #:use-module (sxml match) #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors)) + #:use-module (rnrs bytevectors) + #:declarative? #t + #:export + ( -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) + make-identity-provider + + )) (define* (same-uri? a b #:key (skip-query #f)) (and (equal? (uri-path a) (uri-path b)) (or skip-query (equal? (uri-query a) (uri-query b))))) -(define*-public (make-identity-provider - issuer - key-file - subject - encrypted-password - jwks-uri - authorization-endpoint-uri - token-endpoint-uri - #:key - (http-get http-get)) +(define* (make-identity-provider + issuer + key-file + subject + encrypted-password + jwks-uri + authorization-endpoint-uri + token-endpoint-uri + #:key + (http-get http-get)) (let ((key (catch #t (lambda () @@ -82,55 +86,63 @@ (token-endpoint (make-token-endpoint token-endpoint-uri issuer alg key 3600)) (openid-configuration - (make-oidc-configuration jwks-uri - authorization-endpoint-uri - token-endpoint-uri)) + `((jwks_uri . ,(uri->string jwks-uri)) + (authorization_endpoint . ,(uri->string authorization-endpoint-uri)) + (token_endpoint . ,(uri->string token-endpoint-uri)) + (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc"))) (openid-configuration-uri (build-uri 'https #:host (uri-host issuer) #:path "/.well-known/openid-configuration"))) (lambda (request request-body) (let ((uri (request-uri request)) - (current-time (current-time))) - (cond ((same-uri? uri openid-configuration-uri) - (let* ((current-sec (time-second current-time)) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve-oidc-configuration exp openid-configuration))) - ((same-uri? uri jwks-uri) - (let* ((current-sec (time-second current-time)) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve-jwks exp (make-jwks (list key))))) - ((same-uri? uri authorization-endpoint-uri #:skip-query #t) - (authorization-endpoint request request-body)) - ((same-uri? uri token-endpoint-uri) - (token-endpoint request request-body)) - ((same-uri? uri subject) - (values - (build-response #:headers '((content-type text/turtle)) - #:port #f) - (format #f - "@prefix foaf: <http://xmlns.com/foaf/0.1/> . + (current-time ((p:current-date)))) + (parameterize ((web-locale request)) + (cond ((same-uri? uri openid-configuration-uri) + (let* ((current-sec (time-second (date->time-utc current-time))) + (exp-sec (+ current-sec 3600)) + (exp (time-utc->date + (make-time time-utc 0 exp-sec)))) + (serve-oidc-configuration exp openid-configuration))) + ((same-uri? uri jwks-uri) + (let* ((current-sec (time-second (date->time-utc current-time))) + (exp-sec (+ current-sec 3600)) + (exp (time-utc->date + (make-time time-utc 0 exp-sec)))) + (serve-jwks exp (make-jwks (list key))))) + ((same-uri? uri authorization-endpoint-uri #:skip-query #t) + (authorization-endpoint request request-body)) + ((same-uri? uri token-endpoint-uri) + (token-endpoint request request-body)) + ((same-uri? uri subject) + (values + (build-response #:headers '((content-type text/turtle)) + #:port #f) + (format #f + "@prefix foaf: <http://xmlns.com/foaf/0.1/> . @prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> . <#~a> a foaf:Person ; rdfs:comment \"It works. Now you should use another service to serve that resource.\" . " - (uri-fragment subject)))) - (else - (values - (build-response #:code 404 - #:reason-phrase "Not Found" - #:headers '((content-type application/xhtml+xml))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang "en")) - (body - (h1 "Resource not found") - (p "This OpenID Connect identity provider does not know the resource you are requesting.")))))))))))))))) + (uri-fragment subject)))) + (else + (values + (build-response #:code 404 + #:reason-phrase (W_ "reason-phrase|Not Found") + #:headers '((content-type application/xhtml+xml))) + (with-output-to-string + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Resource not found</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>"))) + ((*TOP* ,p) p)))))))))))))))))) |