diff options
| -rw-r--r-- | doc/disfluid.texi | 5 | ||||
| -rw-r--r-- | po/disfluid.pot | 50 | ||||
| -rw-r--r-- | po/fr.po | 53 | ||||
| -rw-r--r-- | src/scm/webid-oidc/client.scm | 37 | ||||
| -rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 16 | ||||
| -rw-r--r-- | src/scm/webid-oidc/example-app.scm | 111 |
6 files changed, 142 insertions, 130 deletions
diff --git a/doc/disfluid.texi b/doc/disfluid.texi index 4e120f8..c884acf 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -1029,6 +1029,11 @@ Constructor, predicate and accessors for the @code{<client>} record type. @end deffn +@deffn function initial-login @var{client} @var{issuer} [#:@var{http-request}=@code{http-request}] +Create an account by logging in with just the @var{issuer}, and save +the created account. +@end deffn + @deffn function request @var{client} @var{subject} @var{issuer} [#:@var{http-request}=@code{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 diff --git a/po/disfluid.pot b/po/disfluid.pot index 93e92b1..d18ddd6 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:09+0200\n" +"POT-Creation-Date: 2021-09-13 20:17+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" @@ -407,57 +407,57 @@ msgstr "" msgid "Unsupported delegate catalog URI scheme: ~s\n" msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:420 +#: src/scm/webid-oidc/client/accounts.scm:406 msgid "The refresh token has expired." msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:427 +#: src/scm/webid-oidc/client/accounts.scm:413 #, scheme-format msgid "The token request failed with code ~s (~s)." msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:436 +#: src/scm/webid-oidc/client/accounts.scm:422 msgid "The token response did not set the content type." msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:444 +#: src/scm/webid-oidc/client/accounts.scm:430 msgid "The token endpoint did not respond in UTF-8." msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:456 +#: src/scm/webid-oidc/client/accounts.scm:442 #, scheme-format msgid "The token response has content-type ~s, not application/json." msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:466 +#: src/scm/webid-oidc/client/accounts.scm:452 msgid "The token response is not valid JSON." msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:479 +#: src/scm/webid-oidc/client/accounts.scm:465 #, scheme-format msgid "The token response did not include an ID token: ~s" msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:487 +#: src/scm/webid-oidc/client/accounts.scm:473 #, scheme-format msgid "The token response did not include an access token: ~s\n" msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:498 +#: src/scm/webid-oidc/client/accounts.scm:484 #, scheme-format msgid "the ID token signature is invalid: ~a" msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:500 +#: src/scm/webid-oidc/client/accounts.scm:486 msgid "the ID token signature is invalid" msgstr "" -#: src/scm/webid-oidc/client/accounts.scm:515 +#: src/scm/webid-oidc/client/accounts.scm:501 #, 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:524 +#: src/scm/webid-oidc/client/accounts.scm:510 #, scheme-format msgid "The ID token delivered by the identity provider ~s is for issuer ~s." msgstr "" @@ -644,16 +644,16 @@ msgstr "" msgid "cannot encode a DPoP proof" msgstr "" -#: src/scm/webid-oidc/example-app.scm:57 +#: src/scm/webid-oidc/example-app.scm:58 msgid "Main menu:\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:60 +#: src/scm/webid-oidc/example-app.scm:61 #, scheme-format msgid "~a. Log in with ~a (issued by ~a): ~a\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:65 +#: src/scm/webid-oidc/example-app.scm:66 msgid "a new user" msgstr "" @@ -669,41 +669,37 @@ msgstr "" msgid "status|offline (inaccessible)" msgstr "" -#: src/scm/webid-oidc/example-app.scm:73 -msgid "status|not initialized yet" -msgstr "" - -#: src/scm/webid-oidc/example-app.scm:75 +#: 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 "" -#: src/scm/webid-oidc/example-app.scm:92 +#: src/scm/webid-oidc/example-app.scm:83 #, scheme-format msgid "Please visit: ~a\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:93 +#: src/scm/webid-oidc/example-app.scm:84 msgid "Then, paste the authorization code you get:\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:99 +#: src/scm/webid-oidc/example-app.scm:98 #, scheme-format msgid "I could not negociate an access token. ~a" msgstr "" -#: src/scm/webid-oidc/example-app.scm:103 +#: src/scm/webid-oidc/example-app.scm:102 msgid "" "The refresh token has expired, it is not possible to use that account " "offline.\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:108 +#: src/scm/webid-oidc/example-app.scm:107 msgid "Please enter an URI to GET:\n" msgstr "" -#: src/scm/webid-oidc/example-app.scm:133 +#: src/scm/webid-oidc/example-app.scm:132 msgid "Please type your identity provider:\n" msgstr "" @@ -2,7 +2,7 @@ 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:09+0200\n" +"POT-Creation-Date: 2021-09-13 20:17+0200\n" "PO-Revision-Date: 2021-09-13 19:59+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" @@ -421,58 +421,58 @@ 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:420 +#: src/scm/webid-oidc/client/accounts.scm:406 msgid "The refresh token has expired." msgstr "le jeton de rafraîchissement a expiré." -#: src/scm/webid-oidc/client/accounts.scm:427 +#: src/scm/webid-oidc/client/accounts.scm:413 #, 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:436 +#: src/scm/webid-oidc/client/accounts.scm:422 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:444 +#: src/scm/webid-oidc/client/accounts.scm:430 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:456 +#: src/scm/webid-oidc/client/accounts.scm:442 #, 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:466 +#: src/scm/webid-oidc/client/accounts.scm:452 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:479 +#: src/scm/webid-oidc/client/accounts.scm:465 #, 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:487 +#: src/scm/webid-oidc/client/accounts.scm:473 #, 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:498 +#: src/scm/webid-oidc/client/accounts.scm:484 #, 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:500 +#: src/scm/webid-oidc/client/accounts.scm:486 msgid "the ID token signature is invalid" msgstr "la signature du jeton d’ID est invalide" -#: src/scm/webid-oidc/client/accounts.scm:515 +#: src/scm/webid-oidc/client/accounts.scm:501 #, 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:524 +#: src/scm/webid-oidc/client/accounts.scm:510 #, scheme-format msgid "The ID token delivered by the identity provider ~s is for issuer ~s." msgstr "" @@ -675,16 +675,16 @@ 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:57 +#: src/scm/webid-oidc/example-app.scm:58 msgid "Main menu:\n" msgstr "Menu principal :\n" -#: src/scm/webid-oidc/example-app.scm:60 +#: src/scm/webid-oidc/example-app.scm:61 #, scheme-format msgid "~a. Log in with ~a (issued by ~a): ~a\n" msgstr "~a. Se connecter avec ~a (émis par ~a) : ~a\n" -#: src/scm/webid-oidc/example-app.scm:65 +#: src/scm/webid-oidc/example-app.scm:66 msgid "a new user" msgstr "un nouvel utilisateur" @@ -700,11 +700,7 @@ msgstr "hors ligne (mais accessible)" msgid "status|offline (inaccessible)" msgstr "hors ligne (inaccessible)" -#: src/scm/webid-oidc/example-app.scm:73 -msgid "status|not initialized yet" -msgstr "pas encore initialisé" - -#: src/scm/webid-oidc/example-app.scm:75 +#: 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" @@ -712,21 +708,21 @@ 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:92 +#: src/scm/webid-oidc/example-app.scm:83 #, scheme-format msgid "Please visit: ~a\n" msgstr "Veuillez visiter : ~a\n" -#: src/scm/webid-oidc/example-app.scm:93 +#: src/scm/webid-oidc/example-app.scm:84 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:99 +#: src/scm/webid-oidc/example-app.scm:98 #, 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" -#: src/scm/webid-oidc/example-app.scm:103 +#: src/scm/webid-oidc/example-app.scm:102 msgid "" "The refresh token has expired, it is not possible to use that account " "offline.\n" @@ -734,11 +730,11 @@ msgstr "" "Le jeton de rafraîchissement a expiré, il n’est pas possible d’utiliser ce " "compte hors ligne.\n" -#: src/scm/webid-oidc/example-app.scm:108 +#: 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:133 +#: src/scm/webid-oidc/example-app.scm:132 msgid "Please type your identity provider:\n" msgstr "Veuillez entrer votre serveur d’identité :\n" @@ -2359,6 +2355,9 @@ msgstr "" "<p>Vous voulez utiliser <pre>~s</pre> comme type d’offre, mais ce n’est pas " "supporté.</p>" +#~ msgid "status|not initialized yet" +#~ msgstr "pas encore initialisé" + #~ msgid "" #~ "\n" #~ "If no command is specified, run the graphical user interface." diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index f469d19..1aad35d 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -51,6 +51,7 @@ client-key client-redirect-uri + initial-login request serve-application @@ -67,10 +68,7 @@ (key client-key) (redirect-uri client-redirect-uri)) -;; subject is optional, if you don’t know who the user is. -(define* (request client subject issuer - #:key - (http-request http-request)) +(define (setup-headers!) ;; HACK: guile does not support other authentication schemes in ;; WWW-Authenticate than Basic, so it will crash when a response ;; containing that header will be issued. @@ -104,7 +102,36 @@ ((('dpop . dpop) port) (format port "DPoP ~a" dpop)) ((value port) - (original-writer value port))))) + (original-writer value port)))))) + +(define* (initial-login client issuer + #:key + (http-request http-request)) + (setup-headers!) + (match client + (($ <client> client-id client-key redirect-uri) + (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)))) + (client:save-account + (client:login #f issuer + #:http-get my-http-get + #:http-post my-http-post + #:client-id client-id + #:client-key client-key + #:redirect-uri redirect-uri)))))) + +(define* (request client subject issuer + #:key + (http-request http-request)) + (setup-headers!) (match client (($ <client> client-id client-key redirect-uri) (let ((do-login diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 4fb16b5..d7219e3 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -208,18 +208,6 @@ `(,account ,@parsed-accounts)))) ((*TOP* (disfluid:accounts - (disfluid:account - ;; the subject is not set yet - (@ (issuer ,issuer)) - ,arguments ...) - ,other-accounts ...)) - (let ((account (load-account-arguments - #f (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)) @@ -246,9 +234,7 @@ (when (string? issuer) (set! issuer (string->uri issuer))) `(account - (@ ,@(if subject - `((subject ,(uri->string subject))) - '()) + (@ (subject ,(uri->string subject)) (issuer ,(uri->string issuer))) ,@(if id-token `((id-token (@ (alg ,(symbol->string (id:id-token-alg id-token))) diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index c0162de..16e19ae 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -43,16 +43,17 @@ #:use-module (rnrs bytevectors) #:declarative? #t) +(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 (main) (define (do-the-trick subject issuer) - (client:request - (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")) - 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)) @@ -64,34 +65,32 @@ (and subject (uri->string subject))) (format #f (G_ "a new user"))) (uri->string (client:account-issuer (vector-ref accounts i))) - (if (client:account-subject (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)")))) - (format #f (G_ "status|not initialized yet")))) + (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. ")) - (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))) - (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)))) + (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 @@ -117,28 +116,28 @@ (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:make-account #f (string->uri issuer) #f #f #f #f)))) - (main)) - ((? eof-object? _) - (exit 0)) - (else - (main))))) + (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) |