Merge the client service with the webid-oidc program

3 files changed, 121 insertions, 188 deletions

diff --git a/src/Makefile.am b/src/Makefile.am
index 5932f1d..034ae92 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -1,6 +1,6 @@
 lib_LTLIBRARIES += %reldir%/libwebidoidc.la
 
-dist_bin_SCRIPTS += %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-example-app
 
 AM_CPPFLAGS += -I %reldir% -I $(srcdir)/%reldir%
 
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 6fe9cc2..d8f438b 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -604,158 +604,4 @@
                         (body
                          (p "This page does not exist on the server."))))))))))))))
 
-(define (G_ text)
-  (let ((out (gettext text)))
-    (if (string=? out text)
-        ;; No translation, disambiguate
-        (car (reverse (string-split text #\|)))
-        out)))
 
-(define-public (main-server)
-  (setlocale LC_ALL "")
-  (bindtextdomain cfg:package cfg:localedir)
-  (textdomain cfg:package)
-  (let ((version-sym
-         (string->symbol (G_ "command-line|version")))
-        (help-sym
-         (string->symbol (G_ "comand-line|help")))
-        (client-id-sym
-         (string->symbol (G_ "comand-line|client-id")))
-        (redirect-uri-sym
-         (string->symbol (G_ "comand-line|redirect-uri")))
-        (client-name-sym
-         (string->symbol (G_ "comand-line|client-name")))
-        (client-uri-sym
-         (string->symbol (G_ "comand-line|client-uri")))
-        (port-sym
-         (string->symbol (G_ "comand-line|port")))
-        (log-file-sym
-         (string->symbol (G_ "comand-line|log-file")))
-        (error-file-sym
-         (string->symbol (G_ "comand-line|error-file"))))
-    (let ((options
-           (let ((option-spec
-                  `((,version-sym (single-char #\v) (value #f))
-                    (,help-sym (single-char #\h) (value #f))
-                    (,client-id-sym (single-char #\i) (value #t))
-                    (,redirect-uri-sym (single-char #\r) (value #t))
-                    (,client-name-sym (single-char #\n) (value #t))
-                    (,client-uri-sym (single-char #\u) (value #t))
-                    (,port-sym (single-char #\p) (value #t))
-                    (,log-file-sym (single-char #\l) (value #t))
-                    (,error-file-sym (single-char #\e) (value #t)))))
-             (getopt-long (command-line) option-spec))))
-      (cond
-       ((option-ref options help-sym #f)
-        (format #t (G_ "Usage: ~a [OPTIONS]...
-
-Serve public pages for an application.
-
-Options:
-  -h, --~a:
-      display this help message and exit.
-  -v, --~a:
-      display the version information (~a) and exit.
-  -i URI, --~a=URI:
-      set the webid of the client.
-  -r FILE, --~a=URI:
-      set the redirection URI where to get the authorization code.
-  -n NAME, --~a=NAME:
-      set the name of the application.
-  -u URI, --~a=URI:
-      set the address of the application (informative).
-  -p PORT, --~a=PORT:
-      set the port to bind (instead of 8080).
-  -l FILE.log, --~a=FILE.log:
-      dump the standard output to that file.
-  -e FILE.err, --~a=FILE.err:
-      dump the standard error to that file.
-
-Environment variables:
-
-  LANG: set the locale of the sysadmin-facing interface, for log files
-and command-line interface. It is currently ~a.
-
-Example used in webid-oidc-demo.planete-kraus.eu (except it’s managed
-by shepherd in reality):
-
-    export LANG=C
-    webid-oidc-client-service \\
-      --client-id 'https://webid-oidc-demo.planete-kraus.eu/example-application#id' \\
-      --redirect-uri 'https://webid-oidc-demo.planete-kraus.eu/authorized' \\
-      --client-name 'Example Solid Application' \\
-      --client-uri 'https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client' \\
-      --port $PORT
-
-If you find a bug, send a report to ~a.
-")
-                (car (command-line))
-                help-sym version-sym
-                cfg:version
-                client-id-sym redirect-uri-sym client-name-sym client-uri-sym port-sym
-                log-file-sym error-file-sym
-                (or (getenv "LANG") "")
-                cfg:package-bugreport))
-       ((option-ref options version-sym #f)
-        (format #t (G_ "~a version ~a\n")
-                cfg:package cfg:version))
-       (else
-        (let ((client-id (option-ref options client-id-sym #f))
-              (redirect-uri (option-ref options redirect-uri-sym #f))
-              (client-name (option-ref options client-name-sym "Example Solid App"))
-              (client-uri
-               (option-ref options client-uri-sym
-                           "https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client"))
-              (port-string
-               (option-ref options port-sym "8080"))
-              (log-file-string
-               (option-ref options log-file-sym #f))
-              (error-file-string
-               (option-ref options error-file-sym #f)))
-          (when log-file-string
-            (set-current-output-port (stubs:open-output-file* log-file-string))
-            (setvbuf (current-output-port) 'none))
-          (when error-file-string
-            (set-current-error-port (stubs:open-output-file* error-file-string))
-            (setvbuf (current-error-port) 'none))
-          (unless (and client-id (string->uri client-id))
-            (format (current-error-port)
-                    (G_ "You need to set the client ID as an URI.\n"))
-            (exit 1))
-          (unless (and redirect-uri (string->uri redirect-uri))
-            (format (current-error-port)
-                    (G_ "You need to set the redirect URI.\n"))
-            (exit 2))
-          (unless (string->uri client-uri)
-            (format (current-error-port)
-                    (G_ "The client URI should be an URI.\n"))
-            (exit 3))
-          (unless (and (string->number port-string)
-                       (integer? (string->number port-string))
-                       (>= (string->number port-string) 0)
-                       (<= (string->number port-string) 65535))
-            (format (current-error-port)
-                    (G_ "The port should be a number between 0 and 65535.\n"))
-            (exit 1))
-          (let ((handler
-                 (serve-application client-id redirect-uri
-                                    #:client-name client-name
-                                    #:client-uri client-uri)))
-            (let ((handler-with-log
-                   (lambda (request request-body)
-                     (with-exception-handler
-                         (lambda (error)
-                           (format (current-error-port)
-                                   (G_ "~a: Internal server error: ~a\n")
-                                   (date->string (time-utc->date (current-time)))
-                                   (error->str error))
-                           (values
-                            (build-response #:code 500
-                                            #:reason-phrase "Internal Server Error")
-                            "Sorry, there was an error."))
-                       (lambda ()
-                         (handler request request-body))
-                       #:unwind? #t))))
-              (install-suspendable-ports!)
-              (run-server handler 'http
-                          (list #:port (string->number port-string)))))))))))
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index 3582eaa..c53be5d 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -2,6 +2,7 @@
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc reverse-proxy)
   #:use-module (webid-oidc identity-provider)
+  #:use-module (webid-oidc client)
   #:use-module (webid-oidc jti)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -42,6 +43,32 @@
 (define cache-http-get
   (with-cache #:http-get http-get-with-log))
 
+(define (handler-with-log handler)
+  (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)))
+
 (define-public (main)
   (setvbuf (current-output-port) 'none)
   (setvbuf (current-error-port) 'none)
@@ -72,6 +99,14 @@
          (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
@@ -88,6 +123,10 @@
                     (,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))
@@ -104,6 +143,8 @@ Available commands:
     run an authenticating reverse proxy.
   ~a:
     run an identity provider.
+  ~a:
+    serve the pages for a public application.
 
 General options:
   -h, --~a:
@@ -144,6 +185,19 @@ Options for the identity provider:
   -t URI, --~a=URI:
       set the token endpoint of the issuer.
 
+Options for the client service:
+  -c URI, --~a=URI:
+      set the web identifier of the client application, which is
+      dereferenced to a semantic resource.
+  -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.
+  -C NAME, --~a=NAME:
+      set the user-visible application name (may be misleading...).
+  -u URI, --~a=URI:
+      set an URI where someone would find more information about the
+      application (again, may be misleading).
+
 Environment variables:
 
   LANG: set the locale of the user interface (for the server commands,
@@ -197,6 +251,17 @@ invoked with the following options:
       --~a 'https://webid-oidc-demo.planete-kraus.eu/token' \\
       --~a $PORT
 
+Running the public pages for an application
+
+webid-oidc-demo.planete-kraus.eu is configured this way:
+
+    ~a ~a \\
+      --~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
+
 If you find a bug, then please send a report to ~a.
 ")
                 ;; Usage:
@@ -204,6 +269,7 @@ If you find a bug, then please send a report to ~a.
                 ;; Available commands:
                 (G_ "command-line|command|reverse-proxy")
                 (G_ "command-line|command|identity-provider")
+                (G_ "command-line|command|client-service")
                 ;; General options
                 ;; help
                 help-sym
@@ -231,6 +297,11 @@ If you find a bug, then please send a report to ~a.
                 jwks-uri-sym
                 authorization-endpoint-uri-sym
                 token-endpoint-uri-sym
+                ;; Options for the client service
+                client-id-sym
+                redirect-uri-sym
+                client-name-sym
+                client-uri-sym
                 ;; Environment variables
                 (if (getenv "LANG")
                     (format #f (G_ "an environment variable| It is currently set to ~s.")
@@ -262,6 +333,11 @@ If you find a bug, then please send a report to ~a.
                 server-name-sym key-file-sym subject-sym password-sym
                 jwks-uri-sym authorization-endpoint-uri-sym
                 token-endpoint-uri-sym port-sym
+                ;; Running the public pages for an application
+                (car (command-line))
+                (G_ "command-line|command|client-service")
+                client-id-sym redirect-uri-sym client-name-sym client-uri-sym
+                port-sym
                 ;; Bug report
                 cfg:package-bugreport))
        ((option-ref options version-sym #f)
@@ -319,7 +395,17 @@ If you find a bug, then please send a report to ~a.
                  (and str (string->uri str))))
               (token-endpoint-uri
                (let ((str (option-ref options token-endpoint-uri-sym #f)))
-                 (and str (string->uri str)))))
+                 (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")
@@ -393,36 +479,37 @@ If you find a bug, then please send a report to ~a.
                         (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))))))
+                  (run-server
+                   (handler-with-log 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 handler)
+                   'http
+                   (list #:port port)))))
               (else
-              (format (current-error-port) (G_ "Unknown command ~s\n")
-                      command)
-              (exit 1))))))))))
+               (format (current-error-port) (G_ "Unknown command ~s\n")
+                       command)
+               (exit 1))))))))))