diff options
Diffstat (limited to 'src/scm/webid-oidc/server/endpoint/client.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/endpoint/client.scm | 166 |
1 files changed, 166 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/endpoint/client.scm b/src/scm/webid-oidc/server/endpoint/client.scm new file mode 100644 index 0000000..ffa93c3 --- /dev/null +++ b/src/scm/webid-oidc/server/endpoint/client.scm @@ -0,0 +1,166 @@ +;; disfluid, implementation of the Solid specification +;; Copyright (C) 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 server endpoint client) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc provider-confirmation) + #:use-module (webid-oidc client-manifest) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (web server) + #:use-module (web client) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (webid-oidc web-i18n) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (sxml simple) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (oop goops) + #:duplicates (merge-generics) + #:declarative? #t + #:re-export + ( + client-id + redirect-uris + ) + #:export + ( + <client-id> + client-name + client-uri + grant-types + response-types + + <redirect-uri> + )) + +(define-class <client-id> (<endpoint> <client-manifest>) + (client-name #:init-keyword #:client-name #:getter client-name) + (client-uri #:init-keyword #:client-uri #:getter client-uri) + (grant-types #:init-keyword #:grant-types #:getter grant-types) + (response-types #:init-keyword #:response-types #:getter response-types) + #:module-name '(webid-oidc server endpoint client)) + +(define-method (initialize (c <client-id>) initargs) + (next-method) + (let-keywords + initargs #t + ((client-name (G_ "Example Solid Application")) + (client-uri (string->uri "https://disfluid.planete-kraus.eu")) + (grant-types '(refresh_token authorization_code)) + (response-types '(code))) + (match client-uri + ((? string? (= string->uri (? uri? client-uri))) + (slot-set! c 'client-uri client-uri)) + ((? uri?) + #t) + (else + (scm-error 'wrong-type-arg "make <client-id>" + (G_ "#:client-uri should be an URI") + '() + (list client-uri)))) + (let ((fix-symbol-list + (lambda (items what) + (let fix ((values items) + (fixed '()) + (index 0)) + (match values + ((? vector? x) + (fix (vector->list x) fixed index)) + (() + (slot-set! c what (reverse fixed))) + (((or (? string? (= string->symbol value)) + (? symbol? value)) + values ...) + (fix values `(,value @fixed) (+ index 1))) + ((wrong _ ...) + (scm-error 'wrong-type-arg "make <client-id>" + (format #f (G_ "#:~a element ~a should be a string or a symbol") + what index) + '() + (list wrong))) + (else + (scm-error 'wrong-type-arg "make <client-id>" + (format #f (G_ "#:~a should be a list") + what + '() + (list wrong))))))))) + (fix-symbol-list grant-types 'grant-types) + (fix-symbol-list response-types 'response-types)))) + +(define-method (handle (endpoint <client-id>) request request-body) + (receive (response response-body) (serve endpoint #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 '()))))) + +(define-class <redirect-uri> (<endpoint>)) + +(define-method (handle (endpoint <redirect-uri>) request request-body) + (let ((query-args + (apply + append + (map + (lambda (key=value) + (match (map uri-decode (string-split key=value #\=)) + ((key value) + `((,key . ,value))) + (else '()))) + (string-split (uri-query (request-uri request)) #\&))))) + (let ((code (assq-ref query-args 'code))) + (if code + (values + (build-response + #:headers `((content-type applicationn/xhtml+xml))) + (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"))) + (head + (title ,(W_ "page-title|Authorization"))) + (body + (p ,(W_ "You have been authorized. Please paste the following code in the application:")) + (p (strong ,code))))) + <>)) + '()) + ;; No code: + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Invalid Request")) + (make-user-message + `(p ,(W_ "This page should obtain a code from your identity provider, but none has been provided."))))))))) |