summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/client.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/scm/webid-oidc/client.scm')
-rw-r--r--src/scm/webid-oidc/client.scm291
1 files changed, 184 insertions, 107 deletions
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 6c1e368..9200332 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -20,6 +20,8 @@
#:use-module (webid-oidc oidc-id-token)
#:use-module (webid-oidc dpop-proof)
#:use-module (webid-oidc jwk)
+ #:use-module (webid-oidc client-manifest)
+ #:use-module (webid-oidc web-i18n)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module ((webid-oidc config) #:prefix cfg:)
@@ -43,6 +45,7 @@
#:use-module (ice-9 match)
#:use-module (sxml simple)
#:use-module (oop goops)
+ #:duplicates (merge-generics)
#:re-export
(
(client:<client> . <client>)
@@ -59,6 +62,8 @@
request
serve-application
+
+ <extended-client-manifest>
)
#:declarative? #t)
@@ -158,111 +163,183 @@
((kw value args ...)
(scan-arguments args headers `(,value ,kw ,@non-header-args) method)))))
-(define* (serve-application id redirect-uri
- #:key
- (client-name "Example application")
- (client-uri "https://webid-oidc-demo.planete-kraus.eu"))
- (when (string? id)
- (set! id (string->uri id)))
- (when (string? redirect-uri)
- (set! redirect-uri (string->uri redirect-uri)))
- (when (string? client-uri)
- (set! client-uri (string->uri client-uri)))
- (let* ((manifest
- (format #f
- "{
- \"@context\": \"https://www.w3.org/ns/solid/oidc-context.jsonld\",
- \"client_id\" : \"~a\",
- \"redirect_uris\" : [\"~a\"],
- \"client_name\" : \"~a\",
- \"client_uri\" : \"~a\",
- \"grant_types\" : [\"refresh_token\", \"authorization_code\"],
- \"response_types\" : [\"code\"]
-}
-"
- (uri->string id)
- (uri->string redirect-uri)
- client-name
- (uri->string id)))
- (manifest-etag (stubs:hash 'SHA-256 manifest)))
+(define-class <extended-client-manifest> (<client-manifest>)
+ (client-name #:init-keyword #:client-name #:accessor client-name)
+ (client-uri #:init-keyword #:client-uri #:accessor client-uri)
+ (grant-types #:init-keyword #:grant-types #:accessor grant-types)
+ (response-types #:init-keyword #:response-types #:accessor response-types)
+ #:module-name '(webid-oidc client))
+
+(define-method (initialize (client <extended-client-manifest>) initargs)
+ (next-method)
+ (let-keywords
+ initargs #t
+ ((client-name (G_ "Example application"))
+ (client-uri "https://webid-oidc-demo.planete-kraus.eu")
+ (grant-types '(refresh_token authorization_code))
+ (response-types '(code)))
+ (let fix-grant-types ((grant-types grant-types)
+ (ok '()))
+ (match grant-types
+ (()
+ (let ((grant-types (reverse ok)))
+ (let fix-response-types ((response-types response-types)
+ (ok '()))
+ (match response-types
+ (()
+ (let ((response-types (reverse ok)))
+ (let fix-client-uri ((client-uri client-uri))
+ (match client-uri
+ ((? uri? client-uri)
+ (let fix-client-name ((client-name client-name))
+ (match client-name
+ ((? string? client-name)
+ (begin
+ (slot-set! client 'client-name client-name)
+ (slot-set! client 'client-uri client-uri)
+ (slot-set! client 'grant-types grant-types)
+ (slot-set! client 'response-types response-types)))
+ (else
+ (scm-error 'wrong-type-arg "make"
+ (G_ "#:client-name should be a string")
+ '()
+ (list client-name))))))
+ ((? string? (= string->uri (? uri? client-uri)))
+ (fix-client-uri client-uri))
+ (else
+ (scm-error 'wrong-type-arg "make"
+ (G_ "#:client-uri should be an URI")
+ '()
+ (list client-uri)))))))
+ (((or (? string? (= string->symbol hd))
+ (? symbol? hd))
+ response-types ...)
+ (fix-response-types response-types `(,hd ,@ok)))
+ (else
+ (scm-error 'wrong-type-arg "make"
+ (G_ "#:response-types should be a list of symbols")
+ '()
+ (list response-types)))))))
+ (((or (? string? (= string->symbol hd))
+ (? symbol? hd))
+ grant-types ...)
+ (fix-grant-types grant-types `(,hd ,@ok)))
+ (else
+ (scm-error 'wrong-type-arg "make"
+ (G_ "#:grant-types should be a list of symbols")
+ '()
+ (list grant-types)))))))
+
+(define-method (->json-data (client <extended-client-manifest>))
+ (let ((other
+ (catch 'goops-error
+ (lambda ()
+ (next-method))
+ (lambda _
+ '()))))
+ (let ((all
+ `((client_name . ,(client-name client))
+ (client_uri . ,(uri->string (client-uri client)))
+ (grant_types . ,(list->vector (map symbol->string (grant-types client))))
+ (response_types . ,(list->vector (map symbol->string (response-types client))))
+ ,@other)))
+ ;; Put @context first
+ (receive (context non-context)
+ (let search-context ((fields all)
+ (context-ones '())
+ (non-context-ones '()))
+ (match fields
+ ((('@context . ,context) fields ...)
+ (search-context fields `(,context ,@context-ones) non-context-ones))
+ ((non-context fields ...)
+ (search-context fields context-ones `(,non-context ,@non-context-ones)))
+ (()
+ (values (reverse context-ones) (reverse non-context-ones)))))
+ (append
+ (map (lambda (ctx) `(@context . ,ctx)) context)
+ non-context)))))
+
+(define* (serve-application id redirect-uri . args)
+ (let ((manifest (apply make <extended-client-manifest>
+ #:client-id id
+ #:redirect-uris (list redirect-uri)
+ args)))
(lambda (request request-body)
- (let ((uri (request-uri request)))
- (cond
- ((equal? (uri-path uri) (uri-path id))
- (let ((if-none-match (request-if-none-match request)))
- (if (and (list? if-none-match)
- (member manifest-etag
- (map car (request-if-none-match request))))
- (values
- (build-response
- #:code 304
- #:reason-phrase "Not Modified"
- #:headers `((content-type application/ld+json)
- (etag . (,manifest-etag . #t))))
- #f)
- (values
- (build-response
- #:headers `((content-type application/ld+json)
- (etag . (,manifest-etag . #t))
- (cache-control public must-revalidate)))
- manifest))))
- ((equal? (uri-path uri) (uri-path redirect-uri))
- (let ((query-args
- (map
- (lambda (key=value)
- (let ((splits
- (map uri-decode (string-split key=value #\=))))
- (if (or (null? splits) (null? (cdr splits)))
- splits
- (cons (string->symbol (car splits)) (cdr splits)))))
- (string-split (uri-query uri) #\&))))
- (let ((code (assq-ref query-args 'code)))
- (if code
- (values
- (build-response
- #:headers `((content-type application/xhtml+xml)))
- (with-output-to-string
- (lambda ()
- (sxml->xml
- `(*TOP*
- (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang "en"))
- (head
- (title "Authorization"))
- (body
- (p "You have been authorized. Please paste the following code in the application:")
- (p (strong ,code)))))))))
- (values
- (build-response
- #:code 400
- #:reason-phrase "Invalid Request"
- #:headers `((content-type application/xhtml+xml)))
- (with-output-to-string
- (lambda ()
- (sxml->xml
- `(*TOP*
- (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang "en"))
- (head
- (title "Error"))
- (body
- (p "Your identity provider did not authorize you. :("))))))))))))
- (else
- (values
- (build-response
- #:code 404
- #:reason-phrase "Not Found"
- #:headers `((content-type application/xhtml+xml)))
- (with-output-to-string
- (lambda ()
- (sxml->xml
- `(*TOP*
- (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang "en"))
- (head
- (title "Not Found"))
- (body
- (p "This page does not exist on the server."))))))))))))))
+ (parameterize ((web-locale request))
+ (let ((uri (request-uri request)))
+ (cond
+ ((equal? (uri-path uri) (uri-path id))
+ (receive (response response-body) (serve manifest #f)
+ (let ((if-none-match (request-if-none-match request))
+ (etag (response-etag response)))
+ (if (and (list? if-none-match)
+ etag
+ (member (car etag) (map car if-none-match)))
+ (values
+ (build-response
+ #:code 304
+ #:reason-phrase (W_ "reason-phrase|Not Modified")
+ #:headers `((content-type application/ld+json)
+ (etag . ,etag)))
+ #f)
+ (values response response-body)))))
+ ((equal? (uri-path uri) (uri-path redirect-uri))
+ (let ((query-args
+ (map
+ (lambda (key=value)
+ (let ((splits
+ (map uri-decode (string-split key=value #\=))))
+ (if (or (null? splits) (null? (cdr splits)))
+ splits
+ (cons (string->symbol (car splits)) (cdr splits)))))
+ (string-split (uri-query uri) #\&))))
+ (let ((code (assq-ref query-args 'code)))
+ (if code
+ (values
+ (build-response
+ #:headers `((content-type application/xhtml+xml)))
+ (with-output-to-string
+ (lambda ()
+ (sxml->xml
+ `(*TOP*
+ (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+ (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+ (xml:lang ,(W_ "xml-lang|en")))
+ (head
+ (title ,(W_ "page-title|Authorization")))
+ (body
+ (p ,(W_ "You have been authorized. Please paste the following code in the application:"))
+ (p (strong ,code)))))))))
+ (values
+ (build-response
+ #:code 400
+ #:reason-phrase (W_ "reason-phrase|Invalid Request")
+ #:headers `((content-type application/xhtml+xml)))
+ (with-output-to-string
+ (lambda ()
+ (sxml->xml
+ `(*TOP*
+ (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+ (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+ (xml:lang ,(W_ "xml-lang|en")))
+ (head
+ (title ,(W_ "page-title|Error")))
+ (body
+ (p ,(W_ "Your identity provider did not authorize you. :(")))))))))))))
+ (else
+ (values
+ (build-response
+ #:code 404
+ #:reason-phrase (W_ "reason-phrase|Not Found")
+ #:headers `((content-type application/xhtml+xml)))
+ (with-output-to-string
+ (lambda ()
+ (sxml->xml
+ `(*TOP*
+ (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+ (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+ (xml:lang ,(W_ "xml-lang|en")))
+ (head
+ (title ,(W_ "page-title|Not Found")))
+ (body
+ (p ,(W_ "This page does not exist on the server."))))))))))))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-06-02 06:35:14 +0000