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.scm202
1 files changed, 30 insertions, 172 deletions
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 5322af1..ee0b72c 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -22,6 +22,8 @@
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc client-manifest)
#:use-module (webid-oidc web-i18n)
+ #:use-module (webid-oidc server endpoint)
+ #:use-module (webid-oidc server endpoint client)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module ((webid-oidc config) #:prefix cfg:)
@@ -168,183 +170,39 @@
((kw value args ...)
(scan-arguments args headers `(,value ,kw ,@non-header-args) method)))))
-(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>
+ (let ((endpoint (apply make <client-id>
#:client-id id
#:redirect-uris (list redirect-uri)
args)))
(lambda (request request-body)
- (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
+ (with-exception-handler
+ (lambda (exn)
+ (unless (web-exception? exn)
+ (raise-exception exn))
(values
(build-response
- #:code 404
- #:reason-phrase (W_ "reason-phrase|Not Found")
+ #:code (web-exception-code exn)
+ #:reason-phrase (web-exception-reason-phrase exn)
#: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."))))))))))))))))
+ (call-with-output-string
+ (cute 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")))
+ (body
+ ,(call-with-input-string
+ (format #f (W_ "<h1>The request failed</h1>"))
+ xml->sxml)
+ ,(if (user-message? exn)
+ (user-message-sxml exn)
+ (call-with-input-string
+ (format #f (W_ "<p>No more information.</p>"))
+ xml->sxml)))))
+ <>))))
+ (lambda ()
+ (receive (response response-body response-meta)
+ (handle endpoint request request-body)
+ (values response response-body)))
+ #:unwind? #t))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-18 12:56:27 +0000