;; 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 <https://www.gnu.org/licenses/>.

(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 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
    (format (current-error-port) "~a: GET ~a ~s...\n"
            date uri-string headers))
  (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")))
        (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"))))
    (let ((options
           (let ((spec
                  `((,complete-corresponding-source-sym (single-char #\S) (value #t))
                    (,version-sym (single-char #\v) (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) and exit.")
                version-sym
                cfg:version)
        (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_ "
  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\n")
                cfg:package cfg:version))
       (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))))))))))