Merge the identity provider program with webid-oidc

1 files changed, 177 insertions, 6 deletions

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))))))))))