summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/example-app.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/scm/webid-oidc/example-app.scm')
-rw-r--r--src/scm/webid-oidc/example-app.scm212
1 files changed, 212 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm
new file mode 100644
index 0000000..ec92fb9
--- /dev/null
+++ b/src/scm/webid-oidc/example-app.scm
@@ -0,0 +1,212 @@
+(define-module (webid-oidc example-app)
+ #:use-module (webid-oidc 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 (web uri)
+ #:use-module (web client)
+ #: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 (ice-9 getopt-long)
+ #:use-module (ice-9 suspendable-ports)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (sxml simple)
+ #:use-module (rnrs bytevectors))
+
+(define (G_ text)
+ (let ((out (gettext text)))
+ (if (string=? out text)
+ ;; No translation, disambiguate
+ (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, --help:
+ display this help message and exit.
+ -v, --version:
+ 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))
+ 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)))
+ (login webid issuer refresh-token #: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
+")
+ (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))
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-18 22:02:40 +0000