diff options
Diffstat (limited to 'src/scm')
| -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 |
3 files changed, 88 insertions, 76 deletions
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) |