diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-12 22:57:58 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-14 16:06:43 +0200 |
commit | 328b4957d05fc9b0f9ff87f2a4932ae0296ab069 (patch) | |
tree | 2d44b7896c91f9934b470fd6bb54141ddc4dc714 | |
parent | 6a83b79c4de5986ad61a552c2612b7cce0105cda (diff) |
Restructure the client API
The client API had several problems:
- using records instead of GOOPS means that we aren’t flexible enough
to introduce accounts protected by a password, for a multi-user
application;
- saving the user database to disk means we can’t have a proper
immutable API;
- it was difficult to predict when the users database would change,
and inform the user interface about this change;
- it had two different ways to negociate an access token, one when we
had a refresh token and one when we did not;
- it was supposed to either use account objects or a subject / issuer
pair, now we only use account objects.
-rw-r--r-- | README | 1 | ||||
-rw-r--r-- | doc/disfluid.texi | 248 | ||||
-rw-r--r-- | guix/vkraus/packages/disfluid.scm | 1 | ||||
-rw-r--r-- | po/POTFILES.in | 21 | ||||
-rw-r--r-- | po/disfluid.pot | 361 | ||||
-rw-r--r-- | po/fr.po | 453 | ||||
-rw-r--r-- | src/scm/webid-oidc/client.scm | 175 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 843 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/client.scm | 92 | ||||
-rw-r--r-- | src/scm/webid-oidc/example-app.scm | 523 | ||||
-rw-r--r-- | tests/client-workflow.scm | 53 |
12 files changed, 1773 insertions, 1004 deletions
@@ -33,6 +33,7 @@ These are the run-time dependencies: - guile-json - guile-rdf - guile-jsonld +- guile-readline - gnutls (so that guile can fetch resources with https) - nettle diff --git a/doc/disfluid.texi b/doc/disfluid.texi index 04e69af..cf413af 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -864,81 +864,160 @@ authorization. Otherwise, raise an exception of type @node Running a client @chapter Running a client -To run a client, you need to proceed in two steps. First, acquire an -OIDC ID token and an access token from the identity provider, and then -present the access token and a proof of possession of the linked key -in each request, in a DPoP HTTP header. - -The list of accounts is stored on the file system. You can manipulate -the accounts with the @emph{(webid-oidc client accounts)} module. - -@deftp {Record type} <account> @var{subject} @var{issuer} @var{id-token} @var{access-token} @var{refresh-token} @var{keypair} -Store information about an account. @var{subject} is optional, -@var{issuer} is required, but they must both be URIs. In a typical -application, you would ask the user for per @var{issuer}, without -bothering perse with a webid (it can be long to type), and then start -making requests with this account. When you need an authorization -code, you will know the user’s webid. - -If the access token was not invalidated, then @var{id-token} contains -a (decrypted) identity token, and @var{access-token} an encrypted -access token. If you got a @var{refresh-token} for this account, it is -also stored, along with the @var{keypair} that is server-side bound to -it. - -The optional parameters are @code{#f} when we don’t have them. +The job of the client is to use accounts to fetch private resources on +the web. The @emph{(webid-oidc client)} defines the @code{<client>} +class. + +@deftp {Class} <client> @var{client-id} @var{key-pair} @var{redirect-uri} +In OIDC, a client is an application that does not hold the +resources. It may in fact be a network server available on the web, or +a program that you run on your machine. Being a network server or not +is irrelevant. + +The @code{<client>} class is designed with immutability in mind. You +can create a client with the @code{make} generic method, using these +keywords to initialize values: + +@table @code +@item #:client-id +to set the public client identifier (this endpoint +should be available on the world-wide web), as a string representing +an URI or an URI from @code{(web uri)}; +@item #:key-pair +to use a specific key pair. If not set, a new key pair will be +generated; +@item #:redirect-uri +to set the redirect URI that the application controls. It may just be +a page showing the authorization code, with instructions on how to +paste this code into the application. It should match one of the +authorized redirect URIs in the client identifier endpoint. + +If you want to set a state parameter for the redirection, you can do +it by setting the guile parameter @code{authorization-state}. +@end table @end deftp -@deffn function make-account @var{subject} @var{issuer} @var{id-token} @var{access-token} @var{refresh-token} @var{keypair} -Create an account. -@end deffn +@deftypefn {Generic method} uri client-id (@var{client} @code{<client>}) +@deftypefnx {Generic method} {key pair} client-key-pair (@var{client} @code{<client>}) +@deftypefnx {Generic method} uri client-redirect-uri (@var{client} @code{<client>}) +Slot accessors for @var{client}. +@end deftypefn -@deffn function account? @var{object} -Check whether @var{object} is an account. -@end deffn +@defvr {Parameter} client +Define this parameter to set the client to use to access private data. +@end defvr -@deffn function account-subject @var{account} -@deffnx function account-issuer @var{account} -@deffnx function account-id-token @var{account} -@deffnx function account-access-token @var{account} -@deffnx function account-refresh-token @var{account} -@deffnx function account-keypair @var{account} -Access the account. -@end deffn +To access private data, you must identify yourself. The +@emph{(webid-oidc client accounts)} module lets you define accounts. + +@deftp {Class} <account> @var{subject} @var{issuer} @var{id-token} @var{access-token} @var{refresh-token} @var{key-pair} +Encapsulate an account. @var{subject} is your webid, while +@var{issuer} is a host name. @var{id-token} is the @emph{decoded} OIDC ID token, i.e. a +pair of @code{(header . payload)}, because we don’t need to show it to +any other party, so its authenticity needs not be +demonstrated. However, @var{access-token} is an @emph{encoded} access +token (into a string), because we don’t need to worry about its +internals on client side. + +There are different ways to initialize an account. First, you can save +all parameters to some form of storage, and restore it by using the +associated keyword arguments at construction time: + +@table @code +@item #:subject +@item #:issuer +@item #:id-token +@item #:access-token +@item #:refresh-token +@item #:key-pair +@end table -You should always manage the accounts with the users database. +If you want to make a new account, you would ask the user for an +identity provider, and pass it with @code{#:issuer} as the only +initialized value. The constructor will log you in, using the +@code{authorization-process} and @code{anonymous-http-request} +function parameters. -@deffn function read-accounts -Read the list of all accounts. This function is safe to call at any -time during concurrent updates of the database. If the update was -finished, the new list is returned, otherwise the old list is returned -without blocking. -@end deffn +If you want to refresh an access token, you would also set +@code{#:refresh-token}. -@deffn function save-account @var{account} -Find an account in the database with the same subject and issuer, and -replace its contents with @var{account}. Return @var{account}. -@end deffn +In any case, when you don’t specify a value, it’s as if you passed +@code{#f}. +@end deftp -@deffn function delete-account @var{account} -Remove all accounts from the database that have the same subject and -issuer as @var{account}. -@end deffn +@defvr {Parameter} authorization-process +This function is called when an explicit user authorization is +required, for instance because there is no refresh token and the +access token expired. The function takes an URI as argument, with an +additional @code{#:issuer} keyword argument containing the issuer. In +this function, you should ask the user to browse this URI so that your +application gets the authorization code. +@end defvr -To log a user in, you must know at least per issuer. More precisely, -if the user is already known (because, for instance, the user presents -a cookie for your web application), then you should know the user’s -webid and the webid issuer. If you don’t know the user, and the user -is eligible to your service, then you will only know the identity -provider (issuer), because that’s what the user typed in. +@defvr {Parameter} anonymous-http-request +This function is used as a back-end for private resource access, and +to query the server configuration. It defaults to @code{http-request} +from @emph{(web client)}. +@end defvr -@deffn function login @var{subject} @var{issuer} [#:@var{http-request}=@code{http-request}] [#:@var{state}=@code{#f}] #:@var{client-id} #:@var{client-key} #:@var{redirect-uri} -Return a new account with an ID token and an access -token. @var{subject} is optional. +@deftypefn {Generic method} uri subject (@var{account} @code{<account>}) +@deftypefnx {Generic method} <account> set-subject (@var{account} @code{<account>}) (@var{uri} {string or URI}) +@deftypefnx {Generic method} uri issuer (@var{account} @code{<account>}) +@deftypefnx {Generic method} <account> set-issuer (@var{account} @code{<account>}) (@var{uri} {string or URI}) +@deftypefnx {Generic method} {optional decoded ID token} id-token (@var{account} @code{<account>}) +@deftypefnx {Generic method} <account> set-id-token (@var{account} @code{<account>}) (@var{id-token} {optional ID token}) +@deftypefnx {Generic method} {optional encoded access token} access-token (@var{account} @code{<account>}) +@deftypefnx {Generic method} <account> set-access-token (@var{account} @code{<account>}) (@var{access-token} {optional access token}) +@deftypefnx {Generic method} {optional <string>} refresh-token (@var{account} @code{<account>}) +@deftypefnx {Generic method} <account> set-refresh-token (@var{account} @code{<account>}) (@var{refresh-token} {optional <string>}) +@deftypefnx {Generic method} {key pair} key-pair (@var{account} @code{<account>}) +@deftypefnx {Generic method} <account> set-key-pair (@var{account} @code{<account>}) (@var{key-pair} {optional key pair}) +Slot accessors and functional setters for @var{account}. +@end deftypefn + +If you intend to run a public network server as a client application, +you may have multiple different users, but you should not let any user +use any account. If this is the case, you can either store the +accounts on the user agent storage (for instance, as a cookie), or +store all of them on the server. If you choose to store the accounts +on the user agent, at least use a new key pair for each of them. If +you want to store the user database on the server side, be aware that +no entity other than yourself will check that your user abides by any +term of service, so it is possible that a single user makes a lot of +accounts to annoy you and fill your hard drive with key pairs. If your +application does not let random people to use it, you might want to +use @emph{protected accounts}, to help you check that the users cannot +impersonate each other. + +@deftp {Class} <protected-account> (@code{<account>}) @var{username} @var{encrypted-password} +This superclass of @code{<account>} is protected by a username and +password. It is constructed with the initializer keywords +@code{#:username} and @code{#:encrypted-password}. +@end deftp -When you receive an account record from this function, make sure to -save it to the accounts database with @code{save-account}. -@end deffn +@deftypefn {Generic method} <string> username (@var{protected-account} @code{<protected-account>}) +@deftypefnx {Generic method} <protected-account> set-username (@var{protected-account} @code{<protected-account>}) (@var{username} <string>) +@deftypefnx {Generic method} <string> encrypted-password (@var{protected-account} @code{<protected-account>}) +@deftypefnx {Generic method} <protected-account> set-encrypted-password (@var{protected-account} @code{<protected-account>}) (@var{encrypted-password} <string>) +Slot accessors and functional setters for @var{protected-account}. +@end deftypefn + +@deftypefn {Generic method} <account> invalidate-access-token (@var{account} @code{<account>}) +Indicate that the access token in @var{account} cannot be used. Before +using @var{account} again, you will need to refresh the access +token. This function does not mutate @var{account}. +@end deftypefn + +@deftypefn {Generic method} <account> invalidate-refresh-token (@var{account} @code{<account>}) +Indicate that the refresh token has been revoked for +@var{account}. This is usually an indication that the user don’t want +your application to access her private data. This function does not +mutate @var{account}. +@end deftypefn + +@deftypefn {Generic method} <account> refresh (@var{account} @code{<account>}) +Refresh the access token. +@end deftypefn @deftp {Exception type} &authorization-code-required @var{uri} If the login process requires the user to send an authorization code, @@ -1007,40 +1086,19 @@ Constructor, predicate, and accessors for the @code{&token-request-failed} exception type. @end deffn -The @emph{(webid-oidc client)} module provides support for complete -clients. - -@deftp {Record type} <client> @var{id} @var{key} @var{redirect-uri} -The @var{id} of a client is an URI without fragment that can be -dereferenced in the world-wide web to metadata about the client. It -should allow @var{redirect-uri} to access the authorization code. +The @emph{(webid-oidc client)} module provides the most useful +function for a client. -It is useful if an application rotates its @var{key}. So, while a key -will still be used as long as the associated refresh token for a given -user is valid, you can equip new users with a new key pair. -@end deftp - -@deffn function make-client @var{id} @var{key} @var{redirect-uri} -@deffnx function client? @var{object} -@deffnx client-id @var{object} -@deffnx client-key @var{object} -@deffnx client-redirect-uri @var{object} -Constructor, predicate and accessors for the @code{<client>} record -type. +@deffn function request @var{account} @var{uri} . @var{args} +Perform a request on behalf of @var{account}, with the current value +of the @var{client} parameter as the client, using as a backend the +current value of @var{anonymous-http-request}. @end deffn -@deffn function initial-login @var{client} @var{issuer} [#:@var{http-request}] -Create an account by logging in with just the @var{issuer}, and save -the created account. The default @var{http-request} uses the cache for -GET requests. -@end deffn - -@deffn function request @var{client} @var{subject} @var{issuer} [#:@var{http-request}] -Log in with @var{subject} (optional, may be @code{#f}) and -@var{issuer}, and return a function that takes a request and request -body and transfers it, signed, to the @var{http-request} back-end. By -default, it uses the cache for GET requests. -@end deffn +Finally, to implement your application, there needs to be a public +endpoint for the resource server to check that you are not +impersonating another application. This endpoint can be served by any +web server, but a convenience procedure is made available here: @deffn function serve-application @var{id} @var{redirect-uri} @var{[#client-name]} @var{[#client-uri]} Return a handler for web requests to serve the application manifest diff --git a/guix/vkraus/packages/disfluid.scm b/guix/vkraus/packages/disfluid.scm index f372315..07282e3 100644 --- a/guix/vkraus/packages/disfluid.scm +++ b/guix/vkraus/packages/disfluid.scm @@ -108,6 +108,7 @@ ("guile-json" ,guile-json-4) ("guile-rdf" ,guile-rdf) ("guile-jsonld" ,guile-jsonld) + ("guile-readline" ,guile-readline) ("texinfo" ,texinfo) ("autoconf" ,autoconf) ("autoconf-archive" ,autoconf-archive) diff --git a/po/POTFILES.in b/po/POTFILES.in index d19a46f..e485ef5 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -15,24 +15,26 @@ # along with this program. If not, see <https://www.gnu.org/licenses/>. # List of source files which contain translatable strings. +src/hash/libwebidoidc-hash.c +src/jwk/generate-key.c +src/jwk/libwebidoidc-jwk.c src/libwebidoidc.c -src/random/random.c -src/random/libwebidoidc-random.c src/random/generate-random.c -src/jwk/libwebidoidc-jwk.c -src/jwk/generate-key.c -src/hash/libwebidoidc-hash.c +src/random/libwebidoidc-random.c +src/random/random.c +src/scm/webid-oidc/ChangeLog +src/scm/webid-oidc/Makefile.am src/scm/webid-oidc/access-token.scm src/scm/webid-oidc/authorization-code.scm src/scm/webid-oidc/authorization-endpoint.scm -src/scm/webid-oidc/authorization-page.scm src/scm/webid-oidc/authorization-page-unsafe.scm +src/scm/webid-oidc/authorization-page.scm src/scm/webid-oidc/cache.scm src/scm/webid-oidc/catalog.scm -src/scm/webid-oidc/ChangeLog -src/scm/webid-oidc/client/accounts.scm src/scm/webid-oidc/client-manifest.scm src/scm/webid-oidc/client.scm +src/scm/webid-oidc/client/accounts.scm +src/scm/webid-oidc/client/client.scm src/scm/webid-oidc/dpop-proof.scm src/scm/webid-oidc/errors.scm src/scm/webid-oidc/example-app.scm @@ -43,7 +45,6 @@ src/scm/webid-oidc/identity-provider.scm src/scm/webid-oidc/jti.scm src/scm/webid-oidc/jwk.scm src/scm/webid-oidc/jws.scm -src/scm/webid-oidc/Makefile.am src/scm/webid-oidc/offloading.scm src/scm/webid-oidc/oidc-configuration.scm src/scm/webid-oidc/oidc-id-token.scm @@ -54,13 +55,13 @@ src/scm/webid-oidc/rdf-index.scm src/scm/webid-oidc/refresh-token.scm src/scm/webid-oidc/resource-server.scm src/scm/webid-oidc/reverse-proxy.scm +src/scm/webid-oidc/serve.scm src/scm/webid-oidc/server/create.scm src/scm/webid-oidc/server/delete.scm src/scm/webid-oidc/server/log.scm src/scm/webid-oidc/server/precondition.scm src/scm/webid-oidc/server/read.scm src/scm/webid-oidc/server/update.scm -src/scm/webid-oidc/serve.scm src/scm/webid-oidc/simulation.scm src/scm/webid-oidc/stubs.scm src/scm/webid-oidc/testing.scm diff --git a/po/disfluid.pot b/po/disfluid.pot index 700afde..00ee614 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-09-13 20:29+0200\n" +"POT-Creation-Date: 2021-09-14 16:04+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <LL@li.org>\n" @@ -17,10 +17,20 @@ msgstr "" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" +#: src/jwk/generate-key.c:52 +#, c-format +msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" +msgstr "" + #: src/libwebidoidc.c:29 msgid "This is the main function." msgstr "" +#: src/random/generate-random.c:47 +#, c-format +msgid "Usage: generate-random [NUMBER OF BYTES]\n" +msgstr "" + #: src/random/random.c:217 #, c-format msgid "Could not set the global random generator up.\n" @@ -112,16 +122,6 @@ msgid "" "webid_oidc_random_init first.\n" msgstr "" -#: src/random/generate-random.c:47 -#, c-format -msgid "Usage: generate-random [NUMBER OF BYTES]\n" -msgstr "" - -#: src/jwk/generate-key.c:52 -#, c-format -msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" -msgstr "" - #: src/scm/webid-oidc/access-token.scm:72 #, scheme-format msgid "this is not an access token, because it is not even a JWS: ~a" @@ -407,61 +407,6 @@ msgstr "" msgid "Unsupported delegate catalog URI scheme: ~s\n" msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:410 -msgid "The refresh token has expired." -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:417 -#, scheme-format -msgid "The token request failed with code ~s (~s)." -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:426 -msgid "The token response did not set the content type." -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:434 -msgid "The token endpoint did not respond in UTF-8." -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:446 -#, scheme-format -msgid "The token response has content-type ~s, not application/json." -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:456 -msgid "The token response is not valid JSON." -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:469 -#, scheme-format -msgid "The token response did not include an ID token: ~s" -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:477 -#, scheme-format -msgid "The token response did not include an access token: ~s\n" -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:488 -#, scheme-format -msgid "the ID token signature is invalid: ~a" -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:490 -msgid "the ID token signature is invalid" -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:508 -#, scheme-format -msgid "the ID token delivered by the identity provider for ~s has ~s as webid" -msgstr "" - -#: src/scm/webid-oidc/client/accounts.scm:517 -#, scheme-format -msgid "The ID token delivered by the identity provider ~s is for issuer ~s." -msgstr "" - #: src/scm/webid-oidc/client-manifest.scm:111 #, scheme-format msgid "this is not a client manifest: ~a" @@ -532,6 +477,87 @@ msgstr "" msgid "the client manifest is dereferenced from ~s, but it pretends to be ~s" msgstr "" +#: src/scm/webid-oidc/client/accounts.scm:254 +msgid "The refresh token has expired." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:261 +#, scheme-format +msgid "The token request failed with code ~s (~s)." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:270 +msgid "The token response did not set the content type." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:278 +msgid "The token endpoint did not respond in UTF-8." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:290 +#, scheme-format +msgid "The token response has content-type ~s, not application/json." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:300 +msgid "The token response is not valid JSON." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:314 +#, scheme-format +msgid "The token response did not include an ID token: ~s" +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:322 +#, scheme-format +msgid "The token response did not include an access token: ~s\n" +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:333 +#, scheme-format +msgid "the ID token signature is invalid: ~a" +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:335 +msgid "the ID token signature is invalid" +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:353 +#, scheme-format +msgid "the ID token delivered by the identity provider for ~s has ~s as webid" +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:363 +#, scheme-format +msgid "The ID token delivered by the identity provider ~s is for issuer ~s." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:378 +msgid "The issuer is required." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:383 +msgid "The optional subject and required issuer should be strings or URI." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:398 +msgid "Cannot check the username and/or password." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:408 +msgid "The subject should be a string or URI." +msgstr "" + +#: src/scm/webid-oidc/client/accounts.scm:422 +msgid "The issuer should be a string or URI." +msgstr "" + +#: src/scm/webid-oidc/client/client.scm:87 +msgid "" +"Client ID and redirect URIs should be URIs, and key pair should be a key " +"pair.." +msgstr "" + #: src/scm/webid-oidc/dpop-proof.scm:91 #, scheme-format msgid "this is not a DPoP proof, because it is not even a JWS: ~a" @@ -644,63 +670,202 @@ msgstr "" msgid "cannot encode a DPoP proof" msgstr "" -#: src/scm/webid-oidc/example-app.scm:58 -msgid "Main menu:\n" +#: src/scm/webid-oidc/example-app.scm:98 +#, scheme-format +msgid "~a (issued by ~a): no interaction required" msgstr "" -#: src/scm/webid-oidc/example-app.scm:61 +#: src/scm/webid-oidc/example-app.scm:101 #, scheme-format -msgid "~a. Log in with ~a (issued by ~a): ~a\n" +msgid "~a (issued by ~a): offline but accessible" msgstr "" -#: src/scm/webid-oidc/example-app.scm:66 -msgid "a new user" +#: src/scm/webid-oidc/example-app.scm:104 +#, scheme-format +msgid "~a (issued by ~a): online" msgstr "" -#: src/scm/webid-oidc/example-app.scm:69 -msgid "status|currently logged in" +#: src/scm/webid-oidc/example-app.scm:107 +#, scheme-format +msgid "~a (issued by ~a): inaccessible" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:120 +#, scheme-format +msgid "Your choice ~a does not exist.\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:71 -msgid "status|offline (but accessible)" +#: src/scm/webid-oidc/example-app.scm:138 +msgid "Your choice is not a valid URI.\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:72 -msgid "status|offline (inaccessible)" +#: src/scm/webid-oidc/example-app.scm:147 +msgid "This is not a valid HTTP method.\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:74 -msgid "" -"Type a number to log in, prefix it with '-' to delete the account, or type + " -"to create a new account.\n" +#: src/scm/webid-oidc/example-app.scm:163 +msgid "This is not a valid value for this header.\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:83 +#: src/scm/webid-oidc/example-app.scm:201 +msgid "Nothing to undo.\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:213 +msgid "Nothing to redo.\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:273 +msgid "Example app command|add-account" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:275 +msgid "Example app command|choose-account" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:277 +msgid "Example app command|set-uri" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:279 +msgid "Example app command|set-method" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:281 +msgid "Example app command|view-headers" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:283 +msgid "Example app command|clear-headers" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:285 +msgid "Example app command|add-header" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:287 +msgid "Example app command|ok" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:289 +msgid "Example app command|undo" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:291 +msgid "Example app command|redo" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:301 #, scheme-format -msgid "Please visit: ~a\n" +msgid "To log in on ~a, please visit: ~a\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:84 +#: src/scm/webid-oidc/example-app.scm:304 msgid "Then, paste the authorization code you get:\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:98 +#: src/scm/webid-oidc/example-app.scm:322 #, scheme-format -msgid "I could not negociate an access token. ~a" +msgid "" +"Account: ~a\n" +"URI: ~a\n" +"Method: ~a\n" +"Headers: ~a\n" +"\n" +"Available commands:\n" +" - ~a: add an account\n" +" - ~a: change the account\n" +" - ~a: change the URI\n" +" - ~a: change the method\n" +" - ~a: view all headers\n" +" - ~a: clear all the headers\n" +" - ~a: add a new header\n" +" - ~a: perform the request.\n" +"\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:341 +msgid "Account:|unset" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:345 +msgid "URI:|unset" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:349 +msgid "Method:|unset" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:352 +msgid "Headers:|none" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:356 +msgid "list separator|, " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:366 +#, scheme-format +msgid "You can undo your last command with \"~a\".\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:368 +#, scheme-format +msgid "You can re-apply your last undone command with \"~a\".\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:369 +msgid "Readline prompt|Command: " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:376 +#, scheme-format +msgid "An error happened: ~a.\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:388 +msgid "Please enter your identity provider: " msgstr "" -#: src/scm/webid-oidc/example-app.scm:102 +#: src/scm/webid-oidc/example-app.scm:394 msgid "" -"The refresh token has expired, it is not possible to use that account " -"offline.\n" +"You don’t have other accounts available. Please add one with \"add-account" +"\".\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:107 -msgid "Please enter an URI to GET:\n" +#: src/scm/webid-oidc/example-app.scm:400 +#, scheme-format +msgid "- ~a: ~a\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:132 -msgid "Please type your identity provider:\n" +#: src/scm/webid-oidc/example-app.scm:408 +#, scheme-format +msgid "[1-~a] " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:416 +msgid "Visit this URI: " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:422 +msgid "Use this HTTP method [GET]: " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:438 +msgid "Which header? " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:441 +#, scheme-format +msgid "Which header value for ~a? " +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:464 +msgid "Please define an account and the URI.\n" +msgstr "" + +#: src/scm/webid-oidc/example-app.scm:471 +msgid "I don’t know that command.\n" msgstr "" #: src/scm/webid-oidc/fetch.scm:59 @@ -1917,6 +2082,10 @@ msgstr "" msgid "#:endpoint argument is not present or not an URI." msgstr "" +#: src/scm/webid-oidc/serve.scm:76 +msgid "content negociation failed while serving a request" +msgstr "" + #: src/scm/webid-oidc/server/create.scm:85 #, scheme-format msgid "only text/turtle is allowed for the target of a POST request, not ~s" @@ -1936,10 +2105,6 @@ msgstr "" msgid "the auxiliary resource of type ~s at ~s is absent" msgstr "" -#: src/scm/webid-oidc/serve.scm:76 -msgid "content negociation failed while serving a request" -msgstr "" - #: src/scm/webid-oidc/simulation.scm:130 #, scheme-format msgid "invalid credentials: response ~s ~s" @@ -2,8 +2,8 @@ msgid "" msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-09-13 20:29+0200\n" -"PO-Revision-Date: 2021-09-13 19:59+0200\n" +"POT-Creation-Date: 2021-09-14 16:04+0200\n" +"PO-Revision-Date: 2021-09-14 16:02+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" "Language: fr\n" @@ -12,10 +12,20 @@ msgstr "" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" +#: src/jwk/generate-key.c:52 +#, c-format +msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" +msgstr "Utilisation : generate-key [NOMBRE DE BITS | COURBE]\n" + #: src/libwebidoidc.c:29 msgid "This is the main function." msgstr "Ceci est la fonction principale." +#: src/random/generate-random.c:47 +#, c-format +msgid "Usage: generate-random [NUMBER OF BYTES]\n" +msgstr "Utilisation : generate-random [NOMBRE D'OCTETS]\n" + #: src/random/random.c:217 #, c-format msgid "Could not set the global random generator up.\n" @@ -116,16 +126,6 @@ msgstr "" "Le module aléatoire n'a pas été initialisé. Veuillez appeler " "webid_oidc_random_init d'abort.\n" -#: src/random/generate-random.c:47 -#, c-format -msgid "Usage: generate-random [NUMBER OF BYTES]\n" -msgstr "Utilisation : generate-random [NOMBRE D'OCTETS]\n" - -#: src/jwk/generate-key.c:52 -#, c-format -msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" -msgstr "Utilisation : generate-key [NOMBRE DE BITS | COURBE]\n" - #: src/scm/webid-oidc/access-token.scm:72 #, scheme-format msgid "this is not an access token, because it is not even a JWS: ~a" @@ -421,64 +421,6 @@ msgstr "URI relative invalide" msgid "Unsupported delegate catalog URI scheme: ~s\n" msgstr "Schéma d’URI pour un catalogue délégé non supporté : ~s\n" -#: src/scm/webid-oidc/client/accounts.scm:410 -msgid "The refresh token has expired." -msgstr "le jeton de rafraîchissement a expiré." - -#: src/scm/webid-oidc/client/accounts.scm:417 -#, scheme-format -msgid "The token request failed with code ~s (~s)." -msgstr "La requête de jeton a échoué avec un code ~s (~s)." - -#: src/scm/webid-oidc/client/accounts.scm:426 -msgid "The token response did not set the content type." -msgstr "Le jeton de réponse n’a pas défini de type de contenu." - -#: src/scm/webid-oidc/client/accounts.scm:434 -msgid "The token endpoint did not respond in UTF-8." -msgstr "Le terminal de jetonn n’a pas répondu en UTF-8." - -#: src/scm/webid-oidc/client/accounts.scm:446 -#, scheme-format -msgid "The token response has content-type ~s, not application/json." -msgstr "La réponse de jeton a un type de contenu ~s, pas application/json." - -#: src/scm/webid-oidc/client/accounts.scm:456 -msgid "The token response is not valid JSON." -msgstr "La réponse de jeton n’est pas un JSON valide." - -#: src/scm/webid-oidc/client/accounts.scm:469 -#, scheme-format -msgid "The token response did not include an ID token: ~s" -msgstr "La réponse de jeton n’a pas inclus de jeton d’ID : ~s" - -#: src/scm/webid-oidc/client/accounts.scm:477 -#, scheme-format -msgid "The token response did not include an access token: ~s\n" -msgstr "La réponse de jeton n’a pas inclus de jeton d’accès : ~s\n" - -#: src/scm/webid-oidc/client/accounts.scm:488 -#, scheme-format -msgid "the ID token signature is invalid: ~a" -msgstr "la signature du jeton d’ID est invalide : ~a" - -#: src/scm/webid-oidc/client/accounts.scm:490 -msgid "the ID token signature is invalid" -msgstr "la signature du jeton d’ID est invalide" - -#: src/scm/webid-oidc/client/accounts.scm:508 -#, scheme-format -msgid "the ID token delivered by the identity provider for ~s has ~s as webid" -msgstr "" -"le jeton d’ID délivré par le fournisseur d’identité pour ~s a ~s pour webid" - -#: src/scm/webid-oidc/client/accounts.scm:517 -#, scheme-format -msgid "The ID token delivered by the identity provider ~s is for issuer ~s." -msgstr "" -"Le jeton d’ID délivré par le fournisseur d’identité ~s est pour l’émetteur " -"~s." - #: src/scm/webid-oidc/client-manifest.scm:111 #, scheme-format msgid "this is not a client manifest: ~a" @@ -555,6 +497,94 @@ msgstr "impossible de télécharger le manifeste client ~s" msgid "the client manifest is dereferenced from ~s, but it pretends to be ~s" msgstr "le manifeste client est déréférencé depuis ~s, mais il prétend être ~s" +#: src/scm/webid-oidc/client/accounts.scm:254 +msgid "The refresh token has expired." +msgstr "le jeton de rafraîchissement a expiré." + +#: src/scm/webid-oidc/client/accounts.scm:261 +#, scheme-format +msgid "The token request failed with code ~s (~s)." +msgstr "La requête de jeton a échoué avec un code ~s (~s)." + +#: src/scm/webid-oidc/client/accounts.scm:270 +msgid "The token response did not set the content type." +msgstr "Le jeton de réponse n’a pas défini de type de contenu." + +#: src/scm/webid-oidc/client/accounts.scm:278 +msgid "The token endpoint did not respond in UTF-8." +msgstr "Le terminal de jetonn n’a pas répondu en UTF-8." + +#: src/scm/webid-oidc/client/accounts.scm:290 +#, scheme-format +msgid "The token response has content-type ~s, not application/json." +msgstr "La réponse de jeton a un type de contenu ~s, pas application/json." + +#: src/scm/webid-oidc/client/accounts.scm:300 +msgid "The token response is not valid JSON." +msgstr "La réponse de jeton n’est pas un JSON valide." + +#: src/scm/webid-oidc/client/accounts.scm:314 +#, scheme-format +msgid "The token response did not include an ID token: ~s" +msgstr "La réponse de jeton n’a pas inclus de jeton d’ID : ~s" + +#: src/scm/webid-oidc/client/accounts.scm:322 +#, scheme-format +msgid "The token response did not include an access token: ~s\n" +msgstr "La réponse de jeton n’a pas inclus de jeton d’accès : ~s\n" + +#: src/scm/webid-oidc/client/accounts.scm:333 +#, scheme-format +msgid "the ID token signature is invalid: ~a" +msgstr "la signature du jeton d’ID est invalide : ~a" + +#: src/scm/webid-oidc/client/accounts.scm:335 +msgid "the ID token signature is invalid" +msgstr "la signature du jeton d’ID est invalide" + +#: src/scm/webid-oidc/client/accounts.scm:353 +#, scheme-format +msgid "the ID token delivered by the identity provider for ~s has ~s as webid" +msgstr "" +"le jeton d’ID délivré par le fournisseur d’identité pour ~s a ~s pour webid" + +#: src/scm/webid-oidc/client/accounts.scm:363 +#, scheme-format +msgid "The ID token delivered by the identity provider ~s is for issuer ~s." +msgstr "" +"Le jeton d’ID délivré par le fournisseur d’identité ~s est pour l’émetteur " +"~s." + +#: src/scm/webid-oidc/client/accounts.scm:378 +msgid "The issuer is required." +msgstr "L’émetteur est requis." + +#: src/scm/webid-oidc/client/accounts.scm:383 +msgid "The optional subject and required issuer should be strings or URI." +msgstr "" +"Le sujet optionnel et émetteur doivent être des chaînes de caractère ou des " +"URIs." + +#: src/scm/webid-oidc/client/accounts.scm:398 +msgid "Cannot check the username and/or password." +msgstr "Impossible de vérifier le nom d’utilisateur et/ou le mot de passe." + +#: src/scm/webid-oidc/client/accounts.scm:408 +msgid "The subject should be a string or URI." +msgstr "Le sujet doit être une chaîne de caractères ou une URI." + +#: src/scm/webid-oidc/client/accounts.scm:422 +msgid "The issuer should be a string or URI." +msgstr "L’émetteur doit être une chaîne de caractères ou une URI." + +#: src/scm/webid-oidc/client/client.scm:87 +msgid "" +"Client ID and redirect URIs should be URIs, and key pair should be a key " +"pair.." +msgstr "" +"L’ID de client et l’URI de redirection doivent être des URIs, et la paire de " +"clés doit être une paire de clés." + #: src/scm/webid-oidc/dpop-proof.scm:91 #, scheme-format msgid "this is not a DPoP proof, because it is not even a JWS: ~a" @@ -675,68 +705,220 @@ msgstr "impossible d’encoder la preuve DPoP : ~a" msgid "cannot encode a DPoP proof" msgstr "impossible d’encoder la preuve DPoP" -#: src/scm/webid-oidc/example-app.scm:58 -msgid "Main menu:\n" -msgstr "Menu principal :\n" +#: src/scm/webid-oidc/example-app.scm:98 +#, scheme-format +msgid "~a (issued by ~a): no interaction required" +msgstr "~a (émis par ~a) : aucune interaction nécessaire" -#: src/scm/webid-oidc/example-app.scm:61 +#: src/scm/webid-oidc/example-app.scm:101 #, scheme-format -msgid "~a. Log in with ~a (issued by ~a): ~a\n" -msgstr "~a. Se connecter avec ~a (émis par ~a) : ~a\n" +msgid "~a (issued by ~a): offline but accessible" +msgstr "~a (émis par ~a) : hors ligne mais accessible" -#: src/scm/webid-oidc/example-app.scm:66 -msgid "a new user" -msgstr "un nouvel utilisateur" +#: src/scm/webid-oidc/example-app.scm:104 +#, scheme-format +msgid "~a (issued by ~a): online" +msgstr "~a (émis par ~a) : en ligne" -#: src/scm/webid-oidc/example-app.scm:69 -msgid "status|currently logged in" -msgstr "actuellement connecté" +#: src/scm/webid-oidc/example-app.scm:107 +#, scheme-format +msgid "~a (issued by ~a): inaccessible" +msgstr "~a (émis par ~a) : inaccessible" -#: src/scm/webid-oidc/example-app.scm:71 -msgid "status|offline (but accessible)" -msgstr "hors ligne (mais accessible)" +#: src/scm/webid-oidc/example-app.scm:120 +#, scheme-format +msgid "Your choice ~a does not exist.\n" +msgstr "Votre choix, ~a, n’existe pas.\n" -#: src/scm/webid-oidc/example-app.scm:72 -msgid "status|offline (inaccessible)" -msgstr "hors ligne (inaccessible)" +#: src/scm/webid-oidc/example-app.scm:138 +msgid "Your choice is not a valid URI.\n" +msgstr "Votre choix doit être une URI valide.\n" -#: src/scm/webid-oidc/example-app.scm:74 -msgid "" -"Type a number to log in, prefix it with '-' to delete the account, or type + " -"to create a new account.\n" -msgstr "" -"Entrez un nombre pour vous connecter, préfixez-le avec « - » pour supprimer " -"le compte, ou tapez + pour créer un nouveau compte.\n" +#: src/scm/webid-oidc/example-app.scm:147 +msgid "This is not a valid HTTP method.\n" +msgstr "ce n’est pas une méthode HTTP valide.\n" + +#: src/scm/webid-oidc/example-app.scm:163 +msgid "This is not a valid value for this header.\n" +msgstr "Ce n’est pas une valeur valide pour cet en-tête.\n" + +#: src/scm/webid-oidc/example-app.scm:201 +msgid "Nothing to undo.\n" +msgstr "Rien à annuler.\n" + +#: src/scm/webid-oidc/example-app.scm:213 +msgid "Nothing to redo.\n" +msgstr "Rien à refaire.\n" + +#: src/scm/webid-oidc/example-app.scm:273 +msgid "Example app command|add-account" +msgstr "ajouter-compte" + +#: src/scm/webid-oidc/example-app.scm:275 +msgid "Example app command|choose-account" +msgstr "choisir-compte" + +#: src/scm/webid-oidc/example-app.scm:277 +msgid "Example app command|set-uri" +msgstr "définir-uri" -#: src/scm/webid-oidc/example-app.scm:83 +#: src/scm/webid-oidc/example-app.scm:279 +msgid "Example app command|set-method" +msgstr "définir-méthode" + +#: src/scm/webid-oidc/example-app.scm:281 +msgid "Example app command|view-headers" +msgstr "voir-en-têtes" + +#: src/scm/webid-oidc/example-app.scm:283 +msgid "Example app command|clear-headers" +msgstr "effacer-en-têtes" + +#: src/scm/webid-oidc/example-app.scm:285 +msgid "Example app command|add-header" +msgstr "ajouter-en-tête" + +#: src/scm/webid-oidc/example-app.scm:287 +msgid "Example app command|ok" +msgstr "ok" + +#: src/scm/webid-oidc/example-app.scm:289 +msgid "Example app command|undo" +msgstr "annuler" + +#: src/scm/webid-oidc/example-app.scm:291 +msgid "Example app command|redo" +msgstr "refaire" + +#: src/scm/webid-oidc/example-app.scm:301 #, scheme-format -msgid "Please visit: ~a\n" -msgstr "Veuillez visiter : ~a\n" +msgid "To log in on ~a, please visit: ~a\n" +msgstr "Pour vous connecte avec ~a, veuillez visiter : ~a\n" -#: src/scm/webid-oidc/example-app.scm:84 +#: src/scm/webid-oidc/example-app.scm:304 msgid "Then, paste the authorization code you get:\n" msgstr "Ensuite, veuillez coller votre code d’autorisation :\n" -#: src/scm/webid-oidc/example-app.scm:98 +#: src/scm/webid-oidc/example-app.scm:322 #, scheme-format -msgid "I could not negociate an access token. ~a" -msgstr "Je n’ai pas pu négocier de jeton d’accès. ~a" +msgid "" +"Account: ~a\n" +"URI: ~a\n" +"Method: ~a\n" +"Headers: ~a\n" +"\n" +"Available commands:\n" +" - ~a: add an account\n" +" - ~a: change the account\n" +" - ~a: change the URI\n" +" - ~a: change the method\n" +" - ~a: view all headers\n" +" - ~a: clear all the headers\n" +" - ~a: add a new header\n" +" - ~a: perform the request.\n" +"\n" +msgstr "" +"Compte : ~a\n" +"URI : ~a\n" +"Méthode : ~a\n" +"En-têtes : ~a\n" +"\n" +"Commandes disponibles :\n" +" - ~a : ajouter un compte\n" +" - ~a : changer de compte\n" +" - ~a : changer d’URI\n" +" - ~a : changer la méthode\n" +" - ~a : voir tous les en-têtes\n" +" - ~a : effacer tous les en-têtes\n" +" - ~a : ajouter des en-têtes\n" +" - ~a : effectuer la requête.\n" +"\n" + +#: src/scm/webid-oidc/example-app.scm:341 +msgid "Account:|unset" +msgstr "non défini" + +#: src/scm/webid-oidc/example-app.scm:345 +msgid "URI:|unset" +msgstr "non défini" + +#: src/scm/webid-oidc/example-app.scm:349 +msgid "Method:|unset" +msgstr "non définie" + +#: src/scm/webid-oidc/example-app.scm:352 +msgid "Headers:|none" +msgstr "aucun" + +#: src/scm/webid-oidc/example-app.scm:356 +msgid "list separator|, " +msgstr ", " + +#: src/scm/webid-oidc/example-app.scm:366 +#, scheme-format +msgid "You can undo your last command with \"~a\".\n" +msgstr "Vous pouvez annuler votre dernière commande avec « ~a ».\n" + +#: src/scm/webid-oidc/example-app.scm:368 +#, scheme-format +msgid "You can re-apply your last undone command with \"~a\".\n" +msgstr "Vous pouvez refaire votre dernière commande annulée avec « ~a ».\n" + +#: src/scm/webid-oidc/example-app.scm:369 +msgid "Readline prompt|Command: " +msgstr "Commande : " -#: src/scm/webid-oidc/example-app.scm:102 +#: src/scm/webid-oidc/example-app.scm:376 +#, scheme-format +msgid "An error happened: ~a.\n" +msgstr "Une erreur est survenue : ~a.\n" + +#: src/scm/webid-oidc/example-app.scm:388 +msgid "Please enter your identity provider: " +msgstr "Veuillez entrer votre fournisseur d’identité : " + +#: src/scm/webid-oidc/example-app.scm:394 msgid "" -"The refresh token has expired, it is not possible to use that account " -"offline.\n" +"You don’t have other accounts available. Please add one with \"add-account" +"\".\n" msgstr "" -"Le jeton de rafraîchissement a expiré, il n’est pas possible d’utiliser ce " -"compte hors ligne.\n" +"Vous n’avez pas d’autre compte disponible. Veuillez en ajouter un avec " +"« ajouter-compte ».\n" -#: src/scm/webid-oidc/example-app.scm:107 -msgid "Please enter an URI to GET:\n" -msgstr "Veuillez entrer un URI à requêter avec GET :\n" +#: src/scm/webid-oidc/example-app.scm:400 +#, scheme-format +msgid "- ~a: ~a\n" +msgstr "- ~a : ~a\n" + +#: src/scm/webid-oidc/example-app.scm:408 +#, scheme-format +msgid "[1-~a] " +msgstr "[1-~a] " + +#: src/scm/webid-oidc/example-app.scm:416 +msgid "Visit this URI: " +msgstr "Naviguer cette URI : " + +#: src/scm/webid-oidc/example-app.scm:422 +msgid "Use this HTTP method [GET]: " +msgstr "Utiliser cette méthode HTTP [GET] : " + +#: src/scm/webid-oidc/example-app.scm:438 +msgid "Which header? " +msgstr "Quel en-tête ? " + +#: src/scm/webid-oidc/example-app.scm:441 +#, scheme-format +msgid "Which header value for ~a? " +msgstr "Quelle valeur pour l’en-tête ~a ? " -#: src/scm/webid-oidc/example-app.scm:132 -msgid "Please type your identity provider:\n" -msgstr "Veuillez entrer votre serveur d’identité :\n" +#: src/scm/webid-oidc/example-app.scm:464 +msgid "Please define an account and the URI.\n" +msgstr "Veuillez définir un compte et une URI.\n" + +#: src/scm/webid-oidc/example-app.scm:471 +msgid "I don’t know that command.\n" +msgstr "Je ne connais pas cette commande.\n" #: src/scm/webid-oidc/fetch.scm:59 #, scheme-format @@ -2231,6 +2413,10 @@ msgstr "Inacceptable" msgid "#:endpoint argument is not present or not an URI." msgstr "l’argument de #:endpoint n’est pas présent, ou pas une URI." +#: src/scm/webid-oidc/serve.scm:76 +msgid "content negociation failed while serving a request" +msgstr "la négociation de contenu a échoué pour le service d’une requête" + #: src/scm/webid-oidc/server/create.scm:85 #, scheme-format msgid "only text/turtle is allowed for the target of a POST request, not ~s" @@ -2250,10 +2436,6 @@ msgstr "impossible de POSTer vers un chemin de ressource auxiliaire, ~s" msgid "the auxiliary resource of type ~s at ~s is absent" msgstr "la ressource auxiliaire de type ~s à ~s est absente" -#: src/scm/webid-oidc/serve.scm:76 -msgid "content negociation failed while serving a request" -msgstr "la négociation de contenu a échoué pour le service d’une requête" - #: src/scm/webid-oidc/simulation.scm:130 #, scheme-format msgid "invalid credentials: response ~s ~s" @@ -2355,6 +2537,43 @@ msgstr "" "<p>Vous voulez utiliser <pre>~s</pre> comme type d’offre, mais ce n’est pas " "supporté.</p>" +#, scheme-format +#~ msgid "~s (issued by ~s)" +#~ msgstr "~s (émis par ~s)" + +#~ msgid "Main menu:\n" +#~ msgstr "Menu principal :\n" + +#~ msgid "a new user" +#~ msgstr "un nouvel utilisateur" + +#~ msgid "status|currently logged in" +#~ msgstr "actuellement connecté" + +#~ msgid "status|offline (inaccessible)" +#~ msgstr "hors ligne (inaccessible)" + +#~ msgid "" +#~ "Type a number to log in, prefix it with '-' to delete the account, or " +#~ "type + to create a new account.\n" +#~ msgstr "" +#~ "Entrez un nombre pour vous connecter, préfixez-le avec « - » pour " +#~ "supprimer le compte, ou tapez + pour créer un nouveau compte.\n" + +#, scheme-format +#~ msgid "I could not negociate an access token. ~a" +#~ msgstr "Je n’ai pas pu négocier de jeton d’accès. ~a" + +#~ msgid "" +#~ "The refresh token has expired, it is not possible to use that account " +#~ "offline.\n" +#~ msgstr "" +#~ "Le jeton de rafraîchissement a expiré, il n’est pas possible d’utiliser " +#~ "ce compte hors ligne.\n" + +#~ msgid "Please enter an URI to GET:\n" +#~ msgstr "Veuillez entrer un URI à requêter avec GET :\n" + #~ msgid "status|not initialized yet" #~ msgstr "pas encore initialisé" diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 461c4a7..d340e41 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -24,8 +24,9 @@ #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) - #:use-module ((webid-oidc client accounts) #:prefix client:) #:use-module ((webid-oidc cache) #:prefix cache:) + #:use-module ((webid-oidc client accounts) #:prefix account:) + #:use-module ((webid-oidc client client) #:prefix client:) #:use-module (web uri) #:use-module (web client) #:use-module (web request) @@ -43,31 +44,30 @@ #:use-module (ice-9 suspendable-ports) #:use-module (ice-9 match) #:use-module (sxml simple) - #:export + #:use-module (oop goops) + #:re-export ( - <client> - make-client - client? - client-id - client-key - client-redirect-uri + (client:<client> . <client>) + (client:client-id . client-id) + (client:client-key-pair . client-key-pair) + (client:client-redirect-uri . client-redirect-uri) - initial-login + (client:client . client) + (account:authorization-process . authorization-process) + (account:authorization-state . authorization-state) + (account:anonymous-http-request . anonymous-http-request) + ) + #:export + ( request serve-application ) #:declarative? #t) -;; Better for syntax highlighting -(define <client:account> client:<account>) - -(define-record-type <client> - (make-client id key redirect-uri) - client? - (id client-id) - (key client-key) - (redirect-uri client-redirect-uri)) +;; For syntax highlighting +(define <account:account> account:<account>) +(define <client:client> client:<client>) (define (setup-headers!) ;; HACK: guile does not support other authentication schemes in @@ -105,7 +105,7 @@ ((value port) (original-writer value port)))))) -(define* default-http-get-with-cache +(define default-http-get-with-cache (cache:with-cache)) (define* (default-http-request uri . all-args) @@ -122,91 +122,62 @@ #:key (http-request default-http-request)) (setup-headers!) - (match client - (($ <client> client-id client-key redirect-uri) - (client:save-account - (client:login #f issuer - #:http-request http-request - #:client-id client-id - #:client-key client-key - #:redirect-uri redirect-uri))))) + (parameterize ((account:anonymous-http-request default-http-request) + (client:client client)) + (make <account:account> + #:issuer issuer))) -(define* (request client subject issuer - #:key - (http-request default-http-request)) +(define (request account uri . other-args) (setup-headers!) - (match client - (($ <client> client-id client-key redirect-uri) - (let ((do-login - (let ((my-http-get - (lambda* (uri . args) - (apply http-request uri - #:method 'GET - args))) - (my-http-post - (lambda* (uri . args) - (apply http-request uri - #:method 'POST - args)))) - (match-lambda* - ((subject issuer) - (client:save-account - (client:login subject issuer - #:http-request http-request - #:client-id client-id - #:client-key client-key - #:redirect-uri redirect-uri))) - ((($ <client:account> subject issuer _ _ _ _)) - (client:save-account - (client:login subject issuer - #:http-request http-request - #:client-id client-id - #:client-key client-key - #:redirect-uri redirect-uri))))))) - (let ((current-account (do-login subject issuer))) - (define (handle request request-body) - (receive (response response-body) - (let* ((access-token (client:account-access-token current-account)) - (dpop-proof - (issue-dpop-proof - (client:account-keypair current-account) - #:alg (case (kty client-key) - ((EC) 'ES256) - ((RSA) 'RS256)) - #:htm (request-method request) - #:htu (request-uri request) - #:access-token access-token))) - (let ((headers - `((dpop . ,dpop-proof) - (authorization . (dpop . ,access-token)) - ,@(request-headers request)))) - (http-request - (request-uri request) - #:method (request-method request) - #:headers headers))) - (if (eqv? (response-code response) 401) - ;; Maybe the accesss token expired - (let ((server-date (time-second (date->time-utc (response-date response)))) - (exp (assq-ref (client:account-id-token current-account) 'exp))) - (if (>= server-date exp) - ;; The ID token expired, renew it. - (begin - (set! current-account - (client:save-account - (do-login - (client:save-account - (client:invalidate-access-token current-account))))) - ;; Read it that way: invalidate the current - ;; account access token, then save it so that - ;; noone uses the invalid access token, then - ;; try to log in again, and finally save the - ;; new access token. - (handle request request-body)) - ;; The ID token has not expired, we don’t care. - (values response response-body))) - ;; OK or other error, we don’t care. - (values response response-body)))) - handle))))) + (unless (account:access-token account) + (set! account (account:refresh account))) + (define (do-with-headers method headers non-header-args can-fail?) + (let* ((access-token (account:access-token account)) + (dpop-proof + (let ((key-pair (account:key-pair account))) + (issue-dpop-proof + key-pair + #:alg (case (kty key-pair) + ((EC) 'ES256) + ((RSA) 'RS256)) + #:htm method + #:htu uri + #:access-token access-token)))) + (let ((all-headers + `((dpop . ,dpop-proof) + (authorization . (dpop . ,access-token)) + ,@headers))) + (receive (response body) + (apply (account:anonymous-http-request) uri + #:headers all-headers + non-header-args) + (let ((code (response-code response))) + (if (and (eqv? code 401) can-fail?) + ;; Code expired + (begin + (set! account (account:refresh (account:invalidate-access-token account))) + ;; retry + (do-with-headers method headers non-header-args #f)) + (values account response body))))))) + (let scan-arguments ((args other-args) + (headers #f) + (non-header-args '()) + (method #f)) + (match args + (() + (cond + ((not headers) + (scan-arguments args '() non-header-args method)) + ((not method) + (scan-arguments args headers non-header-args 'GET)) + (else + (do-with-headers method headers (reverse non-header-args) #t)))) + ((#:method new-method args ...) + (scan-arguments args headers non-header-args (or method new-method))) + ((#:headers (new-headers ...) args ...) + (scan-arguments args (or headers new-headers) non-header-args method)) + ((kw value args ...) + (scan-arguments args headers `(,value ,kw ,@non-header-args) method))))) (define* (serve-application id redirect-uri #:key diff --git a/src/scm/webid-oidc/client/Makefile.am b/src/scm/webid-oidc/client/Makefile.am index ccb7e35..583193e 100644 --- a/src/scm/webid-oidc/client/Makefile.am +++ b/src/scm/webid-oidc/client/Makefile.am @@ -15,7 +15,9 @@ # along with this program. If not, see <https://www.gnu.org/licenses/>. dist_clientwebidoidcmod_DATA += \ - %reldir%/accounts.scm + %reldir%/accounts.scm \ + %reldir%/client.scm clientwebidoidcgo_DATA += \ - %reldir%/accounts.go + %reldir%/accounts.go \ + %reldir%/client.go diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index cd69c59..f978257 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -1,3 +1,19 @@ +;; 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 client accounts) #:use-module (sxml simple) #:use-module (sxml match) @@ -5,6 +21,7 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 i18n) #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (webid-oidc errors) @@ -14,24 +31,31 @@ #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:) #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module ((webid-oidc dpop-proof) #:prefix dpop:) + #:use-module ((webid-oidc client client) #:prefix client:) #:use-module (web uri) #:use-module (web response) #:use-module (web client) #:use-module (rnrs bytevectors) + #:use-module (oop goops) #:declarative? #t #:export ( <account> - make-account - account? - account-subject - account-issuer - account-id-token - account-access-token - account-refresh-token - account-keypair + subject set-subject + issuer set-issuer + id-token set-id-token + access-token set-access-token + refresh-token set-refresh-token + key-pair set-key-pair + + <protected-account> + username set-username + encrypted-password set-encrypted-password + check-credentials authorization-process + authorization-state + anonymous-http-request &authorization-code-required make-authorization-code-required @@ -48,12 +72,13 @@ token-request-response token-request-response-body - read-accounts - save-account - delete-account + &login-failed + make-login-failed + login-failed? + invalidate-access-token invalidate-refresh-token - login + refresh ) #:declarative? #t) @@ -100,453 +125,361 @@ (make-exception-with-message final-message)) #:continuable? #t))))) -(define-record-type <account> - (make-account subject issuer id-token access-token refresh-token keypair) - account? - (subject account-subject) - (issuer account-issuer) - (id-token account-id-token) - (access-token account-access-token) - (refresh-token account-refresh-token) - (keypair account-keypair)) - -(define (load-account-arguments subject issuer arguments) - (let collect-arguments ((id-token #f) - (access-token #f) - (refresh-token #f) - (keypair #f) - (arguments arguments)) - (match arguments - (() - (make-account subject - issuer - id-token - access-token - refresh-token - keypair)) - ((hd tl ...) - (sxml-match - hd - ((disfluid:id-token (@ (alg ,alg) (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp))) - (collect-arguments - (id:the-id-token - `(((alg . ,alg)) - . ((webid . ,(uri->string subject)) - (iss . ,(uri->string issuer)) - (sub . ,sub) - (aud . ,aud) - (nonce . ,nonce) - (iat . ,(string->number iat)) - (exp . ,(string->number exp))))) - access-token - refresh-token - keypair - tl)) - ((disfluid:access-token (@ (access-token ,access-token))) - (collect-arguments - id-token - access-token - refresh-token - keypair - tl)) - ((disfluid:refresh-token (@ (refresh-token ,refresh-token))) - (collect-arguments - id-token - access-token - refresh-token - keypair - tl)) - ((disfluid:rsa-keypair (@ (n ,n) (e (,e "AQAB")) - (d ,d) (p ,p) (q ,q) (dp ,dp) (dq ,dq) (qi ,qi))) - (collect-arguments - id-token - access-token - refresh-token - `(,@(jwk:make-rsa-public-key n e) - ,@(jwk:make-rsa-private-key d p q dp dq qi)) - tl)) - ((disfluid:ec-keypair (@ (crv ,crv) (x ,x) (y ,y) (d ,d))) - (collect-arguments - id-token - access-token - refresh-token - `(,@(jwk:make-ec-point crv x y) - ,@(jwk:make-ec-scalar crv d)) - tl))))))) - -(define (read-accounts) - (let generate-list - ((content - (catch #t - (lambda () - (call-with-input-file (string-append (p:data-home) "/profiles.xml") - (lambda (port) - (xml->sxml port - #:namespaces '((disfluid . "https://disfluid.planete-kraus.eu/client-account/v1")) - #:trim-whitespace? #t)))) - (lambda error - '(*TOP* - (disfluid:accounts))))) - (parsed-accounts '())) - (sxml-match - content - ((*TOP* - (disfluid:accounts)) - (reverse parsed-accounts)) - ((*TOP* - (disfluid:accounts - (disfluid:account - (@ (subject ,subject) - (issuer ,issuer)) - ,arguments ...) - ,other-accounts ...)) - (let ((account (load-account-arguments - (string->uri subject) - (string->uri issuer) arguments))) - (generate-list - `(*TOP* (disfluid:accounts ,@other-accounts)) - `(,account ,@parsed-accounts)))) - ((*TOP* - (disfluid:accounts - ,whatever - ,other-accounts ...)) - (generate-list `(*TOP* (disfluid:accounts ,@other-accounts)) parsed-accounts)) - ((*TOP* - ,whatever) - (generate-list `(*TOP* (disfluid:accounts)) parsed-accounts))))) - -(define (update-accounts transformer) - (stubs:atomically-update-file - (string-append (p:data-home) "/profiles.xml") - (string-append (p:data-home) "/profiles.xml.lock") - (lambda (port) - (let ((old-accounts (read-accounts))) - (let ((new-accounts (transformer old-accounts))) - (chmod port #o600) - (sxml->xml - `(*TOP* - (accounts - (@ (xmlns "https://disfluid.planete-kraus.eu/client-account/v1")) - ,@(map (match-lambda - (($ <account> subject issuer id-token access-token refresh-token keypair) - (when (string? subject) - (set! subject (string->uri subject))) - (when (string? issuer) - (set! issuer (string->uri issuer))) - `(account - (@ (subject ,(uri->string subject)) - (issuer ,(uri->string issuer))) - ,@(if id-token - `((id-token (@ (alg ,(symbol->string (id:id-token-alg id-token))) - (sub ,(id:id-token-sub id-token)) - (aud ,(uri->string (id:id-token-aud id-token))) - (nonce ,(id:id-token-nonce id-token)) - (iat - ,(number->string - (time-second - (date->time-utc - (id:id-token-iat id-token))))) - (exp - ,(number->string - (time-second - (date->time-utc - (id:id-token-exp id-token)))))))) - '()) - ,@(if access-token - `((access-token (@ (access-token ,access-token)))) - '()) - ,@(if refresh-token - `((refresh-token (@ (refresh-token ,refresh-token)))) - '()) - ,@(if keypair - (case (jwk:kty keypair) - ((RSA) - `((rsa-keypair (@ (n ,(assq-ref keypair 'n)) - (e ,(assq-ref keypair 'e)) - (d ,(assq-ref keypair 'd)) - (p ,(assq-ref keypair 'p)) - (q ,(assq-ref keypair 'q)) - (dp ,(assq-ref keypair 'dp)) - (dq ,(assq-ref keypair 'dq)) - (qi ,(assq-ref keypair 'qi)))))) - ((EC) - `((ec-keypair (@ (crv ,(symbol->string (assq-ref keypair 'crv))) - (x ,(assq-ref keypair 'x)) - (y ,(assq-ref keypair 'y)) - (d ,(assq-ref keypair 'd))))))))))) - new-accounts))) - port)))))) - -(define (filter-out account old-accounts) - (match account - (($ <account> subject issuer _ _ _ _) - (filter - (match-lambda - (($ <account> other-subject other-issuer _ _ _ _) - ;; Keep it only if this is not the same user - (or (not (equal? other-subject subject)) - (not (equal? other-issuer issuer))))) - old-accounts)))) - -(define (save-account account) - (update-accounts - (lambda (old-accounts) - `(,account - ,@(filter-out account old-accounts)))) - account) - -(define (delete-account account) - (update-accounts - (lambda (old-accounts) - (filter-out account old-accounts)))) - -(define invalidate-access-token - (match-lambda - (($ <account> subject issuer _ _ refresh-token keypair) - (make-account subject issuer #f #f refresh-token keypair)))) - -(define invalidate-refresh-token - (match-lambda - (($ <account> subject issuer id-token access-token _ keypair) - (make-account subject issuer id-token access-token #f keypair)))) +(define authorization-state + (make-parameter #f)) + +(define anonymous-http-request + (make-parameter http-request)) (define (http-request->http-get http-request) (lambda* (uri . all-args) (apply http-request uri #:method 'GET all-args))) -;; subject is optional. If the user is unknown, ask for an issuer and -;; pass #f as subject. -(define* (login subject issuer - #:key - (http-request http-request) - (state #f) - client-id - client-key - redirect-uri) - (let ((all-accounts (if subject - ;; we’re expected to know the subject - (read-accounts) - ;; we’re not expected to know the subject - ;; anyway. - '()))) - (let find-access-token ((accounts (read-accounts)) - (available-refresh-token #f)) - (match accounts - (() ;; No access token available (or no ID token, or no key): - ;; requires authorization. - (receive (authorization-endpoint token-endpoint) - (let ((configuration - (cfg:get-oidc-configuration - (uri-host issuer) - #:userinfo (uri-userinfo issuer) - #:port (uri-port issuer) - #:http-get (http-request->http-get http-request)))) - (values - (cfg:oidc-configuration-authorization-endpoint configuration) - (cfg:oidc-configuration-token-endpoint configuration))) - (let ((grant-type - (if available-refresh-token - "refresh_token" - "authorization_code")) - (grant - (or available-refresh-token - ;; Negociate an authorization code - (let ((authorization-uri - (build-uri - (uri-scheme authorization-endpoint) - #:userinfo (uri-userinfo authorization-endpoint) - #:host (uri-host authorization-endpoint) - #:port (uri-port authorization-endpoint) - #:path (uri-path authorization-endpoint) - #:query - (string-join - (map (match-lambda - ((key . value) - (string-join `(,(symbol->string key) - ,(uri-encode value)) - "="))) - `((client_id . ,(uri->string client-id)) - (redirect_uri . ,(uri->string redirect-uri)) - ,@(if state - `((state . ,state)) - '()))) - "&")))) - ((authorization-process) authorization-uri #:issuer issuer)))) - (dpop-proof - (dpop:issue-dpop-proof - client-key - #:alg (case (jwk:kty client-key) - ((EC) 'ES256) - ((RSA) 'RS256)) - #:htm 'POST - #:htu token-endpoint))) - ;; Post the token request with the correct grant: - (receive (response response-body) - (http-request token-endpoint - #:method 'POST - #:body - (string-join - (map - (match-lambda +(define (http-get-implementation) + (http-request->http-get (anonymous-http-request))) + +(define-class <account> () + (subject #:init-keyword #:subject #:getter subject) + (issuer #:init-keyword #:issuer #:getter issuer) + (id-token #:init-keyword #:id-token #:getter id-token #:init-value #f) + (access-token #:init-keyword #:access-token #:getter access-token #:init-value #f) + (refresh-token #:init-keyword #:refresh-token #:getter refresh-token #:init-value #f) + (key-pair #:init-keyword #:key-pair #:getter key-pair)) + +(define-method (equal? (a <account>) (b <account>)) + (and (equal? (subject a) (subject b)) + (equal? (issuer a) (issuer b)) + (equal? (id-token a) (id-token b)) + (equal? (access-token a) (access-token b)) + (equal? (refresh-token a) (refresh-token b)) + (equal? (key-pair a) (key-pair b)))) + +(define-exception-type + &login-failed + &external-error + make-login-failed + login-failed?) + +(define-method (initialize (account <account>) initargs) + (next-method) + (let-keywords + initargs #t + ((subject #f) + (issuer #f) + (id-token #f) + (access-token #f) + (refresh-token #f) + (key-pair #f)) + (match `(,subject ,issuer) + (((or (? string? (= string->uri (? uri? subject))) + (? uri? subject)) + (or (? string? (= string->uri (? uri? issuer))) + (? uri? issuer))) + (slot-set! account 'subject subject) + (slot-set! account 'issuer issuer)) + ((#f + (or (? string? (= string->uri (? uri? issuer))) + (? uri? issuer))) + ;; Create the account + (let ((client (client:client))) + (receive (authorization-endpoint token-endpoint) + (let ((configuration + (cfg:get-oidc-configuration + (uri-host issuer) + #:userinfo (uri-userinfo issuer) + #:port (uri-port issuer) + #:http-get (http-get-implementation)))) + (values + (cfg:oidc-configuration-authorization-endpoint configuration) + (cfg:oidc-configuration-token-endpoint configuration))) + (receive (grant-type grant) + (if refresh-token + (values "refresh_token" refresh-token) + (values + "authorization_code" + (let ((authorization-uri + (build-uri + (uri-scheme authorization-endpoint) + #:userinfo (uri-userinfo authorization-endpoint) + #:host (uri-host authorization-endpoint) + #:port (uri-port authorization-endpoint) + #:path (uri-path authorization-endpoint) + #:query + (string-join + (map (match-lambda ((key . value) - (string-append (uri-encode key) - "=" - (uri-encode value)))) - `(("grant_type" . ,grant-type) - (,(if available-refresh-token - "refresh_token" - "code") . ,grant))) - "&") - #:headers - `((content-type application/x-www-form-urlencoded) - (dpop . ,dpop-proof))) - ;; Check that the token endpoint responded correctly. - (when (eqv? (response-code response) 403) - (when subject - (save-account - (invalidate-refresh-token - (make-account subject issuer #f #f #f #f)))) - (let ((final-message - (format #f (G_ "The refresh token has expired.")))) - (raise-exception - (make-exception - (make-refresh-token-expired) - (make-exception-with-message final-message))))) - (unless (eqv? (response-code response) 200) - (let ((final-message - (format #f (G_ "The token request failed with code ~s (~s).") - (response-code response) - (response-reason-phrase response)))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (unless (response-content-type response) - (let ((final-message - (format #f (G_ "The token response did not set the content type.")))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (with-exception-handler - (lambda (encoding-error) - (let ((final-message - (format #f (G_ "The token endpoint did not respond in UTF-8.")))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message) - encoding-error)))) - (lambda () - (when (bytevector? response-body) - (set! response-body (utf8->string response-body))))) - (unless (eq? (car (response-content-type response)) - 'application/json) - (let ((final-message - (format #f (G_ "The token response has content-type ~s, not application/json.") - (response-content-type response)))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (let ((data - (with-exception-handler - (lambda (json-error) - (let ((final-message - (format #f (G_ "The token response is not valid JSON.")))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message) - json-error)))) - (lambda () - (stubs:json-string->scm response-body))))) - (let ((id-token (assq-ref data 'id_token)) - (access-token (assq-ref data 'access_token)) - (refresh-token (assq-ref data 'refresh_token))) - (unless id-token - (let ((final-message - (format #f (G_ "The token response did not include an ID token: ~s") - data))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (unless access-token - (let ((final-message - (format #f (G_ "The token response did not include an access token: ~s + (string-join `(,(symbol->string key) + ,(uri-encode value)) + "="))) + `((client_id . ,(uri->string (client:client-id client))) + (redirect_uri . ,(uri->string (client:client-redirect-uri client))) + ,@(let ((state (authorization-state))) + (if state + `((state . ,state)) + '())))) + "&")))) + ((authorization-process) authorization-uri #:issuer issuer)))) + (unless key-pair + (set! key-pair (client:client-key-pair client))) + (let ((dpop-proof + (dpop:issue-dpop-proof + key-pair + #:alg (case (jwk:kty key-pair) + ((EC) 'ES256) + ((RSA) 'RS256)) + #:htm 'POST + #:htu token-endpoint))) + (receive (response response-body) + ((anonymous-http-request) token-endpoint + #:method 'POST + #:body + (string-join + (map + (match-lambda + ((key . value) + (string-append (uri-encode key) + "=" + (uri-encode value)))) + `(("grant_type" . ,grant-type) + (,(if (equal? grant-type "refresh_token") + "refresh_token" + "code") . ,grant))) + "&") + #:headers + `((content-type application/x-www-form-urlencoded) + (dpop . ,dpop-proof))) + ;; Check that the token endpoint responded correctly. + (when (eqv? (response-code response) 403) + (let ((final-message + (format #f (G_ "The refresh token has expired.")))) + (raise-exception + (make-exception + (make-refresh-token-expired) + (make-exception-with-message final-message))))) + (unless (eqv? (response-code response) 200) + (let ((final-message + (format #f (G_ "The token request failed with code ~s (~s).") + (response-code response) + (response-reason-phrase response)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (unless (response-content-type response) + (let ((final-message + (format #f (G_ "The token response did not set the content type.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (with-exception-handler + (lambda (encoding-error) + (let ((final-message + (format #f (G_ "The token endpoint did not respond in UTF-8.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + encoding-error)))) + (lambda () + (when (bytevector? response-body) + (set! response-body (utf8->string response-body))))) + (unless (eq? (car (response-content-type response)) + 'application/json) + (let ((final-message + (format #f (G_ "The token response has content-type ~s, not application/json.") + (response-content-type response)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (let ((data + (with-exception-handler + (lambda (json-error) + (let ((final-message + (format #f (G_ "The token response is not valid JSON.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + json-error)))) + (lambda () + (stubs:json-string->scm response-body))))) + (set! id-token (assq-ref data 'id_token)) + (set! access-token (assq-ref data 'access_token)) + (set! refresh-token + (assq-ref data 'refresh_token)) + (unless id-token + (let ((final-message + (format #f (G_ "The token response did not include an ID token: ~s") + data))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (unless access-token + (let ((final-message + (format #f (G_ "The token response did not include an access token: ~s ") - data))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (with-exception-handler - (lambda (decoding-error) - (let ((final-message - (if (exception-with-message? decoding-error) - (format #f (G_ "the ID token signature is invalid: ~a") - (exception-message decoding-error)) - (format #f (G_ "the ID token signature is invalid"))))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message) - decoding-error)))) - (lambda () - (set! id-token - (id:id-token-decode id-token - #:http-get - (http-request->http-get http-request))))) - ;; We are not interested in the ID token - ;; signature anymore, because it won’t be - ;; transmitted to other parties and we know that - ;; it is valid. - (when (and subject - (not (equal? subject (id:id-token-webid id-token)))) - (let ((final-message - (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid") - (uri->string subject) - (id:id-token-webid id-token)))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (when (not (equal? issuer (id:id-token-iss id-token))) - (let ((final-message - (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.") - (uri->string issuer) - (id:id-token-iss id-token)))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message final-message))))) - (make-account - (id:id-token-webid id-token) - issuer - id-token - access-token - refresh-token - client-key))))))) - ;; There is an account with an access token that was still - ;; valid last time we used it. - ((($ <account> hd-subject hd-issuer hd-id-token hd-access-token hd-refresh-token hd-keypair) tl ...) - (cond - ((and (equal? hd-subject subject) - (equal? hd-issuer issuer) - hd-id-token - hd-access-token - hd-keypair) - ;; We can use it as is. - (make-account hd-subject hd-issuer - hd-id-token hd-access-token hd-refresh-token hd-keypair)) - ((and (equal? hd-subject subject) - (equal? hd-issuer issuer)) - ;; We know that user, but the access token has been - ;; invalidated. If it still has a refresh token, maybe try - ;; it. - (find-access-token '() hd-refresh-token)) - (else - ;; We can’t even use this refresh token, so we will try - ;; with the previous one. - (find-access-token tl available-refresh-token)))))))) + data))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (with-exception-handler + (lambda (decoding-error) + (let ((final-message + (if (exception-with-message? decoding-error) + (format #f (G_ "the ID token signature is invalid: ~a") + (exception-message decoding-error)) + (format #f (G_ "the ID token signature is invalid"))))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + decoding-error)))) + (lambda () + (set! id-token + (id:id-token-decode id-token + #:http-get + (http-request->http-get (anonymous-http-request)))))) + ;; We are not interested in the ID token + ;; signature anymore, because it won’t be + ;; transmitted to other parties and we know that + ;; it is valid. + (when (and subject + (not (equal? subject (id:id-token-webid id-token)))) + (let ((final-message + (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid") + (uri->string subject) + (id:id-token-webid id-token)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (set! subject (id:id-token-webid id-token)) + (when (not (equal? issuer (id:id-token-iss id-token))) + (let ((final-message + (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.") + (uri->string issuer) + (id:id-token-iss id-token)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) + (slot-set! account 'subject subject) + (slot-set! account 'issuer issuer) + (slot-set! account 'id-token id-token) + (slot-set! account 'access-token access-token) + (slot-set! account 'refresh-token refresh-token) + (slot-set! account 'key-pair key-pair)))))))) + ((#f #f) + (scm-error 'wrong-type-arg "make <account>" + (G_ "The issuer is required.") + '() + (list issuer))) + (else + (scm-error 'wrong-type-arg "make <account>" + (G_ "The optional subject and required issuer should be strings or URI.") + '() + (list subject issuer)))))) + +(define-class <protected-account> (<account>) + (username #:init-keyword #:username #:getter username) + (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password)) + +(define-method (check-credentials (account <protected-account>) (username <string>) (password <string>)) + (let ((c (crypt password (encrypted-password account)))) + (unless (string=? c (encrypted-password account)) + (raise-exception + (make-exception + (make-login-failed) + (make-exception-with-message + (G_ "Cannot check the username and/or password."))))))) + +(define-method (set-subject (a <account>) uri) + (let ((ret (shallow-clone a)) + (uri + (match uri + ((? uri? uri) uri) + ((? string? (= string->uri (? uri? uri))) uri) + (else + (scm-error 'wrong-type-arg "set-subject" + (G_ "The subject should be a string or URI.") + '() + (list subject)))))) + (slot-set! ret 'subject uri) + ret)) + +(define-method (set-issuer (a <account>) uri) + (let ((ret (shallow-clone a)) + (uri + (match uri + ((? uri? uri) uri) + ((? string? (= string->uri (? uri? uri))) uri) + (else + (scm-error 'wrong-type-arg "set-issuer" + (G_ "The issuer should be a string or URI.") + '() + (list issuer)))))) + (slot-set! ret 'issuer uri) + ret)) + +(define-method (set-id-token (a <account>) id-token) + (let ((ret (shallow-clone a))) + (slot-set! ret 'id-token id-token) + ret)) + +(define-method (set-access-token (a <account>) access-token) + (let ((ret (shallow-clone a))) + (slot-set! ret 'access-token access-token) + ret)) + +(define-method (set-refresh-token (a <account>) refresh-token) + (let ((ret (shallow-clone a))) + (slot-set! ret 'refresh-token refresh-token) + ret)) + +(define-method (set-key-pair (a <account>) key-pair) + (let ((ret (shallow-clone a))) + (slot-set! ret 'key-pair key-pair) + ret)) + +(define-method (set-username (a <protected-account>) username) + (let ((ret (shallow-clone a))) + (slot-set! ret 'username username) + ret)) + +(define-method (set-encrypted-password (a <protected-account>) encrypted-password) + (let ((ret (shallow-clone a))) + (slot-set! ret 'encrypted-password encrypted-password) + ret)) + +(define-method (invalidate-access-token (a <account>)) + (set-id-token + (set-access-token a #f) + #f)) + +(define-method (invalidate-refresh-token (a <account>)) + (set-refresh-token a #f)) + +(define-method (refresh (a <account>)) + ;; Fill the holes made by invalidate-access-token + (let ((full + (make <account> + #:issuer (issuer a) + #:refresh-token (refresh-token a) + #:key-pair (key-pair a)))) + (unless (equal? (subject a) (subject full)) + (set! a (set-subject a (subject full)))) + (unless (equal? (issuer a) (issuer full)) + (set! a (set-issuer a (issuer full)))) + (unless (equal? (id-token a) (id-token full)) + (set! a (set-id-token a (id-token full)))) + (unless (equal? (access-token a) (access-token full)) + (set! a (set-access-token a (access-token full)))) + (unless (equal? (refresh-token a) (refresh-token full)) + (set! a (set-refresh-token a (refresh-token full)))) + (unless (equal? (key-pair a) (key-pair full)) + (set! a (set-key-pair a (key-pair full)))) + a)) diff --git a/src/scm/webid-oidc/client/client.scm b/src/scm/webid-oidc/client/client.scm new file mode 100644 index 0000000..66f8b74 --- /dev/null +++ b/src/scm/webid-oidc/client/client.scm @@ -0,0 +1,92 @@ +;; 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 client client) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc provider-confirmation) + #:use-module (webid-oidc oidc-configuration) + #:use-module (webid-oidc oidc-id-token) + #:use-module (webid-oidc dpop-proof) + #:use-module (webid-oidc web-i18n) + #:use-module ((webid-oidc jwk) #:prefix jwk:) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module ((webid-oidc client accounts) #:prefix client:) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (web http) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 i18n) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 match) + #:use-module (sxml simple) + #:use-module (oop goops) + #:export + ( + <client> + client-id + client-key-pair + client-redirect-uri + + client + ) + #:declarative? #t) + +(define-class <client> () + (client-id #:init-keyword #:client-id #:getter client-id) + (key-pair #:init-keyword #:key-pair #:getter client-key-pair) + (redirect-uri #:init-keyword #:redirect-uri #:getter client-redirect-uri)) + +(define-method (initialize (client <client>) initargs) + (next-method) + (let-keywords + initargs #t + ((client-id #f) + (key-pair #t) ;; We’ll generate one if not #f + (redirect-uri #f)) + (let convert-args ((client-id client-id) + (key-pair key-pair) + (redirect-uri redirect-uri)) + (match `(,client-id ,key-pair ,redirect-uri) + (((or (? string? (= string->uri (? uri? client-id))) + (? uri? client-id)) + (? jwk:jwk? client-key) + (or (? string? (= string->uri (? uri? redirect-uri))) + (? uri? redirect-uri))) + (begin + (slot-set! client 'client-id client-id) + (slot-set! client 'key-pair client-key) + (slot-set! client 'redirect-uri redirect-uri))) + ((_ #t _) + (convert-args client-id (jwk:generate-key #:n-size 2048) redirect-uri)) + (else + (scm-error 'wrong-type-arg "make <account>" + (G_ "Client ID and redirect URIs should be URIs, and key pair should be a key pair..") + '() + (list client-id key-pair redirect-uri))))))) + +(define client + (make-parameter #f)) diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index 16e19ae..9bf99c1 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -16,7 +16,7 @@ (define-module (webid-oidc example-app) #:use-module ((webid-oidc client) #:prefix client:) - #:use-module ((webid-oidc client accounts) #:prefix client:) + #:use-module ((webid-oidc client accounts) #:prefix account:) #:use-module ((webid-oidc cache) #:prefix cache:) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc web-i18n) @@ -29,8 +29,10 @@ #:use-module (web request) #:use-module (web response) #:use-module (web server) + #:use-module (web http) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 getopt-long) @@ -39,105 +41,432 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) + #:use-module (ice-9 readline) #:use-module (sxml simple) #:use-module (rnrs bytevectors) - #:declarative? #t) + #:use-module (oop goops) + #:declarative? #t + #:export (main)) -(define example-app - (client:make-client - (string->uri - "https://webid-oidc-demo.planete-kraus.eu/example-application#id") - (jwk:generate-key #:n-size 2048) - (string->uri - "https://webid-oidc-demo.planete-kraus.eu/authorized"))) +(define <client:client> client:<client>) +(define <account:account> account:<account>) + +(define-class <app-state> () + (account #:init-keyword #:account #:getter app-state-account) + (unused-accounts #:init-keyword #:unused-accounts #:getter app-state-unused-accounts) + (uri #:init-keyword #:uri #:getter app-state-uri) + (method #:init-keyword #:method #:getter app-state-method #:init-value 'GET) + (headers #:init-keyword #:headers #:getter app-state-headers #:init-value '())) + +(define-method (equal? (a <app-state>) (b <app-state>)) + ;; This method will let us know if an action is a re-do or a novel + ;; update + (and (equal? (app-state-account a) (app-state-account b)) + (equal? (app-state-unused-accounts a) (app-state-unused-accounts b)) + (equal? (app-state-uri a) (app-state-uri b)) + (eq? (app-state-method a) (app-state-method b)) + (equal? (app-state-headers a) (app-state-headers b)))) + +(define-method (add-account (app <app-state>) (account <account:account>)) + (let ((ret (shallow-clone app))) + ;; If we have already selected an account, make it unused, + ;; otherwise select it as default. + (if (app-state-account ret) + (slot-set! ret 'unused-accounts + `(,account ,@(app-state-unused-accounts app))) + (slot-set! ret 'account account)) + ret)) + +(define-method (enumerate-accounts (app <app-state>)) + (let construct ((all-accounts `(,(app-state-account app) + ,@(app-state-unused-accounts app))) + (i 1) + (constructed '())) + (match all-accounts + (() + (reverse constructed)) + ((next rest ...) + (construct rest (+ i 1) `((,i . ,next) ,@constructed)))))) + +(define-method (account-summary (account <account:account>)) + (let ((subject (account:subject account)) + (issuer (account:issuer account)) + (access-token (account:access-token account)) + (refresh-token (account:refresh-token account))) + (cond + ((and access-token refresh-token) + (format #f (G_ "~a (issued by ~a): no interaction required") + (uri->string subject) (uri->string issuer))) + (refresh-token + (format #f (G_ "~a (issued by ~a): offline but accessible") + (uri->string subject) (uri->string issuer))) + (access-token + (format #f (G_ "~a (issued by ~a): online") + (uri->string subject) (uri->string issuer))) + (else + (format #f (G_ "~a (issued by ~a): inaccessible") + (uri->string subject) (uri->string issuer)))))) + +(define-method (choose-account (app <app-state>) (i <integer>)) + (let ((ret (shallow-clone app)) + (all-accounts (enumerate-accounts app))) + (let find-the-account ((accounts all-accounts) + (past '())) + (match accounts + (() + (raise-exception + (make-exception + (make-exception-with-message + (format #f (G_ "Your choice ~a does not exist.\n") i))))) + ((((? (cute eqv? <> i)) . hd) tl ...) + (begin + (slot-set! ret 'account hd) + (slot-set! ret 'unused-accounts + (let ((tl (map (match-lambda ((_ . account) account)) tl))) + (append-reverse past tl))))) + (((_ . hd) tl ...) + (find-the-account tl `(,hd ,@past))))) + ret)) + +(define-method (set-uri (app <app-state>) uri) + (let ((ret (shallow-clone app))) + (when (string? uri) + (set! uri (string->uri uri))) + (unless (uri? uri) + (raise-exception + (make-exception + (make-exception-with-message (G_ "Your choice is not a valid URI.\n"))))) + (slot-set! ret 'uri uri) + ret)) + +(define-method (set-method (app <app-state>) method) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-message (G_ "This is not a valid HTTP method.\n"))))) + (lambda () + (let ((ret (shallow-clone app))) + (slot-set! ret 'method (string->symbol method)) + ret)))) + +(define-method (clear-headers (app <app-state>)) + (let ((ret (shallow-clone app))) + (slot-set! ret 'headers '()) + ret)) + +(define-method (add-header (app <app-state>) (header <string>) (value <string>)) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-exception-with-message (G_ "This is not a valid value for this header.\n"))))) + (lambda () + (let ((ret (shallow-clone app)) + (new-header (parse-header (string->symbol header) value))) + (slot-set! ret 'headers + `((,(string->symbol header) . ,new-header) + ,@(app-state-headers ret))) + ret)))) + +(define-class <undoable-app-state> () + (previous-states + #:init-keyword #:previous-states + #:getter app-previous-states + #:init-value '()) + (undone-states + #:init-keyword #:undone-states + #:getter app-undone-states + #:init-value '())) + +(define-method (current-state (app <undoable-app-state>)) + (match (app-previous-states app) + ((state _ ...) + state) + (else + (make <app-state> #:account #f #:unused-accounts '() #:uri #f)))) + +(define-method (can-undo? (app <undoable-app-state>)) + (not (null? (app-previous-states app)))) + +(define-method (can-redo? (app <undoable-app-state>)) + (not (null? (app-undone-states app)))) + +(define-method (undo (app <undoable-app-state>)) + (let ((ret (shallow-clone app))) + (match (app-previous-states ret) + (() + (raise-exception + (make-exception + (make-exception-with-message (G_ "Nothing to undo.\n"))))) + ((undone other-done ...) + (slot-set! ret 'previous-states other-done) + (slot-set! ret 'undone-states `(,undone ,@(app-undone-states ret))))) + ret)) + +(define-method (redo (app <undoable-app-state>)) + (let ((ret (shallow-clone app))) + (match (app-undone-states ret) + (() + (raise-exception + (make-exception + (make-exception-with-message (G_ "Nothing to redo.\n"))))) + ((redone other-undone ...) + (slot-set! ret 'previous-states `(,redone ,@(app-previous-states ret))) + (slot-set! ret 'undone-states other-undone))) + ret)) + +(define-method (push-state (app <undoable-app-state>) (state <app-state>)) + ;; Maybe it’s a redo + (match (app-undone-states app) + (((? (cute equal? <> state)) _ ...) + ;; This is a redo + (redo app)) + (else + ;; This is not a redo + (let ((ret (shallow-clone app))) + (slot-set! ret 'previous-states `(,state ,@(app-previous-states ret))) + (slot-set! ret 'undone-states '()) + ret)))) + +(define-method (add-account (app <undoable-app-state>) (account <account:account>)) + (push-state + app + (add-account (current-state app) account))) + +(define-method (enumerate-accounts (app <undoable-app-state>)) + (enumerate-accounts (current-state app))) + +(define-method (choose-account (app <undoable-app-state>) (i <integer>)) + (push-state app (choose-account (current-state app) i))) + +(define-method (set-uri (app <undoable-app-state>) (uri <string>)) + (push-state app (set-uri (current-state app) uri))) + +(define-method (set-method (app <undoable-app-state>) (method <string>)) + (push-state app (set-method (current-state app) method))) + +(define-method (clear-headers (app <undoable-app-state>)) + (push-state app (clear-headers (current-state app)))) + +(define-method (add-header (app <undoable-app-state>) (header <string>) (value <string>)) + (push-state app (add-header (current-state app) header value))) + +(define (with-sigint-handler handler f) + ;; I don’t know how to re-install the previous sigaction + (dynamic-wind + (lambda () + (sigaction SIGINT + (lambda (sig) + (handler)))) + f + (lambda () + (sigaction SIGINT #f)))) (define (main) - (define (do-the-trick subject issuer) - (client:request example-app subject issuer)) - (let ((accounts (list->vector (client:read-accounts)))) - (format #t (G_ "Main menu:\n")) - (let enumerate-accounts ((i 0)) - (when (< i (vector-length accounts)) - (format #t (G_ "~a. Log in with ~a (issued by ~a): ~a + (setvbuf (current-output-port) 'none) + (setvbuf (current-error-port) 'none) + (setlocale LC_ALL "") + (bindtextdomain cfg:package cfg:localedir) + (textdomain cfg:package) + (define add-account-command + (G_ "Example app command|add-account")) + (define choose-account-command + (G_ "Example app command|choose-account")) + (define set-uri-command + (G_ "Example app command|set-uri")) + (define set-method-command + (G_ "Example app command|set-method")) + (define view-headers-command + (G_ "Example app command|view-headers")) + (define clear-headers-command + (G_ "Example app command|clear-headers")) + (define add-header-command + (G_ "Example app command|add-header")) + (define ok-command + (G_ "Example app command|ok")) + (define undo-command + (G_ "Example app command|undo")) + (define redo-command + (G_ "Example app command|redo")) + (parameterize + ((client:client + (make <client:client> + #:client-id + "https://webid-oidc-demo.planete-kraus.eu/example-application#id" + #:redirect-uri + "https://webid-oidc-demo.planete-kraus.eu/authorized")) + (client:authorization-process + (lambda* (uri #:key issuer) + (format (current-error-port) (G_ "To log in on ~a, please visit: ~a\n") + (uri->string issuer) + (uri->string uri)) + (format (current-error-port) (G_ "Then, paste the authorization code you get:\n")) + (read-line (current-input-port) 'trim))) + (client:authorization-state #f) + (client:anonymous-http-request + (let ((default-http-get-with-cache (cache:with-cache))) + (lambda* (uri . all-args) + (let try-get-with-cache ((args all-args) + (args-for-get '())) + (match args + (() + (apply default-http-get-with-cache uri (reverse args-for-get))) + ((#:headers arg other-args ...) + (try-get-with-cache other-args `(,arg #:headers ,@args-for-get))) + ((#:method 'GET other-args ...) + (try-get-with-cache other-args args-for-get)) + (else + (apply http-request uri all-args)))))))) + (let menu ((state (make <undoable-app-state>))) + (format #t (G_ "Account: ~a +URI: ~a +Method: ~a +Headers: ~a + +Available commands: + - ~a: add an account + - ~a: change the account + - ~a: change the URI + - ~a: change the method + - ~a: view all headers + - ~a: clear all the headers + - ~a: add a new header + - ~a: perform the request. + ") - (1+ i) - (or (let ((subject (client:account-subject (vector-ref accounts i)))) - (and subject (uri->string subject))) - (format #f (G_ "a new user"))) - (uri->string (client:account-issuer (vector-ref accounts i))) - (if (client:account-id-token (vector-ref accounts i)) - (format #f (G_ "status|currently logged in")) - (if (client:account-refresh-token (vector-ref accounts i)) - (format #f (G_ "status|offline (but accessible)")) - (format #f (G_ "status|offline (inaccessible)"))))) - (enumerate-accounts (1+ i)))) - (format #t (G_ "Type a number to log in, prefix it with '-' to delete the account, or type + to create a new account. -")) - (parameterize - ((client:authorization-process - ;; There’s a problem with guile continuable - ;; exceptions: we can’t handle errors in a handler for - ;; continuable exceptions. Until this is clarified, we - ;; avoid continuable exceptions. - (lambda* (uri #:key issuer) - (format (current-error-port) (G_ "Please visit: ~a\n") (uri->string uri)) - (format (current-error-port) (G_ "Then, paste the authorization code you get:\n")) - (read-line (current-input-port) 'trim)))) - (match (read-line (current-input-port) 'trim) - ((? string? - (= string->number - (and (? integer? _) - (? (cute >= <> 1) _) - (? (cute <= <> (vector-length accounts))) - (= (cute - <> 1) choice)))) - (let ((account (vector-ref accounts choice))) - (with-exception-handler - (lambda (error) - (cond - ((client:token-request-failed? error) - (format (current-error-port) (G_ "I could not negociate an access token. ~a") - (exception-message error)) - (main)) - ((client:refresh-token-expired? error) - (format (current-error-port) (G_ "The refresh token has expired, it is not possible to use that account offline.\n")) - (main)) - (else - (raise-exception error)))) - (lambda () - (format #t (G_ "Please enter an URI to GET:\n")) - (let ((uri (string->uri (read-line (current-input-port) 'trim))) - (handler (do-the-trick (client:account-subject account) - (client:account-issuer account)))) - (receive (response response-body) - (handler (build-request uri) "") - (let ((ad-hoc-port (write-response response (current-output-port)))) - (unless (response-must-not-include-body? response) - (when (string? response-body) - (set! response-body (string->utf8 response-body))) - (write-response-body ad-hoc-port response-body))))) - (format #t "\n") - (main))))) - ((? string? - (= string->number - (and (? integer? _) - (= (cute - <>) - (and (? (cute >= <> 1) _) - (? (cute <= <> (vector-length accounts)) _) - (= (cute - <> 1) choice)))))) - ;; Delete - (client:delete-account (vector-ref accounts choice)) - (main)) - ("+" - ;; Create an account - (format #t (G_ "Please type your identity provider:\n")) - (let ((issuer (read-line (current-input-port) 'trim))) - (when (and (string? issuer) (string->uri issuer)) - (client:save-account - (client:initial-login example-app (string->uri issuer))))) - (main)) - ((? eof-object? _) - (exit 0)) - (else - (main)))))) - -(main) + (let ((acct (app-state-account (current-state state)))) + (if acct + (account-summary acct) + (G_ "Account:|unset"))) + (let ((uri (app-state-uri (current-state state)))) + (if uri + (uri->string uri) + (G_ "URI:|unset"))) + (let ((method (app-state-method (current-state state)))) + (if method + (symbol->string method) + (G_ "Method:|unset"))) + (let ((headers (app-state-headers (current-state state)))) + (if (null? headers) + (G_ "Headers:|none") + (string-join + (map (match-lambda ((header . _) (symbol->string header))) + headers) + (G_ "list separator|, ")))) + add-account-command + choose-account-command + set-uri-command + set-method-command + view-headers-command + clear-headers-command + add-header-command + ok-command) + (when (can-undo? state) + (format #t (G_ "You can undo your last command with \"~a\".\n") undo-command)) + (when (can-redo? state) + (format #t (G_ "You can re-apply your last undone command with \"~a\".\n") redo-command)) + (let ((command (readline (G_ "Readline prompt|Command: ")))) + (if (eof-object? command) + (exit 0) + (with-exception-handler + (lambda (exn) + (if (exception-with-message? exn) + (begin + (format #t (G_ "An error happened: ~a.\n") + (exception-message exn)) + (menu state)) + (raise-exception exn))) + (lambda () + (cond + ((equal? command add-account-command) + (let ((identity-provider + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (readline (G_ "Please enter your identity provider: ")))))) + (menu (add-account state (make <account:account> #:issuer identity-provider))))) + ((equal? command choose-account-command) + (let ((accounts (enumerate-accounts state))) + (if (null? accounts) + (begin + (format #t (G_ "You don’t have other accounts available. Please add one with \"add-account\".\n")) + (menu state)) + (begin + (let enumerate-accounts ((accounts accounts)) + (match accounts + (((i . account) rest ...) + (format #t (G_ "- ~a: ~a\n") i (account-summary account)) + (enumerate-accounts rest)) + (() #t))) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (let ((choice (string->number + (readline (format #f (G_ "[1-~a] ") + (length accounts)))))) + (menu (choose-account state choice))))))))) + ((equal? command set-uri-command) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (menu (set-uri state (readline (G_ "Visit this URI: "))))))) + ((equal? command set-method-command) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (let ((method (readline (G_ "Use this HTTP method [GET]: ")))) + (when (equal? method "") + (set! method "GET")) + (menu (set-method state method)))))) + ((equal? command view-headers-command) + (write-headers (app-state-headers (current-state state)) + (current-output-port)) + (newline) + (menu state)) + ((equal? command clear-headers-command) + (menu (clear-headers state))) + ((equal? command add-header-command) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (let ((header (string-downcase (readline (G_ "Which header? "))))) + (let ((value + (readline + (format #f (G_ "Which header value for ~a? ") + header)))) + (menu (add-header state header value))))))) + ((equal? command ok-command) + (receive (account uri) + (let ((state (current-state state))) + (values + (app-state-account state) + (app-state-uri state))) + (if (and account uri) + (receive (account response body) + (client:request (app-state-account (current-state state)) + (app-state-uri (current-state state)) + #:method (app-state-method (current-state state)) + #:headers (app-state-headers (current-state state))) + (let ((ready-to-write-body + (write-response response (current-output-port)))) + (unless (response-must-not-include-body? ready-to-write-body) + (write-response-body ready-to-write-body + (if (string? body) + (string->utf8 body) + body))) + (newline))) + (format #t (G_ "Please define an account and the URI.\n"))) + (menu state))) + ((equal? command undo-command) + (menu (undo state))) + ((equal? command redo-command) + (menu (redo state))) + (else + (format #t (G_ "I don’t know that command.\n")) + (menu state)))))))))) diff --git a/tests/client-workflow.scm b/tests/client-workflow.scm index 15f480a..b0c0c2f 100644 --- a/tests/client-workflow.scm +++ b/tests/client-workflow.scm @@ -30,12 +30,16 @@ (ice-9 optargs) (ice-9 receive) (ice-9 hash-table) - (ice-9 match)) + (ice-9 match) + (oop goops)) ;; In this example, a user firsts requests an account, then logs in ;; with a refresh token, then logs out, but we can still revive per ;; account, then the refresh token gets banned. +(define <client:client> client:<client>) +(define <client:account> client:<account>) + (define (display-log simulation) (format (current-error-port) "Log:\n") (for-each @@ -53,7 +57,8 @@ (with-test-environment "client-workflow" (lambda () - (let ((simulation (sim:make-simulation))) + (let ((simulation (sim:make-simulation)) + (account #f)) (sim:add-server! simulation (string->uri "https://server@client-workflow.scm") (string->uri "https://server@client-workflow.scm/alice#me")) @@ -63,21 +68,24 @@ (string->uri "https://client@client-workflow.scm/authorized") "Client workflow test" (string->uri "https://client@client-workflow.scm/about")) - (let ((client (client:make-client - (string->uri "https://client@client-workflow.scm/id") - (jwk:generate-key #:n-size 2048) - (string->uri "https://client@client-workflow.scm/authorized")))) + (parameterize ((client:client + (make <client:client> + #:client-id "https://client@client-workflow.scm/id" + #:redirect-uri + (string->uri "https://client@client-workflow.scm/authorized"))) + (client:anonymous-http-request + (cute sim:request simulation <...>))) (parameterize ((p:current-date 0) (client:authorization-process (lambda* (uri #:key issuer) (sim:grant-authorization simulation uri)))) - (receive (response response-body) - (let ((handler - (client:request client #f - (string->uri "https://server@client-workflow.scm") - #:http-request (cute sim:request simulation <...>)))) - (handler (build-request (string->uri "https://server@client-workflow.scm/")) - #f)) + (receive (new-account response response-body) + (begin + (set! account + (make <client:account> #:issuer "https://server@client-workflow.scm")) + (client:request account + (string->uri "https://server@client-workflow.scm/"))) + (set! account new-account) (unless (eqv? (response-code response) 200) ;; Only Alice can read that resource. (exit 3))) @@ -140,14 +148,9 @@ (exit 4))))) ;; 1 hour later, the access token should have expired. (parameterize ((p:current-date 3600)) - (receive (response response-body) - (let ((handler - (client:request client - (string->uri "https://server@client-workflow.scm/alice#me") - (string->uri "https://server@client-workflow.scm") - #:http-request (cute sim:request simulation <...>)))) - (handler (build-request (string->uri "https://server@client-workflow.scm/")) - #f)) + (receive (new-account response response-body) + (client:request account (string->uri "https://server@client-workflow.scm/")) + (set! account new-account) (unless (eqv? (response-code response) 200) ;; Only Alice can read that resource. (exit 5))) @@ -210,13 +213,7 @@ (unless (client:refresh-token-expired? error) (exit 7))) (lambda () - (let ((handler - (client:request client - (string->uri "https://server@client-workflow.scm/alice#me") - (string->uri "https://server@client-workflow.scm") - #:http-request (cute sim:request simulation <...>)))) - (handler (build-request (string->uri "https://server@client-workflow.scm/")) - #f)) + (client:request account (string->uri "https://server@client-workflow.scm/")) (exit 8)) #:unwind? #t #:unwind-for-type client:&refresh-token-expired) |