From 56f64a336b5dff86280a94b33e698ce74bd39450 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Sat, 5 Dec 2020 13:11:49 +0100
Subject: Run the identity provider as a script

---
 src/scm/webid-oidc/identity-provider.scm | 26 +++++++++++++++++++-------
 src/scm/webid-oidc/stubs.scm             |  4 ++++
 2 files changed, 23 insertions(+), 7 deletions(-)

(limited to 'src/scm')

diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm
index de49fc5..8df4386 100644
--- a/src/scm/webid-oidc/identity-provider.scm
+++ b/src/scm/webid-oidc/identity-provider.scm
@@ -246,8 +246,8 @@ by shepherd in reality):
       --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 https://webid-oidc-demo.planete-kraus.eu/authorize \\
-      --token-endpoint https://webid-oidc-demo.planete-kraus.eu/token \\
+      --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.
@@ -284,10 +284,10 @@ If you find a bug, send a report to ~a.
                (option-ref options error-file-sym #f))
               (jti-list (make-jti-list)))
           (when log-file-string
-            (set-current-output-port (open-output-file* 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 (open-output-file* 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)
@@ -343,13 +343,25 @@ If you find a bug, send a report to ~a.
                      (with-exception-handler
                          (lambda (error)
                            (format (current-error-port)
-                                   (G_ "Internal server error: ~a\n")
+                                   (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))))))
+                         (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 'http (list #:port (string->number port-string)))))))))))
+              (run-server handler-with-log 'http (list #:port (string->number port-string)))))))))))
diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index b29aa1f..cdea58a 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -137,6 +137,10 @@
         (else
          (throw key subr message args rest))))))
 
+(define-public (open-output-file* filename . args)
+  (mkdir-p (dirname filename))
+  (apply open-output-file filename args))
+
 (define-public (call-with-output-file* filename . args)
   (mkdir-p (dirname filename))
   (apply call-with-output-file filename args))
-- 
cgit v1.2.3