blob: c0162de41a4c2923442fef27ea42296f8bed3050 (
plain)
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
|
;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (webid-oidc example-app)
#:use-module ((webid-oidc client) #:prefix client:)
#:use-module ((webid-oidc client accounts) #:prefix client:)
#:use-module ((webid-oidc cache) #:prefix cache:)
#:use-module (webid-oidc dpop-proof)
#:use-module (webid-oidc web-i18n)
#: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 (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 (ice-9 exceptions)
#:use-module (sxml simple)
#:use-module (rnrs bytevectors)
#:declarative? #t)
(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
")
(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)
|
