1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
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))
|
