From 7b97db1634394f90e653d0cd25bc45ce770b10f3 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Wed, 5 May 2021 15:22:01 +0200 Subject: Add a server for an application --- src/Makefile.am | 2 +- src/scm/webid-oidc/client.scm | 275 +++++++++++++++++++++++++++++++++++++++++- src/webid-oidc-client-service | 7 ++ 3 files changed, 282 insertions(+), 2 deletions(-) create mode 100755 src/webid-oidc-client-service (limited to 'src') diff --git a/src/Makefile.am b/src/Makefile.am index d990641..527f201 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -1,6 +1,6 @@ lib_LTLIBRARIES += %reldir%/libwebidoidc.la -dist_bin_SCRIPTS += %reldir%/webid-oidc-issuer %reldir%/webid-oidc-reverse-proxy %reldir%/webid-oidc-hello +dist_bin_SCRIPTS += %reldir%/webid-oidc-issuer %reldir%/webid-oidc-reverse-proxy %reldir%/webid-oidc-hello %reldir%/webid-oidc-client-service AM_CPPFLAGS += -I %reldir% -I $(srcdir)/%reldir% 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: . + +<~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))))))))))) diff --git a/src/webid-oidc-client-service b/src/webid-oidc-client-service new file mode 100755 index 0000000..1139abd --- /dev/null +++ b/src/webid-oidc-client-service @@ -0,0 +1,7 @@ +#!/usr/local/bin/guile \ +--no-auto-compile -s +!# + +(use-modules (webid-oidc client)) + +(main-server) -- cgit v1.2.3