diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-13 22:48:16 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-19 11:36:23 +0200 |
commit | 326f056867bab68ae94408a31af6f4c666dfb191 (patch) | |
tree | 73e7680dbb543192060c61c2089fb7cd135b76ca | |
parent | 5f6437959c641647447fe8801bee917a0d56c3dc (diff) |
server: add client endpoints
-rw-r--r-- | doc/disfluid.texi | 43 | ||||
-rw-r--r-- | po/POTFILES.in | 1 | ||||
-rw-r--r-- | po/disfluid.pot | 108 | ||||
-rw-r--r-- | po/fr.po | 142 | ||||
-rw-r--r-- | src/scm/webid-oidc/client.scm | 202 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/endpoint/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/endpoint/client.scm | 166 |
7 files changed, 373 insertions, 295 deletions
diff --git a/doc/disfluid.texi b/doc/disfluid.texi index 8f22927..16cb1e3 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -1549,6 +1549,7 @@ the user. * Request authentication:: * Hello world:: * Reverse proxy:: +* Client pages:: @end menu @node Error signalling @@ -1698,6 +1699,48 @@ Return the header set by the reverse proxy to hold the authenticated webid. @end deffn +@node Client pages +@section Client pages +The @emph{(webid-oidc server endpoint client)} module defines an +endpoint to serve the public pages for a client application. + +@deftp {Class} <client-id> (<endpoint>) @var{client-id} @var{redirect-uris} @var{client-name} @var{client-uri} @var{grant-types} @var{response-types} +During the OIDC authorization process, the identity provider must +check some things against the public URI of a client application. This +endpoint will respond to this query. + +You can construct it with @code{#:@var{redirect-uris}} (a list of +URIs), @code{#:@var{client-id}} (an URI, or string encoding an URI), +@code{#:@var{client-name}} (a string), @code{#:@var{grant-types}} (a +list of symbols or strings), @code{#:@var{response-types}} (a list of +symbols or strings). +@end deftp + +@deffn {Generic} redirect-uris @var{client-id} +Return the list of approved redirection URIs. +@end deffn + +@deffn {Generic} client-id @var{client-id} +Return the URI where the application can be queried by the identity +provider. +@end deffn + +@deffn {Generic} client-name @var{client-id} +Return the associated name. Please note that the companion +implementation of the identity provider in this package will not +display the name to the user, because it can be misleading. +@end deffn + +@deffn {Generic} client-uri @var{client-id} +Return the URI where people can find information about the +application. Also not hidden by the identity provider. +@end deffn + +@deftp {Class} <redirect-uri> (<endpoint>) +This endpoint receives an authorization code, and display it to the +user, asking to paste it in the application. +@end deftp + @node Running an Identity Provider @chapter Running an Identity Provider diff --git a/po/POTFILES.in b/po/POTFILES.in index f11d0d2..3666403 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -80,6 +80,7 @@ src/scm/webid-oidc/server/create.scm src/scm/webid-oidc/server/delete.scm src/scm/webid-oidc/server/endpoint.scm src/scm/webid-oidc/server/endpoint/authentication.scm +src/scm/webid-oidc/server/endpoint/client.scm src/scm/webid-oidc/server/endpoint/hello.scm src/scm/webid-oidc/server/endpoint/reverse-proxy.scm src/scm/webid-oidc/server/log.scm diff --git a/po/disfluid.pot b/po/disfluid.pot index fd646d9..030c1b2 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -277,9 +277,9 @@ msgid "" msgstr "" #: src/scm/webid-oidc/authorization-page-unsafe.scm:52 -#: src/scm/webid-oidc/client.scm:312 src/scm/webid-oidc/client.scm:329 -#: src/scm/webid-oidc/client.scm:346 src/scm/webid-oidc/hello-world.scm:147 +#: src/scm/webid-oidc/client.scm:193 src/scm/webid-oidc/hello-world.scm:147 #: src/scm/webid-oidc/identity-provider.scm:136 +#: src/scm/webid-oidc/server/endpoint/client.scm:153 #: src/scm/webid-oidc/server/endpoint/hello.scm:63 #: src/scm/webid-oidc/server/endpoint/reverse-proxy.scm:125 #: src/scm/webid-oidc/token-endpoint.scm:113 @@ -289,7 +289,7 @@ msgid "xml-lang|en" msgstr "" #: src/scm/webid-oidc/authorization-page-unsafe.scm:67 -#: src/scm/webid-oidc/client.scm:314 +#: src/scm/webid-oidc/server/endpoint/client.scm:155 msgid "page-title|Authorization" msgstr "" @@ -467,62 +467,16 @@ msgstr "" msgid "cannot serve the public manifest" msgstr "" -#: src/scm/webid-oidc/client.scm:135 +#: src/scm/webid-oidc/client.scm:137 msgid "accept-language-header|en-us" msgstr "" -#: src/scm/webid-oidc/client.scm:182 -msgid "Example application" +#: src/scm/webid-oidc/client.scm:196 +msgid "<h1>The request failed</h1>" msgstr "" -#: src/scm/webid-oidc/client.scm:209 -msgid "#:client-name should be a string" -msgstr "" - -#: src/scm/webid-oidc/client.scm:216 -msgid "#:client-uri should be an URI" -msgstr "" - -#: src/scm/webid-oidc/client.scm:225 -msgid "#:response-types should be a list of symbols" -msgstr "" - -#: src/scm/webid-oidc/client.scm:234 -msgid "#:grant-types should be a list of symbols" -msgstr "" - -#: src/scm/webid-oidc/client.scm:286 src/scm/webid-oidc/resource-server.scm:143 -msgid "reason-phrase|Not Modified" -msgstr "" - -#: src/scm/webid-oidc/client.scm:316 -msgid "" -"You have been authorized. Please paste the following code in the application:" -msgstr "" - -#: src/scm/webid-oidc/client.scm:321 -msgid "reason-phrase|Invalid Request" -msgstr "" - -#: src/scm/webid-oidc/client.scm:331 -msgid "page-title|Error" -msgstr "" - -#: src/scm/webid-oidc/client.scm:333 -msgid "Your identity provider did not authorize you. :(" -msgstr "" - -#: src/scm/webid-oidc/client.scm:338 -#: src/scm/webid-oidc/identity-provider.scm:129 -msgid "reason-phrase|Not Found" -msgstr "" - -#: src/scm/webid-oidc/client.scm:348 -msgid "page-title|Not Found" -msgstr "" - -#: src/scm/webid-oidc/client.scm:350 -msgid "This page does not exist on the server." +#: src/scm/webid-oidc/client.scm:201 src/scm/webid-oidc/hello-world.scm:155 +msgid "<p>No more information.</p>" msgstr "" #: src/scm/webid-oidc/client/accounts.scm:118 @@ -1065,10 +1019,6 @@ msgstr "" msgid "<h1>Please authenticate</h1>" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:155 -msgid "<p>No more information.</p>" -msgstr "" - #: src/scm/webid-oidc/http-link.scm:148 msgid "the #:anchor parameter should be a string or an URI reference" msgstr "" @@ -1117,6 +1067,10 @@ msgstr "" msgid "Warning: generating a new key pair." msgstr "" +#: src/scm/webid-oidc/identity-provider.scm:129 +msgid "reason-phrase|Not Found" +msgstr "" + #: src/scm/webid-oidc/jti.scm:59 #, scheme-format msgid "a replay has been detected with JTI ~s" @@ -2107,6 +2061,11 @@ msgstr "" msgid "reason-phrase|Precondition Failed" msgstr "" +#: src/scm/webid-oidc/resource-server.scm:143 +#: src/scm/webid-oidc/server/endpoint/client.scm:123 +msgid "reason-phrase|Not Modified" +msgstr "" + #: src/scm/webid-oidc/resource-server.scm:165 msgid "The owner is not defined." msgstr "" @@ -2246,6 +2205,39 @@ msgid "" "<p>There is an access token and a DPoP proof, but one or both is invalid.</p>" msgstr "" +#: src/scm/webid-oidc/server/endpoint/client.scm:70 +msgid "Example Solid Application" +msgstr "" + +#: src/scm/webid-oidc/server/endpoint/client.scm:81 +msgid "#:client-uri should be an URI" +msgstr "" + +#: src/scm/webid-oidc/server/endpoint/client.scm:100 +#, scheme-format +msgid "#:~a element ~a should be a string or a symbol" +msgstr "" + +#: src/scm/webid-oidc/server/endpoint/client.scm:106 +#, scheme-format +msgid "#:~a should be a list" +msgstr "" + +#: src/scm/webid-oidc/server/endpoint/client.scm:157 +msgid "" +"You have been authorized. Please paste the following code in the application:" +msgstr "" + +#: src/scm/webid-oidc/server/endpoint/client.scm:164 +msgid "reason-phrase|Invalid Request" +msgstr "" + +#: src/scm/webid-oidc/server/endpoint/client.scm:166 +msgid "" +"This page should obtain a code from your identity provider, but none has " +"been provided." +msgstr "" + #: src/scm/webid-oidc/server/endpoint/hello.scm:57 msgid "<p>You are not authentified.</p>" msgstr "" @@ -3,7 +3,7 @@ msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" "POT-Creation-Date: 2021-10-19 11:31+0200\n" -"PO-Revision-Date: 2021-10-19 11:34+0200\n" +"PO-Revision-Date: 2021-10-19 11:35+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" "Language: fr\n" @@ -308,9 +308,9 @@ msgstr "" "requis (#:webid et #:client-id), soit (#:jwt-header et #:jwt-payload)" #: src/scm/webid-oidc/authorization-page-unsafe.scm:52 -#: src/scm/webid-oidc/client.scm:312 src/scm/webid-oidc/client.scm:329 -#: src/scm/webid-oidc/client.scm:346 src/scm/webid-oidc/hello-world.scm:147 +#: src/scm/webid-oidc/client.scm:193 src/scm/webid-oidc/hello-world.scm:147 #: src/scm/webid-oidc/identity-provider.scm:136 +#: src/scm/webid-oidc/server/endpoint/client.scm:153 #: src/scm/webid-oidc/server/endpoint/hello.scm:63 #: src/scm/webid-oidc/server/endpoint/reverse-proxy.scm:125 #: src/scm/webid-oidc/token-endpoint.scm:113 @@ -320,7 +320,7 @@ msgid "xml-lang|en" msgstr "fr" #: src/scm/webid-oidc/authorization-page-unsafe.scm:67 -#: src/scm/webid-oidc/client.scm:314 +#: src/scm/webid-oidc/server/endpoint/client.scm:155 msgid "page-title|Authorization" msgstr "Autorisation" @@ -510,65 +510,17 @@ msgstr "" msgid "cannot serve the public manifest" msgstr "impossible de servir le manifeste public" -#: src/scm/webid-oidc/client.scm:135 +#: src/scm/webid-oidc/client.scm:137 msgid "accept-language-header|en-us" msgstr "fr-fr" -#: src/scm/webid-oidc/client.scm:182 -msgid "Example application" -msgstr "Application exemple" +#: src/scm/webid-oidc/client.scm:196 +msgid "<h1>The request failed</h1>" +msgstr "<h1>La requête a échoué</h1>" -#: src/scm/webid-oidc/client.scm:209 -msgid "#:client-name should be a string" -msgstr "#:client-name doit être une chaîne de caractères" - -#: src/scm/webid-oidc/client.scm:216 -msgid "#:client-uri should be an URI" -msgstr "#:client-uri doit être une URI" - -#: src/scm/webid-oidc/client.scm:225 -msgid "#:response-types should be a list of symbols" -msgstr "#:response-types doit être une liste de symboles" - -#: src/scm/webid-oidc/client.scm:234 -msgid "#:grant-types should be a list of symbols" -msgstr "#:grant-types doit être une liste de symboles" - -#: src/scm/webid-oidc/client.scm:286 src/scm/webid-oidc/resource-server.scm:143 -msgid "reason-phrase|Not Modified" -msgstr "Non Modifié" - -#: src/scm/webid-oidc/client.scm:316 -msgid "" -"You have been authorized. Please paste the following code in the application:" -msgstr "" -"Vous avez été autorisé. Veuillez coller le code suivant dans votre " -"application :" - -#: src/scm/webid-oidc/client.scm:321 -msgid "reason-phrase|Invalid Request" -msgstr "Requête Invalide" - -#: src/scm/webid-oidc/client.scm:331 -msgid "page-title|Error" -msgstr "Erreur" - -#: src/scm/webid-oidc/client.scm:333 -msgid "Your identity provider did not authorize you. :(" -msgstr "Votre fournisseur d’identité ne vous a pas autorisé. :(" - -#: src/scm/webid-oidc/client.scm:338 -#: src/scm/webid-oidc/identity-provider.scm:129 -msgid "reason-phrase|Not Found" -msgstr "Non Trouvé" - -#: src/scm/webid-oidc/client.scm:348 -msgid "page-title|Not Found" -msgstr "Non Trouvé" - -#: src/scm/webid-oidc/client.scm:350 -msgid "This page does not exist on the server." -msgstr "Cette page n’existe pas sur le serveur." +#: src/scm/webid-oidc/client.scm:201 src/scm/webid-oidc/hello-world.scm:155 +msgid "<p>No more information.</p>" +msgstr "<p>Pas plus d’information.</p>" #: src/scm/webid-oidc/client/accounts.scm:118 #, scheme-format @@ -1182,10 +1134,6 @@ msgstr "Le port doit être un nombre entre 0 et 65535.\n" msgid "<h1>Please authenticate</h1>" msgstr "<h1>Veuillez vous authentifier</h1>" -#: src/scm/webid-oidc/hello-world.scm:155 -msgid "<p>No more information.</p>" -msgstr "<p>Pas plus d’information.</p>" - #: src/scm/webid-oidc/http-link.scm:148 msgid "the #:anchor parameter should be a string or an URI reference" msgstr "" @@ -1238,6 +1186,10 @@ msgstr "" msgid "Warning: generating a new key pair." msgstr "Attention : génération d'une nouvelle paire de clé." +#: src/scm/webid-oidc/identity-provider.scm:129 +msgid "reason-phrase|Not Found" +msgstr "Non Trouvé" + #: src/scm/webid-oidc/jti.scm:59 #, scheme-format msgid "a replay has been detected with JTI ~s" @@ -2500,6 +2452,11 @@ msgstr "" msgid "reason-phrase|Precondition Failed" msgstr "Échec de Précondition" +#: src/scm/webid-oidc/resource-server.scm:143 +#: src/scm/webid-oidc/server/endpoint/client.scm:123 +msgid "reason-phrase|Not Modified" +msgstr "Non Modifié" + #: src/scm/webid-oidc/resource-server.scm:165 msgid "The owner is not defined." msgstr "Le propriétaire n’est pas défini." @@ -2643,6 +2600,44 @@ msgstr "" "<p>Il y a un jeton d’accès et une preuve DPoP, mais l’un ou les deux sont " "invalides.</p>" +#: src/scm/webid-oidc/server/endpoint/client.scm:70 +msgid "Example Solid Application" +msgstr "Application exemple Solid" + +#: src/scm/webid-oidc/server/endpoint/client.scm:81 +msgid "#:client-uri should be an URI" +msgstr "#:client-uri doit être une URI" + +#: src/scm/webid-oidc/server/endpoint/client.scm:100 +#, scheme-format +msgid "#:~a element ~a should be a string or a symbol" +msgstr "" +"l’élément #:~a numéro ~a doit être une chaîne de caractères ou un symbole" + +#: src/scm/webid-oidc/server/endpoint/client.scm:106 +#, scheme-format +msgid "#:~a should be a list" +msgstr "#:~a doit être une liste" + +#: src/scm/webid-oidc/server/endpoint/client.scm:157 +msgid "" +"You have been authorized. Please paste the following code in the application:" +msgstr "" +"Vous avez été autorisé. Veuillez coller le code suivant dans votre " +"application :" + +#: src/scm/webid-oidc/server/endpoint/client.scm:164 +msgid "reason-phrase|Invalid Request" +msgstr "Requête Invalide" + +#: src/scm/webid-oidc/server/endpoint/client.scm:166 +msgid "" +"This page should obtain a code from your identity provider, but none has " +"been provided." +msgstr "" +"Cette page devait obtenir un code de votre fournisseur d’identité, mais " +"aucun n’a été fourni." + #: src/scm/webid-oidc/server/endpoint/hello.scm:57 msgid "<p>You are not authentified.</p>" msgstr "<p>Vous n’êtes pas authentifié.</p>" @@ -2924,6 +2919,27 @@ msgstr "Contenu :" msgid "Discard edits" msgstr "Rejeter les modifications" +#~ msgid "#:client-name should be a string" +#~ msgstr "#:client-name doit être une chaîne de caractères" + +#~ msgid "#:response-types should be a list of symbols" +#~ msgstr "#:response-types doit être une liste de symboles" + +#~ msgid "#:grant-types should be a list of symbols" +#~ msgstr "#:grant-types doit être une liste de symboles" + +#~ msgid "page-title|Error" +#~ msgstr "Erreur" + +#~ msgid "Your identity provider did not authorize you. :(" +#~ msgstr "Votre fournisseur d’identité ne vous a pas autorisé. :(" + +#~ msgid "page-title|Not Found" +#~ msgstr "Non Trouvé" + +#~ msgid "This page does not exist on the server." +#~ msgstr "Cette page n’existe pas sur le serveur." + #~ msgid "<p>The client is compatible with Solid.</p>" #~ msgstr "<p>Le client est compatible avec Solid.</p>" diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 5322af1..ee0b72c 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -22,6 +22,8 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc client-manifest) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc server endpoint client) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -168,183 +170,39 @@ ((kw value args ...) (scan-arguments args headers `(,value ,kw ,@non-header-args) method))))) -(define-class <extended-client-manifest> (<client-manifest>) - (client-name #:init-keyword #:client-name #:accessor client-name) - (client-uri #:init-keyword #:client-uri #:accessor client-uri) - (grant-types #:init-keyword #:grant-types #:accessor grant-types) - (response-types #:init-keyword #:response-types #:accessor response-types) - #:module-name '(webid-oidc client)) - -(define-method (initialize (client <extended-client-manifest>) initargs) - (next-method) - (let-keywords - initargs #t - ((client-name (G_ "Example application")) - (client-uri "https://webid-oidc-demo.planete-kraus.eu") - (grant-types '(refresh_token authorization_code)) - (response-types '(code))) - (let fix-grant-types ((grant-types grant-types) - (ok '())) - (match grant-types - (() - (let ((grant-types (reverse ok))) - (let fix-response-types ((response-types response-types) - (ok '())) - (match response-types - (() - (let ((response-types (reverse ok))) - (let fix-client-uri ((client-uri client-uri)) - (match client-uri - ((? uri? client-uri) - (let fix-client-name ((client-name client-name)) - (match client-name - ((? string? client-name) - (begin - (slot-set! client 'client-name client-name) - (slot-set! client 'client-uri client-uri) - (slot-set! client 'grant-types grant-types) - (slot-set! client 'response-types response-types))) - (else - (scm-error 'wrong-type-arg "make" - (G_ "#:client-name should be a string") - '() - (list client-name)))))) - ((? string? (= string->uri (? uri? client-uri))) - (fix-client-uri client-uri)) - (else - (scm-error 'wrong-type-arg "make" - (G_ "#:client-uri should be an URI") - '() - (list client-uri))))))) - (((or (? string? (= string->symbol hd)) - (? symbol? hd)) - response-types ...) - (fix-response-types response-types `(,hd ,@ok))) - (else - (scm-error 'wrong-type-arg "make" - (G_ "#:response-types should be a list of symbols") - '() - (list response-types))))))) - (((or (? string? (= string->symbol hd)) - (? symbol? hd)) - grant-types ...) - (fix-grant-types grant-types `(,hd ,@ok))) - (else - (scm-error 'wrong-type-arg "make" - (G_ "#:grant-types should be a list of symbols") - '() - (list grant-types))))))) - -(define-method (->json-data (client <extended-client-manifest>)) - (let ((other - (catch 'goops-error - (lambda () - (next-method)) - (lambda _ - '())))) - (let ((all - `((client_name . ,(client-name client)) - (client_uri . ,(uri->string (client-uri client))) - (grant_types . ,(list->vector (map symbol->string (grant-types client)))) - (response_types . ,(list->vector (map symbol->string (response-types client)))) - ,@other))) - ;; Put @context first - (receive (context non-context) - (let search-context ((fields all) - (context-ones '()) - (non-context-ones '())) - (match fields - ((('@context . ,context) fields ...) - (search-context fields `(,context ,@context-ones) non-context-ones)) - ((non-context fields ...) - (search-context fields context-ones `(,non-context ,@non-context-ones))) - (() - (values (reverse context-ones) (reverse non-context-ones))))) - (append - (map (lambda (ctx) `(@context . ,ctx)) context) - non-context))))) - (define* (serve-application id redirect-uri . args) - (let ((manifest (apply make <extended-client-manifest> + (let ((endpoint (apply make <client-id> #:client-id id #:redirect-uris (list redirect-uri) args))) (lambda (request request-body) - (parameterize ((web-locale request)) - (let ((uri (request-uri request))) - (cond - ((equal? (uri-path uri) (uri-path id)) - (receive (response response-body) (serve manifest #f) - (let ((if-none-match (request-if-none-match request)) - (etag (response-etag response))) - (if (and (list? if-none-match) - etag - (member (car etag) (map car if-none-match))) - (values - (build-response - #:code 304 - #:reason-phrase (W_ "reason-phrase|Not Modified") - #:headers `((content-type application/ld+json) - (etag . ,etag))) - #f) - (values response response-body))))) - ((equal? (uri-path uri) (uri-path redirect-uri)) - (let ((query-args - (map - (lambda (key=value) - (let ((splits - (map uri-decode (string-split key=value #\=)))) - (if (or (null? splits) (null? (cdr splits))) - splits - (cons (string->symbol (car splits)) (cdr splits))))) - (string-split (uri-query uri) #\&)))) - (let ((code (assq-ref query-args 'code))) - (if code - (values - (build-response - #: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"))) - (head - (title ,(W_ "page-title|Authorization"))) - (body - (p ,(W_ "You have been authorized. Please paste the following code in the application:")) - (p (strong ,code))))))))) - (values - (build-response - #:code 400 - #:reason-phrase (W_ "reason-phrase|Invalid Request") - #: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"))) - (head - (title ,(W_ "page-title|Error"))) - (body - (p ,(W_ "Your identity provider did not authorize you. :("))))))))))))) - (else + (with-exception-handler + (lambda (exn) + (unless (web-exception? exn) + (raise-exception exn)) (values (build-response - #:code 404 - #:reason-phrase (W_ "reason-phrase|Not Found") + #:code (web-exception-code exn) + #:reason-phrase (web-exception-reason-phrase exn) #: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"))) - (head - (title ,(W_ "page-title|Not Found"))) - (body - (p ,(W_ "This page does not exist on the server.")))))))))))))))) + (call-with-output-string + (cute 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 + ,(call-with-input-string + (format #f (W_ "<h1>The request failed</h1>")) + xml->sxml) + ,(if (user-message? exn) + (user-message-sxml exn) + (call-with-input-string + (format #f (W_ "<p>No more information.</p>")) + xml->sxml))))) + <>)))) + (lambda () + (receive (response response-body response-meta) + (handle endpoint request request-body) + (values response response-body))) + #:unwind? #t)))) diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am index 1e4ee16..e6c6158 100644 --- a/src/scm/webid-oidc/server/endpoint/Makefile.am +++ b/src/scm/webid-oidc/server/endpoint/Makefile.am @@ -17,9 +17,11 @@ dist_endpointserverwebidoidcmod_DATA += \ %reldir%/reverse-proxy.scm \ %reldir%/authentication.scm \ - %reldir%/hello.scm + %reldir%/hello.scm \ + %reldir%/client.scm endpointserverwebidoidcgo_DATA += \ %reldir%/reverse-proxy.go \ %reldir%/authentication.go \ - %reldir%/hello.go + %reldir%/hello.go \ + %reldir%/client.go diff --git a/src/scm/webid-oidc/server/endpoint/client.scm b/src/scm/webid-oidc/server/endpoint/client.scm new file mode 100644 index 0000000..ffa93c3 --- /dev/null +++ b/src/scm/webid-oidc/server/endpoint/client.scm @@ -0,0 +1,166 @@ +;; disfluid, implementation of the Solid specification +;; Copyright (C) 2021 Vivien Kraus + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +(define-module (webid-oidc server endpoint client) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc provider-confirmation) + #:use-module (webid-oidc client-manifest) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (web server) + #:use-module (web client) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (webid-oidc web-i18n) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (sxml simple) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (oop goops) + #:duplicates (merge-generics) + #:declarative? #t + #:re-export + ( + client-id + redirect-uris + ) + #:export + ( + <client-id> + client-name + client-uri + grant-types + response-types + + <redirect-uri> + )) + +(define-class <client-id> (<endpoint> <client-manifest>) + (client-name #:init-keyword #:client-name #:getter client-name) + (client-uri #:init-keyword #:client-uri #:getter client-uri) + (grant-types #:init-keyword #:grant-types #:getter grant-types) + (response-types #:init-keyword #:response-types #:getter response-types) + #:module-name '(webid-oidc server endpoint client)) + +(define-method (initialize (c <client-id>) initargs) + (next-method) + (let-keywords + initargs #t + ((client-name (G_ "Example Solid Application")) + (client-uri (string->uri "https://disfluid.planete-kraus.eu")) + (grant-types '(refresh_token authorization_code)) + (response-types '(code))) + (match client-uri + ((? string? (= string->uri (? uri? client-uri))) + (slot-set! c 'client-uri client-uri)) + ((? uri?) + #t) + (else + (scm-error 'wrong-type-arg "make <client-id>" + (G_ "#:client-uri should be an URI") + '() + (list client-uri)))) + (let ((fix-symbol-list + (lambda (items what) + (let fix ((values items) + (fixed '()) + (index 0)) + (match values + ((? vector? x) + (fix (vector->list x) fixed index)) + (() + (slot-set! c what (reverse fixed))) + (((or (? string? (= string->symbol value)) + (? symbol? value)) + values ...) + (fix values `(,value @fixed) (+ index 1))) + ((wrong _ ...) + (scm-error 'wrong-type-arg "make <client-id>" + (format #f (G_ "#:~a element ~a should be a string or a symbol") + what index) + '() + (list wrong))) + (else + (scm-error 'wrong-type-arg "make <client-id>" + (format #f (G_ "#:~a should be a list") + what + '() + (list wrong))))))))) + (fix-symbol-list grant-types 'grant-types) + (fix-symbol-list response-types 'response-types)))) + +(define-method (handle (endpoint <client-id>) request request-body) + (receive (response response-body) (serve endpoint #f) + (let ((if-none-match (request-if-none-match request)) + (etag (response-etag response))) + (if (and (list? if-none-match) + etag + (member (car etag) (map car if-none-match))) + (values + (build-response + #:code 304 + #:reason-phrase (W_ "reason-phrase|Not Modified") + #:headers `((content-type application/ld+json) + (etag . ,etag))) + #f + '()) + (values response response-body '()))))) + +(define-class <redirect-uri> (<endpoint>)) + +(define-method (handle (endpoint <redirect-uri>) request request-body) + (let ((query-args + (apply + append + (map + (lambda (key=value) + (match (map uri-decode (string-split key=value #\=)) + ((key value) + `((,key . ,value))) + (else '()))) + (string-split (uri-query (request-uri request)) #\&))))) + (let ((code (assq-ref query-args 'code))) + (if code + (values + (build-response + #:headers `((content-type applicationn/xhtml+xml))) + (call-with-output-string + (cute 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"))) + (head + (title ,(W_ "page-title|Authorization"))) + (body + (p ,(W_ "You have been authorized. Please paste the following code in the application:")) + (p (strong ,code))))) + <>)) + '()) + ;; No code: + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Invalid Request")) + (make-user-message + `(p ,(W_ "This page should obtain a code from your identity provider, but none has been provided."))))))))) |