diff options
Diffstat (limited to 'src/scm/webid-oidc/example-app.scm')
| -rw-r--r-- | src/scm/webid-oidc/example-app.scm | 288 |
1 files changed, 104 insertions, 184 deletions
diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index f0fcdd3..d6ef2a0 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -15,25 +15,30 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc example-app) - #:use-module (webid-oidc client) + #:use-module ((webid-oidc client) #:prefix client:) + #:use-module ((webid-oidc client accounts) #:prefix client:) #:use-module (webid-oidc errors) #:use-module ((webid-oidc cache) #:prefix cache:) #:use-module (webid-oidc dpop-proof) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module (web uri) #:use-module (web client) + #:use-module (web request) #:use-module (web response) #:use-module (web server) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (srfi srfi-19) #:use-module (ice-9 i18n) + #:use-module (srfi srfi-26) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) #:use-module (ice-9 textual-ports) #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) #:use-module (sxml simple) #:use-module (rnrs bytevectors)) @@ -44,187 +49,102 @@ (car (reverse (string-split text #\|))) out))) -(define (enumerate-profiles profiles) - (define (aux i) - (when (< i (vector-length profiles)) - (let ((prof (vector-ref profiles i))) - (format #t (G_ "~a.\t~a, certified by ~a;\n") - (+ i 1) - (uri->string (car prof)) - (uri->string (cadr prof)))) - (aux (+ i 1)))) - (aux 0)) - -(define (enumerate-providers providers) - (define (aux i) - (when (< i (vector-length providers)) - (let ((prov (vector-ref providers i))) - (format #t (G_ "~a – ~a\n") - (+ i 1) - (prov))) - (aux (+ i 1)))) - (aux 0)) - -(define (select-choice mini maxi question) - (format #t "~a" question) - (let* ((line - (read-line (current-input-port) 'trim)) - (number (false-if-exception (string->number line)))) - (cond - ((eof-object? line) - (exit 0)) - ((and (integer? number) - (>= number mini) - (<= number maxi)) - number) - (else - (format #t (G_ "I’m expecting a number between ~a and ~a.\n") - mini maxi) - (select-choice mini maxi question))))) - -(define cache-http-get (cache:with-cache)) - -(define (inner-main-loop http-request) - (format #t (G_ "Please enter an URI to GET: ")) - (let ((line (read-line (current-input-port) 'trim))) - (unless (eof-object? line) - (let ((uri (string->uri line))) - (receive (response response-body) - (http-request uri) - (let ((write-body - (write-response response (current-output-port)))) - (when (string? response-body) - (set! response-body (string->utf8 response-body))) - (when response-body - (write-response-body write-body response-body))))) - (inner-main-loop http-request)))) - -(define (main-loop id-token access-token key) - (let ((my-http-request - (make-client id-token access-token key - #:http-request - (lambda args - (format (current-error-port) (G_ "Sending a request: ~s\n") args) - (apply http-request args))))) - (inner-main-loop my-http-request))) - -(define-public (inner-main) - (setlocale LC_ALL "") - (bindtextdomain cfg:package cfg:localedir) - (textdomain cfg:package) - (let ((version-sym - (string->symbol (G_ "command-line|version"))) - (help-sym - (string->symbol (G_ "comand-line|help")))) - (let ((options - (let ((option-spec - `((,version-sym (single-char #\v) (value #f)) - (,help-sym (single-char #\h) (value #f))))) - (getopt-long (command-line) option-spec)))) - (cond - ((option-ref options help-sym #f) - (format #t (G_ "Usage: ~a [OPTIONS]... - -Demonstrate a webid-oidc application. - -Options: - -h, --~a: - display this help message and exit. - -v, --~a: - display the version information (~a) and exit. - -Environment variables: - - LANG: set the locale. Currently ~a. - - XDG_CACHE_HOME: where the seed for the key generator is -stored. Currently ~a. - - XDG_DATA_HOME: where the login credentials are stored. Currently ~a. - - HOME: to compute a default value for XDG_CACHE_HOME and -XDG_DATA_HOME, if missing. Currently ~a. - -If you find a bug, send a report to ~a. -") - (car (command-line)) - help-sym version-sym - cfg:version - (or (getenv "LANG") "") - (or (getenv "XDG_CACHE_HOME") "") - (or (getenv "XDG_DATA_HOME") "") - (or (getenv "HOME") "") - cfg:package-bugreport)) - ((option-ref options version-sym #f) - (format #t (G_ "~a version ~a\n") - cfg:package cfg:version)) - (else - (let ((profiles (list->vector (list-profiles)))) - (format #t (G_ "First, let’s log in. Here are your options:\n")) - (enumerate-profiles profiles) - (format #t (G_ "0.\tLog in with a different identity.\n")) - (let ((i-profile - (select-choice - 0 - (vector-length profiles) - (G_ "Please indicate your choice number: ")))) - (receive (id-token access-token key) - (if (eqv? i-profile 0) - (setup - (lambda () - (format #t (G_ "Please enter your webid, or identity server: ")) - (read-line (current-input-port) 'trim)) - (lambda (providers) - (cond - ((null? providers) - (error "No, this cannot happen.")) - ((null? (cdr providers)) - (car providers)) - (else - (set! providers (list->vector providers)) - (format #t (G_ "There are different possible identity providers for your webid:\n")) - (enumerate-providers providers) - (let ((i-provider - (select-choice 1 (- (vector-length providers) 1) - (G_ "Please indicate your choice number: ")))) - (vector-ref providers i-provider))))) - (lambda (uri) - (format #t (G_ "Please visit the following URI with a web browser:\n~a\n") - (uri->string uri)) - (format #t (G_ "Please paste your authorization code: ")) - (read-line (current-input-port) 'trim)) - #:client-id "https://webid-oidc-demo.planete-kraus.eu/example-application#id" - #:redirect-uri "https://webid-oidc-demo.planete-kraus.eu/authorized" - #:http-get cache-http-get) - (let ((profile (vector-ref profiles (- i-profile 1)))) - (let ((webid (car profile)) - (issuer (cadr profile)) - (refresh-token (caddr profile)) - (key (cadddr profile))) - (login webid issuer refresh-token key #:http-get cache-http-get)))) - (format #t (G_ "Log in success. Keep this identity token for yourself: - -~a - -Now, you can do authenticated request by presenting the following access token: - -~a - -and signing DPoP proofs with the following key: - -~a +(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)) + (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 ") - (stubs:scm->json-string id-token #:pretty #t) - access-token - (stubs:scm->json-string key #:pretty #t)) - (main-loop id-token access-token key))))))))) - -(define-public (main) - (with-exception-handler - (lambda (error) - (format (current-error-port) - (G_ "There was an error: ~a\n") - (error->str error))) - (lambda () - (inner-main)) - #:unwind? #t)) + (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-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")))) + (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)))) + (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:make-account #f (string->uri issuer) #f #f #f #f)))) + (main)) + ((? eof-object? _) + (exit 0)) + (else + (main))))) + +(main) |