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.scm275
1 files changed, 274 insertions, 1 deletions
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index ef0d116..6fe9cc2 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -7,15 +7,21 @@
#:use-module (webid-oidc jwk)
#: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 request)
#:use-module (web response)
#:use-module (web server)
#:use-module (web http)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-19)
- #:use-module (rnrs bytevectors))
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 i18n)
+ #:use-module (ice-9 getopt-long)
+ #:use-module (ice-9 suspendable-ports)
+ #:use-module (sxml simple))
(define*-public (authorize host-or-webid
#:key
@@ -486,3 +492,270 @@
(parse-args uri 'GET '() '() args))
(lambda (uri . args)
(parse-http-request-args uri args)))
+
+(define*-public (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
+ "@prefix solid: <http://www.w3.org/ns/solid/terms#> .
+
+<~a> solid:oidcRegistration \"\"\"{
+ \"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 id)
+ (uri->string redirect-uri)
+ client-name
+ (uri->string id)))
+ (manifest-etag (stubs:hash 'SHA-256 manifest)))
+ (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 text/turtle)
+ (etag . (,manifest-etag . #t))))
+ #f)
+ (values
+ (build-response
+ #:headers `((content-type text/turtle)
+ (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."))))))))))))))
+
+(define (G_ text)
+ (let ((out (gettext text)))
+ (if (string=? out text)
+ ;; No translation, disambiguate
+ (car (reverse (string-split text #\|)))
+ out)))
+
+(define-public (main-server)
+ (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")))
+ (client-id-sym
+ (string->symbol (G_ "comand-line|client-id")))
+ (redirect-uri-sym
+ (string->symbol (G_ "comand-line|redirect-uri")))
+ (client-name-sym
+ (string->symbol (G_ "comand-line|client-name")))
+ (client-uri-sym
+ (string->symbol (G_ "comand-line|client-uri")))
+ (port-sym
+ (string->symbol (G_ "comand-line|port")))
+ (log-file-sym
+ (string->symbol (G_ "comand-line|log-file")))
+ (error-file-sym
+ (string->symbol (G_ "comand-line|error-file"))))
+ (let ((options
+ (let ((option-spec
+ `((,version-sym (single-char #\v) (value #f))
+ (,help-sym (single-char #\h) (value #f))
+ (,client-id-sym (single-char #\i) (value #t))
+ (,redirect-uri-sym (single-char #\r) (value #t))
+ (,client-name-sym (single-char #\n) (value #t))
+ (,client-uri-sym (single-char #\u) (value #t))
+ (,port-sym (single-char #\p) (value #t))
+ (,log-file-sym (single-char #\l) (value #t))
+ (,error-file-sym (single-char #\e) (value #t)))))
+ (getopt-long (command-line) option-spec))))
+ (cond
+ ((option-ref options help-sym #f)
+ (format #t (G_ "Usage: ~a [OPTIONS]...
+
+Serve public pages for an application.
+
+Options:
+ -h, --~a:
+ display this help message and exit.
+ -v, --~a:
+ display the version information (~a) and exit.
+ -i URI, --~a=URI:
+ set the webid of the client.
+ -r FILE, --~a=URI:
+ set the redirection URI where to get the authorization code.
+ -n NAME, --~a=NAME:
+ set the name of the application.
+ -u URI, --~a=URI:
+ set the address of the application (informative).
+ -p PORT, --~a=PORT:
+ set the port to bind (instead of 8080).
+ -l FILE.log, --~a=FILE.log:
+ dump the standard output to that file.
+ -e FILE.err, --~a=FILE.err:
+ dump the standard error to that file.
+
+Environment variables:
+
+ LANG: set the locale of the sysadmin-facing interface, for log files
+and command-line interface. It is currently ~a.
+
+Example used in webid-oidc-demo.planete-kraus.eu (except it’s managed
+by shepherd in reality):
+
+ export LANG=C
+ webid-oidc-client-service \\
+ --client-id 'https://webid-oidc-demo.planete-kraus.eu/example-application#id' \\
+ --redirect-uri 'https://webid-oidc-demo.planete-kraus.eu/authorized' \\
+ --client-name 'Example Solid Application' \\
+ --client-uri 'https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client' \\
+ --port $PORT
+
+If you find a bug, send a report to ~a.
+")
+ (car (command-line))
+ help-sym version-sym
+ cfg:version
+ client-id-sym redirect-uri-sym client-name-sym client-uri-sym port-sym
+ log-file-sym error-file-sym
+ (or (getenv "LANG") "")
+ cfg:package-bugreport))
+ ((option-ref options version-sym #f)
+ (format #t (G_ "~a version ~a\n")
+ cfg:package cfg:version))
+ (else
+ (let ((client-id (option-ref options client-id-sym #f))
+ (redirect-uri (option-ref options redirect-uri-sym #f))
+ (client-name (option-ref options client-name-sym "Example Solid App"))
+ (client-uri
+ (option-ref options client-uri-sym
+ "https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client"))
+ (port-string
+ (option-ref options port-sym "8080"))
+ (log-file-string
+ (option-ref options log-file-sym #f))
+ (error-file-string
+ (option-ref options error-file-sym #f)))
+ (when log-file-string
+ (set-current-output-port (stubs:open-output-file* log-file-string))
+ (setvbuf (current-output-port) 'none))
+ (when error-file-string
+ (set-current-error-port (stubs:open-output-file* error-file-string))
+ (setvbuf (current-error-port) 'none))
+ (unless (and client-id (string->uri client-id))
+ (format (current-error-port)
+ (G_ "You need to set the client ID as an URI.\n"))
+ (exit 1))
+ (unless (and redirect-uri (string->uri redirect-uri))
+ (format (current-error-port)
+ (G_ "You need to set the redirect URI.\n"))
+ (exit 2))
+ (unless (string->uri client-uri)
+ (format (current-error-port)
+ (G_ "The client URI should be an URI.\n"))
+ (exit 3))
+ (unless (and (string->number port-string)
+ (integer? (string->number port-string))
+ (>= (string->number port-string) 0)
+ (<= (string->number port-string) 65535))
+ (format (current-error-port)
+ (G_ "The port should be a number between 0 and 65535.\n"))
+ (exit 1))
+ (let ((handler
+ (serve-application client-id redirect-uri
+ #:client-name client-name
+ #:client-uri client-uri)))
+ (let ((handler-with-log
+ (lambda (request request-body)
+ (with-exception-handler
+ (lambda (error)
+ (format (current-error-port)
+ (G_ "~a: Internal server error: ~a\n")
+ (date->string (time-utc->date (current-time)))
+ (error->str error))
+ (values
+ (build-response #:code 500
+ #:reason-phrase "Internal Server Error")
+ "Sorry, there was an error."))
+ (lambda ()
+ (handler request request-body))
+ #:unwind? #t))))
+ (install-suspendable-ports!)
+ (run-server handler 'http
+ (list #:port (string->number port-string)))))))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-29 03:19:45 +0000