;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 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 .
(define-module (webid-oidc program)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc server log)
#:use-module (webid-oidc reverse-proxy)
#:use-module (webid-oidc identity-provider)
#:use-module (webid-oidc client)
#:use-module (webid-oidc resource-server)
#:use-module (webid-oidc server create)
#:use-module (webid-oidc jti)
#:use-module (webid-oidc offloading)
#:use-module (webid-oidc catalog)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (ice-9 i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 control)
#:use-module (ice-9 threads)
#:use-module (ice-9 futures)
#:use-module (srfi srfi-19)
#:use-module (rnrs bytevectors)
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
#:use-module (web client)
#:use-module (webid-oidc cache)
#:use-module (web server))
(define (G_ text)
(let ((out (gettext text)))
(if (string=? out text)
;; No translation, disambiguate
(car (reverse (string-split text #\|)))
out)))
(define logging-mutex (make-mutex))
(define* (http-get-with-log uri #:key (headers '()))
(define date (date->string (time-utc->date (current-time))))
(define uri-string (if (uri? uri) (uri->string uri) uri))
(with-mutex logging-mutex
(when (getenv "XML_CATALOG_FILES")
(format (current-error-port) "~a: Warning: XML_CATALOG_FILES is set to ~s.\n"
date
(getenv "XML_CATALOG_FILES")))
(format (current-error-port) "~a: GET ~a ~s...\n"
date uri-string headers))
(set! uri (resolve-uri uri
#:http-get
(lambda* (uri . args)
(with-mutex logging-mutex
(format (current-error-port) "~a: Warning: loading XML catalog from the web, ~s.\n"
date
(uri->string uri)))
(apply http-get uri args))))
(receive (response response-body)
(in-another-thread
(http-get uri #:headers headers))
(with-mutex logging-mutex
(format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n"
date uri-string headers response
(cond
((bytevector? response-body)
(bytevector-length response-body))
((string? response-body)
(string-length response-body))
(else 0))))
(values response response-body)))
(define cache-http-get
(with-cache
#:http-get http-get-with-log))
(define (request-ip-address request)
;; The IP address of the remote end
(let ((socket (request-port request)))
(let ((peer (getpeername socket)))
(let ((family (sockaddr:fam peer))
(address (sockaddr:addr peer)))
(inet-ntop family address)))))
(define (handler-with-log log-file error-file complete-corresponding-source handler)
(lambda (request request-body)
(when log-file
(prepare-log-file log-file))
(when error-file
(prepare-error-file error-file))
(call/ec
(lambda (return)
(with-exception-handler
(lambda (error)
(with-mutex logging-mutex
(format (current-error-port)
(G_ "~a: ~a: Internal server error: ~a\n")
(date->string (time-utc->date (current-time)))
(request-ip-address request)
(error->str error)))
(return
(build-response #:code 500
#:reason-phrase "Internal Server Error"
#:headers `((source . ,complete-corresponding-source)))
"Sorry, there was an error."))
(lambda ()
(with-exception-handler
(lambda (error)
(with-mutex logging-mutex
(format (current-error-port)
(G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n")
((record-accessor &unknown-client-locale 'web-locale) error)
((record-accessor &unknown-client-locale 'c-locale) error)
(error->str error))))
(lambda ()
(receive (response response-body user cause)
(call-with-values
(lambda ()
(handler request request-body))
(case-lambda
((response response-body)
(values response response-body #f #f))
((response response-body user)
(values response response-body user #f))
((response response-body user cause)
(values response response-body user cause))))
(let ((logging-port
(let ((response-code (response-code response)))
(if (>= response-code 400)
;; That’s an error
(current-error-port)
(current-output-port)))))
(with-mutex logging-mutex
(format logging-port
(G_ "~a: ~s ~a ~s ~a\n")
(if user
(format #f (G_ "~a: ~a (~a)")
(date->string (time-utc->date (current-time)))
(uri->string user)
(request-ip-address request))
(format #f (G_ "~a: ~a")
(date->string (time-utc->date (current-time)))
(request-ip-address request)))
(request-method request)
(uri-path (request-uri request))
(response-code response)
(if cause
(string-append
(response-reason-phrase response)
" "
(format #f (G_ "(there was an error: ~a)")
(error->str cause)))
(response-reason-phrase response)))))
(return
(build-response
#:version (response-version response)
#:code (response-code response)
#:reason-phrase (response-reason-phrase response)
#:headers (cons `(source . ,complete-corresponding-source)
(response-headers response))
#:port (response-port response)
#:validate-headers? #t)
response-body)))
#:unwind? #t
#:unwind-for-type &unknown-client-locale)))))))
(define (serve-one-client* handler implementation server state)
;; Same as serve-one-client, except it is served in a promise.
(call-with-values
(lambda ()
(read-client implementation server))
(lambda (client request body)
(future
(with-threads
(if client
(receive (response body state)
(handle-request handler request body state)
(write-client implementation server client response body)
state)
state))))))
(define* (run-server*
handler
#:optional
(implementation 'http)
(open-params '())
. state)
;; Same as the traditional run-server, but the requests are handled
;; in a future and the state is discarded.
(let* ((implementation (lookup-server-impl implementation))
(server (open-server implementation open-params)))
(let lp ()
(serve-one-client* handler implementation server state)
(lp))))
(define-public (main)
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'none)
(setlocale LC_ALL "")
(bindtextdomain cfg:package cfg:localedir)
(textdomain cfg:package)
(let ((version-sym
(string->symbol (G_ "command-line|version")))
(describe-project-sym
(string->symbol (G_ "command-line|describe-project")))
(complete-corresponding-source-sym
(string->symbol (G_ "command-line|complete-corresponding-source")))
(help-sym
(string->symbol (G_ "command-line|help")))
(port-sym
(string->symbol (G_ "command-line|server|port")))
(server-name-sym
(string->symbol (G_ "command-line|server|server-name")))
(backend-uri-sym
(string->symbol (G_ "command-line|server|reverse-proxy|backend-uri")))
(header-sym
(string->symbol (G_ "command-line|server|reverse-proxy|header")))
(key-file-sym
(string->symbol (G_ "command-line|server|issuer|key-file")))
(subject-sym
(string->symbol (G_ "command-line|server|issuer|subject")))
(encrypted-password-sym
(string->symbol (G_ "command-line|server|issuer|encrypted-password")))
(jwks-uri-sym
(string->symbol (G_ "command-line|server|issuer|jwks-uri")))
(authorization-endpoint-uri-sym
(string->symbol (G_ "command-line|server|issuer|authorization-endpoint-uri")))
(token-endpoint-uri-sym
(string->symbol (G_ "command-line|server|issuer|token-endpoint-uri")))
(client-id-sym
(string->symbol (G_ "command-line|server|client-id")))
(redirect-uri-sym
(string->symbol (G_ "command-line|server|redirect-uri")))
(client-name-sym
(string->symbol (G_ "command-line|server|client-name")))
(client-uri-sym
(string->symbol (G_ "command-line|server|client-uri")))
(log-file-sym
(string->symbol (G_ "command-line|log-file")))
(error-file-sym
(string->symbol (G_ "command-line|error-file")))
(locale-release-date
(strftime (locale-date-format)
(localtime (time-second (date->time-utc cfg:release-date))))))
(let ((options
(let ((spec
`((,complete-corresponding-source-sym (single-char #\S) (value #t))
(,version-sym (single-char #\v) (value #f))
(,describe-project-sym (value #f))
(,help-sym (single-char #\h) (value #f))
(,log-file-sym (single-char #\l) (value #t))
(,error-file-sym (single-char #\e) (value #t))
(,key-file-sym (single-char #\k) (value #t))
(,subject-sym (single-char #\s) (value #t))
(,encrypted-password-sym (single-char #\w) (value #t))
(,jwks-uri-sym (single-char #\j) (value #t))
(,authorization-endpoint-uri-sym (single-char #\a) (value #t))
(,token-endpoint-uri-sym (single-char #\t) (value #t))
(,client-id-sym (single-char #\c) (value #t))
(,redirect-uri-sym (single-char #\r) (value #t))
(,client-name-sym (single-char #\C) (value #t))
(,client-uri-sym (single-char #\u) (value #t))
(,port-sym (single-char #\p) (value #t))
(,server-name-sym (single-char #\n) (value #t))
(,header-sym (single-char #\H) (value #t))
(,backend-uri-sym (single-char #\b) (value #t)))))
(getopt-long (command-line) spec))))
(cond
((option-ref options help-sym #f)
(format #t (G_ "Usage: ~a COMMAND [OPTIONS]...
")
(car (command-line)))
(format #t (G_ "
Run the webid-oidc COMMAND."))
(format #t "\n")
(format #t (G_ "
This program is covered by the GNU Affero GPL, version 3 or
later. This license requires you to provide a way for any user over
the network to download the complete corresponding source code (with
your modifications) at no cost. The server adds a \"Source:\" header
to all responses."))
(format #t "\n")
(format #t (G_ "
Available commands:"))
(format #t (G_ "
~a:
run an authenticating reverse proxy.")
(G_ "command-line|command|reverse-proxy"))
(format #t (G_ "
~a:
run an identity provider.")
(G_ "command-line|command|identity-provider"))
(format #t (G_ "
~a:
serve the pages for a public application.")
(G_ "command-line|command|client-service"))
(format #t (G_ "
~a:
run a full server, with identity provider and resource storage
facility.")
(G_ "command-line|command|server"))
(format #t "\n")
(format #t (G_ "
General options:"))
(format #t (G_ "
-S MEANS, --~a=MEANS:
specify a way to download the complete corresponding source
code. For instance, this would be an URI pointing to a tarball.")
complete-corresponding-source-sym)
(format #t (G_ "
-h, --~a:
display a short help message and exit.")
help-sym)
(format #t (G_ "
-v, --~a:
display the version information (~a, released ~a) and exit.")
version-sym
cfg:version
locale-release-date)
(format #t (G_ "
--~a:
describe the project in the DOAP vocabulary and exit.")
describe-project-sym)
(format #t (G_ "
-l FILE.log, --~a=FILE.log:
redirect the program standard output to FILE.log.")
log-file-sym)
(format #t (G_ "
-e FILE.err, --~a=FILE.err:
redirect the program errors to FILE.err.")
error-file-sym)
(format #t "\n")
(format #t (G_ "
General server-side options:"))
(format #t (G_ "
-p PORT, --~a=PORT:
set the server port to bind, 8080 by default.")
port-sym)
(format #t (G_ "
-n URI, --~a=URI:
set the public server URI (scheme, userinfo, host, and port).")
server-name-sym)
(format #t "\n")
(format #t (G_ "
Options for the resource server:"))
(format #t (G_ "
-H HEADER, --~a=HEADER:
the HEADER field contains the webid of the authenticated user,
XXX-Agent by default. For the full server, disable webid-oidc
authentication.")
header-sym)
(format #t (G_ "
-b URI, --~a=URI:
set the backend URI for the reverse proxy, only for the
reverse-proxy command.")
backend-uri-sym)
(format #t "\n")
(format #t (G_ "
Options for the identity provider:"))
(format #t (G_ "
-k FILE, --~a=FILE.jwk:
set the file name of the key file. If it does not exist, a new
key is generated. The server does not offer an HTTPS service.")
key-file-sym)
(format #t (G_ "
-s WEBID, --~a=WEBID:
set the identity of the subject.")
subject-sym)
(format #t (G_ "
-w ENCRYPTED_PASSWORD, --~a=ENCRYPTED_PASSWORD:
set the encrypted password to recognize the user.")
encrypted-password-sym)
(format #t (G_ "
-j URI, --~a=URI:
set the URI to query the key of the server.")
jwks-uri-sym)
(format #t (G_ "
-a URI, --~a=URI:
set the authorization endpoint of the issuer.")
authorization-endpoint-uri-sym)
(format #t (G_ "
-t URI, --~a=URI:
set the token endpoint of the issuer.")
token-endpoint-uri-sym)
(format #t "\n")
(format #t (G_ "
Options for the client service:"))
(format #t (G_ "
-c URI, --~a=URI:
set the web identifier of the client application, which is
dereferenced to a semantic resource.")
client-id-sym)
(format #t (G_ "
-r URI, --~a=URI:
set the redirection URI to get the authorization code back. The
page is presented with the code to paste in the application.")
redirect-uri-sym)
(format #t (G_ "
-C NAME, --~a=NAME:
set the user-visible application name (may be misleading...).")
client-name-sym)
(format #t (G_ "
-u URI, --~a=URI:
set an URI where someone would find more information about the
application (again, may be misleading).")
client-uri-sym)
(format #t "\n")
(format #t (G_ "
Environment variables:"))
(format #t (G_ "
XML_CATALOG_FILES: the server will fetch resources on the web. By
setting this environment variable to a space-separated list of
catalog URIs, the server will redirect these requests to another
server. Currently, it is not possible to load files from the
file system, because there is no way to specify the
content-type."))
(when (getenv "XML_CATALOG_FILES")
(format #t (G_ "the-environment-variable|
It is currently set to ~s.")
(getenv "XML_CATALOG_FILES")))
(format #t (G_ "
LANG: set the locale of the user interface (for the server commands,
the user is the system administrator)."))
(when (getenv "LANG")
(format #t (G_ "the-environment-variable|
It is currently set to ~s.")
(getenv "LANG")))
(format #t (G_ "
XDG_DATA_HOME: where the program stores persistent data. The
identity provider stores the refresh tokens. The full server
stores the resources there. For a system service, it is
recommended to set it to /var/lib."))
(when (getenv "XDG_DATA_HOME")
(format #t (G_ "the-environment-variable|
It is currently set to ~s.")
(getenv "XDG_DATA_HOME")))
(format #t (G_ "
XDG_CACHE_HOME: where the program stores and updates the seed file,
and the web client cache. You can remove this directory at any
time. The seed file will be initialized from /dev/random."))
(when (getenv "XDG_CACHE_HOME")
(format #t (G_ "the-environment-variable|
It is currently set to ~s.")
(getenv "XDG_CACHE_HOME")))
(format #t (G_ "
HOME: if XDG_DATA_HOME or XDG_CACHE_HOME is not set, they are
computed from the value of the HOME environment variable. It is
not used otherwise."))
(when (getenv "HOME")
(format #t (G_ "the-environment-variable|
It is currently set to ~s.")
(getenv "HOME")))
(format #t "\n")
(format #t (G_ "
Running a reverse proxy"))
(format #t (G_ "
Suppose that you operate data.provider.com. You want to run an
authenticating reverse proxy, that will receive incoming requests
through http://localhost:8080, and forward them to
https://private.data.provider.com. The backend will look for the
XXX-Agent header, and if it is found, then its value will be
considered the webid of the authenticated
user. https://private.data.provider.com should only accept requests
from this reverse proxy."))
(format #t "\n")
(format #t (G_ "
~a ~a \\
--~a 'https://data.provider.com/server-source-code.tar.gz' \\
--~a 8080 \\
--~a 'https://data.provider.com' \\
--~a 'https://private.data.provider.com' \\
--~a 'XXX-Agent' \\
--~a '/var/log/proxy.log' \\
--~a '/var/log/proxy.err'")
(car (command-line))
(G_ "command-line|command|reverse-proxy")
complete-corresponding-source-sym
port-sym server-name-sym backend-uri-sym header-sym
log-file-sym error-file-sym)
(format #t "\n")
(format #t (G_ "
Running an identity provider"))
(format #t (G_ "
The identity provider running at webid-oidc-demo.planete-kraus.eu is
invoked with the following options:"))
(format #t "\n")
(format #t (G_ "
export XDG_DATA_HOME=/var/lib
export XDG_CACHE_HOME=/var/cache
~a ~a \\
--~a 'https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz' \\
--~a 'https://webid-oidc-demo.planete-kraus.eu' \\
--~a '/var/lib/webid-oidc/issuer/key.jwk' \\
--~a 'https://webid-oidc-demo.planete-kraus.eu/profile/card#me' \\
--~a \"$ENCRYPTED_PASSWORD\" \\
--~a 'https://webid-oidc-demo.planete-kraus.eu/keys' \\
--~a 'https://webid-oidc-demo.planete-kraus.eu/authorize' \\
--~a 'https://webid-oidc-demo.planete-kraus.eu/token' \\
--~a $PORT")
(car (command-line))
(G_ "command-line|command|identity-provider")
complete-corresponding-source-sym
server-name-sym key-file-sym subject-sym encrypted-password-sym
jwks-uri-sym authorization-endpoint-uri-sym
token-endpoint-uri-sym port-sym)
(format #t "\n")
(format #t (G_ "
Running the public pages for an application"))
(format #t (G_ "
The example client application pages for
webid-oidc-demo.planete-kraus.eu are served this way:"))
(format #t "\n")
(format #t (G_ "
~a ~a \\
--~a 'https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz' \\
--~a 'https://webid-oidc-demo.planete-kraus.eu/example-application#id' \\
--~a 'https://webid-oidc-demo.planete-kraus.eu/authorized' \\
--~a 'Example Solid Application' \\
--~a 'https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client' \\
--~a $PORT")
(car (command-line))
(G_ "command-line|command|client-service")
complete-corresponding-source-sym
client-id-sym redirect-uri-sym client-name-sym client-uri-sym
port-sym)
(format #t "\n")
(format #t (G_ "
Running a full server"))
(format #t "\n")
(format #t (G_ "
To run the server with identity provider and
resource server for one particular user, you need to combine the
options for the parts."))
(format #t (G_ "
export XDG_DATA_HOME=/var/lib
export XDG_CACHE_HOME=/var/cache
~a ~a \\
--~a 'https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz' \\
--~a 'https://data.planete-kraus.eu' \\
--~a '/var/lib/webid-oidc/server/key.jwk' \\
--~a 'https://data.planete-kraus.eu/vivien#me' \\
--~a '$...alg...$...salt...$...hash...' \\
--~a 'https://data.planete-kraus.eu/keys' \\
--~a 'https://data.planete-kraus.eu/authorize' \\
--~a 'https://data.planete-kraus.eu/token' \\
--~a '...port...'")
(car (command-line))
(G_ "command-line|command|server")
complete-corresponding-source-sym
server-name-sym
key-file-sym
subject-sym
encrypted-password-sym
jwks-uri-sym
authorization-endpoint-uri-sym
token-endpoint-uri-sym
port-sym)
(format #t "\n")
(format #t (G_ "
If you find a bug, then please send a report to ~a.")
cfg:package-bugreport)
(format #t "\n"))
((option-ref options version-sym #f)
(format #t (G_ "~a version ~a
Rreleased ~a\n")
cfg:package cfg:version locale-release-date))
((option-ref options describe-project-sym #f)
(format #t "@prefix earl: .
@prefix doap: .
@prefix xsd: .
@prefix solid-test: .
<> a earl:Software, earl:TestSubject ;
doap:name ~s ;
doap:release [ doap:name ~s ; doap:revision ~s ; doap:created ~s^^xsd:date ] ;
doap:developer ;
doap:homepage ;
doap:description \"Solid implementation to protect users’ freedom\"@en,
\"Implémentation de Solid pour garantir la liberté des utilisateurs\"@fr ;
doap:programming-language \"GNU Guile\" ;
solid-test:features \"authentication\", \"acl\", \"wac-allow\" .
"
cfg:package
(format #f "~a ~a" cfg:package cfg:version)
cfg:version
(date->string cfg:release-date "~1")))
(else
(let ((rest (option-ref options '() '()))
(complete-corresponding-source
(let ((str (option-ref options complete-corresponding-source-sym #f)))
(unless str
(format (current-error-port)
(G_ "You are legally required to link to the complete corresponding source code.\n"))
(exit 1))
str))
(port
(let ((port (string->number (option-ref options port-sym "8080"))))
(unless port
(format (current-error-port)
(G_ "The --~a argument must be a number, not ~s.\n")
port-sym
(option-ref options port-sym "8080"))
(exit 1))
(unless (integer? port)
(format (current-error-port)
(G_ "The --~a argument must be an integer, not ~s.\n")
port-sym
port)
(exit 1))
(unless (> port 0)
(format (current-error-port)
(G_ "The --~a argument must be positive, ~s is invalid.\n")
port-sym port)
(exit 1))
(unless (<= port 65535)
(format (current-error-port)
(G_ "The --~a argument must be less than 65536, ~s is invalid.\n")
port-sym port)
(exit 1))
port))
(server-name
(let ((str (option-ref options server-name-sym #f)))
(and str
(string->uri str))))
(backend-uri
(let ((str (option-ref options backend-uri-sym #f)))
(and str
(string->uri str))))
(header
(let ((str (option-ref options header-sym #f)))
(and str
(string->symbol str))))
(key-file (option-ref options key-file-sym #f))
(subject
(let ((str (option-ref options subject-sym #f)))
(and str (string->uri str))))
(encrypted-password (option-ref options encrypted-password-sym #f))
(jwks-uri
(let ((str (option-ref options jwks-uri-sym #f)))
(and str (string->uri str))))
(authorization-endpoint-uri
(let ((str (option-ref options authorization-endpoint-uri-sym #f)))
(and str (string->uri str))))
(token-endpoint-uri
(let ((str (option-ref options token-endpoint-uri-sym #f)))
(and str (string->uri str))))
(client-id
(let ((str (option-ref options client-id-sym #f)))
(and str (string->uri str))))
(redirect-uri
(let ((str (option-ref options redirect-uri-sym #f)))
(and str (string->uri str))))
(client-name
(option-ref options client-name-sym #f))
(client-uri
(option-ref options client-uri-sym #f)))
(when (null? rest)
(format (current-error-port)
(G_ "Usage: ~a COMMAND [OPTIONS]...\nSee --~a (-h).\n")
(car (command-line))
help-sym)
(exit 1))
(let ((command (car rest))
(non-options (cdr rest)))
(cond
((equal? command (G_ "command-line|command|reverse-proxy"))
(begin
(unless server-name
(format (current-error-port) (G_ "You must pass --~a to set the server name.\n")
server-name-sym)
(exit 1))
(unless backend-uri
(format (current-error-port) (G_ "You must pass --~a to set the backend URI.\n")
backend-uri-sym)
(exit 1))
(run-server*
(handler-with-log
(option-ref options log-file-sym #f)
(option-ref options error-file-sym #f)
complete-corresponding-source
(make-reverse-proxy
#:server-uri server-name
#:http-get cache-http-get
#:endpoint backend-uri
#:auth-header header))
'http
(list #:port port))))
((equal? command (G_ "command-line|command|identity-provider"))
(begin
(unless server-name
(format (current-error-port) (G_ "You must pass --~a to set the server name.\n")
server-name-sym)
(exit 1))
(unless key-file
(format (current-error-port) (G_ "You must pass --~a to set the file where to store the identity provider key.\n")
key-file-sym)
(exit 1))
(unless subject
(format (current-error-port) (G_ "You must pass --~a to set the subject of the identity provider.\n")
subject-sym)
(exit 1))
(unless encrypted-password
(format (current-error-port) (G_ "You must pass --~a to set the subject’s encrypted password.\n")
encrypted-password-sym)
(exit 1))
(unless jwks-uri
(format (current-error-port) (G_ "You must pass --~a to set the JWKS URI.\n")
jwks-uri-sym)
(exit 1))
(unless authorization-endpoint-uri
(format (current-error-port) (G_ "You must pass --~a to set the authorization endpoint URI.\n")
authorization-endpoint-uri-sym)
(exit 1))
(unless token-endpoint-uri
(format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n")
token-endpoint-uri-sym)
(exit 1))
(let ((handler
(make-identity-provider
server-name key-file subject encrypted-password jwks-uri
authorization-endpoint-uri token-endpoint-uri
(make-jti-list)
#:current-time current-time
#:http-get cache-http-get)))
(run-server*
(handler-with-log
(option-ref options log-file-sym #f)
(option-ref options error-file-sym #f)
complete-corresponding-source handler)
'http
(list #:port port)))))
((equal? command (G_ "command-line|command|client-service"))
(begin
(unless client-id
(format (current-error-port) (G_ "You must pass --~a to set the application web ID.\n")
client-id-sym)
(exit 1))
(unless redirect-uri
(format (current-error-port) (G_ "You must pass --~a to set the redirection URI.\n")
redirect-uri-sym)
(exit 1))
(unless client-name
(format (current-error-port) (G_ "You must pass --~a to set the informative client name.\n")
client-name-sym)
(exit 1))
(unless client-uri
(format (current-error-port) (G_ "You must pass --~a to set the informative client URI.\n")
client-uri-sym)
(exit 1))
(let ((handler
(serve-application client-id redirect-uri
#:client-name client-name
#:client-uri client-uri)))
(run-server*
(handler-with-log
(option-ref options log-file-sym #f)
(option-ref options error-file-sym #f)
complete-corresponding-source handler)
'http
(list #:port port)))))
((equal? command (G_ "command-line|command|server"))
(unless server-name
(format (current-error-port) (G_ "You must pass --~a to set the server name.\n")
server-name-sym)
(exit 1))
(unless key-file
(format (current-error-port) (G_ "You must pass --~a to set the file where to store the identity provider key.\n")
key-file-sym)
(exit 1))
(unless subject
(format (current-error-port) (G_ "You must pass --~a to set the subject of the identity provider.\n")
subject-sym)
(exit 1))
(unless encrypted-password
(format (current-error-port) (G_ "You must pass --~a to set the subject’s encrypted password.\n")
encrypted-password-sym)
(exit 1))
(unless jwks-uri
(format (current-error-port) (G_ "You must pass --~a to set the JWKS URI.\n")
jwks-uri-sym)
(exit 1))
(unless authorization-endpoint-uri
(format (current-error-port) (G_ "You must pass --~a to set the authorization endpoint URI.\n")
authorization-endpoint-uri-sym)
(exit 1))
(unless token-endpoint-uri
(format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n")
token-endpoint-uri-sym)
(exit 1))
(let ((jti-list (make-jti-list)))
(let ((resource-handler
(make-resource-server
#:server-uri server-name
#:owner subject
#:authenticator
(if header
(begin
(set! header
(string->symbol
(string-downcase
(symbol->string header))))
(lambda (request request-body)
(let ((value (assq-ref (request-headers request) header)))
(and value (string->uri value)))))
(make-authenticator
jti-list
#:server-uri server-name
#:http-get cache-http-get))
#:http-get cache-http-get))
(identity-provider-handler
(make-identity-provider
server-name key-file subject encrypted-password jwks-uri
authorization-endpoint-uri token-endpoint-uri
jti-list
#:current-time current-time
#:http-get cache-http-get)))
(create-root server-name subject)
(run-server*
(handler-with-log
(option-ref options log-file-sym #f)
(option-ref options error-file-sym #f)
complete-corresponding-source
(lambda (request request-body)
(let ((path (uri-path (request-uri request))))
(if (or (equal? path "/.well-known/openid-configuration")
(equal? path (uri-path jwks-uri))
(equal? path (uri-path authorization-endpoint-uri))
(equal? path (uri-path token-endpoint-uri)))
(identity-provider-handler request request-body)
(resource-handler request request-body)))))
'http
(list #:port port)))))
(else
(format (current-error-port) (G_ "Unknown command ~s\n")
command)
(exit 1))))))))))