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.

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 ""
 
diff --git a/po/fr.po b/po/fr.po
index 0ed04df..3a1a77f 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -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)