Merge the identity provider program with webid-oidc

3 files changed, 178 insertions, 250 deletions

diff --git a/src/Makefile.am b/src/Makefile.am
index 1876a55..5932f1d 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 %reldir%/webid-oidc-hello %reldir%/webid-oidc-client-service %reldir%/webid-oidc-example-app
+dist_bin_SCRIPTS += %reldir%/webid-oidc %reldir%/webid-oidc-hello %reldir%/webid-oidc-client-service %reldir%/webid-oidc-example-app
 
 AM_CPPFLAGS += -I %reldir% -I $(srcdir)/%reldir%
 
diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm
index 8df4386..6f96b44 100644
--- a/src/scm/webid-oidc/identity-provider.scm
+++ b/src/scm/webid-oidc/identity-provider.scm
@@ -122,246 +122,3 @@
                                        (body
                                         (h1 "Resource not found")
                                         (p "This OpenID Connect identity provider does not know the resource you are requesting."))))))))))))))))
-
-(define-public (main)
-  (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))
-    (format (current-error-port) "~a: GET ~a ~s...\n"
-            date uri-string headers)
-    (receive (response response-body) (http-get uri #:headers headers)
-      (if response-body
-          (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n"
-                  date uri-string headers response
-                  (if (bytevector? response-body)
-                      (bytevector-length response-body)
-                      (string-length response-body)))
-          (format (current-error-port) "~a: GET ~a ~s: ~s\n"
-                  date uri-string headers response))
-      (values response response-body)))
-  (define cache-http-get
-    (with-cache #:http-get http-get-with-log))
-  (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")))
-        (issuer-sym
-         (string->symbol (G_ "comand-line|issuer")))
-        (key-file-sym
-         (string->symbol (G_ "comand-line|key-file")))
-        (subject-sym
-         (string->symbol (G_ "comand-line|subject")))
-        (password-sym
-         (string->symbol (G_ "comand-line|password")))
-        (jwks-uri-sym
-         (string->symbol (G_ "comand-line|jwks-uri")))
-        (authorization-endpoint-uri-sym
-         (string->symbol (G_ "comand-line|authorization-endpoint-uri")))
-        (token-endpoint-uri-sym
-         (string->symbol (G_ "comand-line|token-endpoint-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))
-                    (,issuer-sym (single-char #\i) (value #t))
-                    (,key-file-sym (single-char #\k) (value #t))
-                    (,subject-sym (single-char #\s) (value #t))
-                    (,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))
-                    (,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]...
-
-Run the Solid identity provider for a specific user.
-
-Options:
-  -h, --~a:
-      display this help message and exit.
-  -v, --~a:
-      display the version information (~a) and exit.
-  -i URI, --~a=URI:
-      set the public server host name.
-  -k FILE, --~a=FILE.jwk:
-      set the file name of the key file. If it does not exist, a new
-      key is generated.
-  -s WEBID, --~a=WEBID:
-      set the identity of the subject.
-  -w PASSWORD, --~a=PASSWORD:
-      set the password to recognize the user.
-  -j URI, --~a=URI:
-      set the URI to query the key of the server.
-  -a URI, --~a=URI:
-      set the authorization endpoint of the issuer.
-  -t URI, --~a=URI:
-      set the token endpoint of the issuer.
-  -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 (the user
-pages are translated according to the user agent’s Accept-language
-header), for log files and command-line interface. It is currently ~a.
-
-  XDG_DATA_HOME: where to store the refresh tokens (under the
-webid-oidc directory). For a system service, it is recommended to set
-it to /var/lib. Currently set to ~a.
-
-  XDG_CACHE_HOME: where to store and update the seed file for the
-random number generator. If you remove it, you need to restart the
-program to use a different seed. Currently set to ~a.
-
-  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. Currently set to ~a.
-
-Example used in webid-oidc-demo.planete-kraus.eu (except it’s managed
-by shepherd in reality):
-
-    export LANG=C
-    export XDG_DATA_HOME=/var/lib
-    export XDG_CACHE_HOME=/var/cache
-    webid-oidc-issuer \\
-      --issuer https://webid-oidc-demo.planete-kraus.eu \\
-      --key-file /var/lib/webid-oidc/issuer/key.jwk \\
-      --subject https://webid-oidc-demo.planete-kraus.eu/profile/card#me \\
-      --password \"$PASSWORD\" \\
-      --jwks-uri https://webid-oidc-demo.planete-kraus.eu/keys \\
-      --authorization-endpoint-uri https://webid-oidc-demo.planete-kraus.eu/authorize \\
-      --token-endpoint-uri https://webid-oidc-demo.planete-kraus.eu/token \\
-      --port $PORT
-
-If you find a bug, send a report to ~a.
-")
-                (car (command-line))
-                help-sym version-sym
-                cfg:version
-                issuer-sym key-file-sym subject-sym password-sym
-                jwks-uri-sym authorization-endpoint-uri-sym
-                token-endpoint-uri-sym port-sym log-file-sym error-file-sym
-                (or (getenv "LANG") "")
-                (or (getenv "XDG_DATA_HOME") "")
-                (or (getenv "XDG_CACHE_HOME") "")
-                (or (getenv "HOME") "")
-                cfg:package-bugreport))
-       ((option-ref options version-sym #f)
-        (format #t (G_ "~a version ~a\n")
-                cfg:package cfg:version))
-       (else
-        (let ((issuer (option-ref options issuer-sym #f))
-              (key-file (option-ref options key-file-sym #f))
-              (subject (option-ref options subject-sym #f))
-              (password (option-ref options password-sym #f))
-              (jwks-uri (option-ref options jwks-uri-sym #f))
-              (authorization-endpoint-uri
-               (option-ref options authorization-endpoint-uri-sym #f))
-              (token-endpoint-uri
-               (option-ref options token-endpoint-uri-sym #f))
-              (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))
-              (jti-list (make-jti-list)))
-          (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 issuer (string->uri issuer))
-            (format (current-error-port)
-                    (G_ "You need to set the issuer.\n"))
-            (exit 1))
-          (unless key-file
-            (format (current-error-port)
-                    (G_ "You need to set the file name of the key file.\n"))
-            (exit 1))
-          (unless (and subject (string->uri subject))
-            (format (current-error-port)
-                    (G_ "You need to set the identity of the subject.\n"))
-            (exit 1))
-          (unless password
-            (format (current-error-port)
-                    (G_ "You need to set the password to verify the identity of the subject.\n"))
-            (exit 1))
-          (unless (and jwks-uri (string->uri jwks-uri))
-            (format (current-error-port)
-                    (G_ "You need to set the JWKS URI.\n"))
-            (exit 1))
-          (unless (and authorization-endpoint-uri
-                       (string->uri authorization-endpoint-uri))
-            (format (current-error-port)
-                    (G_ "You need to set the authorization endpoint URI.\n"))
-            (exit 1))
-          (unless (and token-endpoint-uri
-                       (string->uri token-endpoint-uri))
-            (format (current-error-port)
-                    (G_ "You need to set the token endpoint URI.\n"))
-            (exit 1))
-          (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
-                 (make-identity-provider
-                  (string->uri issuer)
-                  key-file
-                  (string->uri subject)
-                  password
-                  (string->uri jwks-uri)
-                  (string->uri authorization-endpoint-uri)
-                  (string->uri token-endpoint-uri)
-                  jti-list
-                  #:current-time current-time
-                  #:http-get cache-http-get)))
-            (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 ()
-                         (with-exception-handler
-                             (lambda (error)
-                               (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 ()
-                             (handler request request-body))
-                           #:unwind? #t
-                           #:unwind-for-type &unknown-client-locale))
-                       #:unwind? #t))))
-              (install-suspendable-ports!)
-              (run-server handler-with-log 'http (list #:port (string->number port-string)))))))))))
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index b8878b0..3582eaa 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -1,6 +1,8 @@
 (define-module (webid-oidc program)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc reverse-proxy)
+  #:use-module (webid-oidc identity-provider)
+  #:use-module (webid-oidc jti)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (ice-9 optargs)
@@ -58,16 +60,34 @@
          (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")))
+        (password-sym
+         (string->symbol (G_ "command-line|server|issuer|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")))
         (log-file-sym
-         (string->symbol (G_ "comand-line|log-file")))
+         (string->symbol (G_ "command-line|log-file")))
         (error-file-sym
-         (string->symbol (G_ "comand-line|error-file"))))
+         (string->symbol (G_ "command-line|error-file"))))
     (let ((options
            (let ((spec
                   `((,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))
+                    (,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))
                     (,port-sym (single-char #\p) (value #t))
                     (,server-name-sym (single-char #\n) (value #t))
                     (,header-sym (single-char #\H) (value #t))
@@ -80,8 +100,10 @@
 Run the webid-oidc COMMAND.
 
 Available commands:
-  ~a: 
+  ~a:
     run an authenticating reverse proxy.
+  ~a:
+    run an identity provider.
 
 General options:
   -h, --~a:
@@ -107,11 +129,38 @@ Options for the reverse proxy:
     set the backend URI for the reverse proxy, only for the
     reverse-proxy command.
 
+Options for the identity provider:
+  -k FILE, --~a=FILE.jwk:
+      set the file name of the key file. If it does not exist, a new
+      key is generated.
+  -s WEBID, --~a=WEBID:
+      set the identity of the subject.
+  -w PASSWORD, --~a=PASSWORD:
+      set the password to recognize the user.
+  -j URI, --~a=URI:
+      set the URI to query the key of the server.
+  -a URI, --~a=URI:
+      set the authorization endpoint of the issuer.
+  -t URI, --~a=URI:
+      set the token endpoint of the issuer.
+
 Environment variables:
 
   LANG: set the locale of the user interface (for the server commands,
 the user is the system administrator).~a
 
+  XDG_DATA_HOME: where the program stores persistent data. The
+identity provider stores the refresh tokens. For a system service, it
+is recommended to set it to /var/lib.~a
+
+  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.~a
+
+  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.~a
+
 Running a reverse proxy
 
 Suppose that you operate data.provider.com. You want to run an
@@ -131,12 +180,30 @@ from this reverse proxy.
       --~a '/var/log/proxy.log' \\
       --~a '/var/log/proxy.err'
 
+Running an identity provider
+
+The identity provider running at webid-oidc-demo.planete-kraus.eu is
+invoked with the following options:
+
+    export XDG_DATA_HOME=/var/lib
+    export XDG_CACHE_HOME=/var/cache
+    ~a ~a \\
+      --~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 \"$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
+
 If you find a bug, then please send a report to ~a.
 ")
                 ;; Usage:
                 (car (command-line))
                 ;; Available commands:
                 (G_ "command-line|command|reverse-proxy")
+                (G_ "command-line|command|identity-provider")
                 ;; General options
                 ;; help
                 help-sym
@@ -157,12 +224,30 @@ If you find a bug, then please send a report to ~a.
                 header-sym
                 ;; backend-uri
                 backend-uri-sym
+                ;; Options for the identity provider
+                key-file-sym
+                subject-sym
+                password-sym
+                jwks-uri-sym
+                authorization-endpoint-uri-sym
+                token-endpoint-uri-sym
                 ;; Environment variables
-                ;; LANG
                 (if (getenv "LANG")
                     (format #f (G_ "an environment variable| It is currently set to ~s.")
                             (getenv "LANG"))
                     (G_ "an environment variable| It is currently unset."))
+                (if (getenv "XDG_DATA_HOME")
+                    (format #f (G_ "an environment variable| It is currently set to ~s.")
+                            (getenv "XDG_DATA_HOME"))
+                    (G_ "an environment variable| It is currently unset."))
+                (if (getenv "XDG_CACHE_HOME")
+                    (format #f (G_ "an environment variable| It is currently set to ~s.")
+                            (getenv "XDG_CACHE_HOME"))
+                    (G_ "an environment variable| It is currently unset."))
+                (if (getenv "HOME")
+                    (format #f (G_ "an environment variable| It is currently set to ~s.")
+                            (getenv "HOME"))
+                    (G_ "an environment variable| It is currently unset."))
                 ;; Running a reverse proxy
                 ;; Program name
                 (car (command-line))
@@ -171,6 +256,12 @@ If you find a bug, then please send a report to ~a.
                 ;; options
                 port-sym server-name-sym backend-uri-sym header-sym
                 log-file-sym error-file-sym
+                ;; Running an identity provider
+                (car (command-line))
+                (G_ "command-line|command|identity-provider")
+                server-name-sym key-file-sym subject-sym password-sym
+                jwks-uri-sym authorization-endpoint-uri-sym
+                token-endpoint-uri-sym port-sym
                 ;; Bug report
                 cfg:package-bugreport))
        ((option-ref options version-sym #f)
@@ -214,7 +305,21 @@ If you find a bug, then please send a report to ~a.
               (header
                (let ((str (option-ref options header-sym #f)))
                  (and str
-                      (string->symbol 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))))
+              (password (option-ref options 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)))))
           (when (null? rest)
             (format (current-error-port)
                     (G_ "Usage: ~a COMMAND [OPTIONS]...\nSee --~a (-h).\n")
@@ -251,7 +356,73 @@ If you find a bug, then please send a report to ~a.
                   #:auth-header header)
                  'http
                  (list #:port port))))
-             (else
+             ((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 password
+                  (format (current-error-port) (G_ "You must pass --~a to set the subject’s password.\n")
+                          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 password jwks-uri
+                        authorization-endpoint-uri token-endpoint-uri
+                        (make-jti-list)
+                        #:current-time current-time
+                        #:http-get cache-http-get)))
+                  (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 ()
+                               (with-exception-handler
+                                   (lambda (error)
+                                     (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 ()
+                                   (handler request request-body))
+                                 #:unwind? #t
+                                 #:unwind-for-type &unknown-client-locale))
+                             #:unwind? #t))))
+                    (run-server
+                     handler-with-log
+                     'http
+                     (list #:port port))))))
+              (else
               (format (current-error-port) (G_ "Unknown command ~s\n")
                       command)
               (exit 1))))))))))