diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-17 07:44:20 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-13 20:18:04 +0200 |
commit | 67eaa758f8b86353920c4b7cbb66cbb9b4fd6e7c (patch) | |
tree | 6e963338eb558489bb4a734dd8da02602bd82974 | |
parent | c4325da48fa86b6555062395870f29a7f9f67813 (diff) |
Don’t save an account if it does not have a subject
I added a function to log in for the first time, so that we don’t have
to store an account for which we know we will need to jump through the
authorization endpoint hoops.
-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) |