diff options
Diffstat (limited to 'src/scm/webid-oidc/program.scm')
-rw-r--r-- | src/scm/webid-oidc/program.scm | 142 |
1 files changed, 67 insertions, 75 deletions
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 9d65b70..2b80bef 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -25,6 +25,7 @@ #:use-module (webid-oidc jti) #:use-module (webid-oidc offloading) #:use-module (webid-oidc catalog) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -45,13 +46,6 @@ #: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 '())) @@ -59,16 +53,17 @@ (define uri-string (if (uri? uri) (uri->string uri) uri)) (with-mutex logging-mutex (when (getenv "XML_CATALOG_FILES") - (format (current-error-port) "~a: Warning: XML_CATALOG_FILES is set to ~s.\n" + (format (current-error-port) (G_ "~a: Warning: XML_CATALOG_FILES is set to ~s.\n") date (getenv "XML_CATALOG_FILES"))) - (format (current-error-port) "~a: GET ~a ~s...\n" + (format (current-error-port) (G_ "~a: GET ~a ~s...\n") date uri-string headers)) (set! uri (resolve-uri uri #:http-get (lambda* (uri . args) (with-mutex logging-mutex - (format (current-error-port) "~a: Warning: loading XML catalog from the web, ~s.\n" + (format (current-error-port) + (G_ "~a: Warning: loading XML catalog from the web, ~s.\n") date (uri->string uri))) (apply http-get uri args)))) @@ -76,7 +71,7 @@ (in-another-thread (http-get uri #:headers headers)) (with-mutex logging-mutex - (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n" + (format (current-error-port) (G_ "~a: GET ~a ~s: ~s ~a bytes\n") date uri-string headers response (cond ((bytevector? response-body) @@ -115,84 +110,81 @@ (string-append (getenv "HOME") "/.cache")) "/disfluid")) ;; Fix the date - (p:current-date ((p:current-date)))) + (p:current-date ((p:current-date))) + (web-locale request)) (call/ec (lambda (return) (with-exception-handler (lambda (error) + (unless (exception-with-message? error) + (let ((final-message + (format #f (G_ "really bad internal server error")))) + (raise-exception + (make-exception + (make-exception-with-message final-message) + error)))) (with-mutex logging-mutex (format (current-error-port) (G_ "~a: ~a: Internal server error: ~a\n") (date->string ((p:current-date))) (request-ip-address request) - (error->str error))) + (exception-message error))) (return (build-response #:code 500 - #:reason-phrase "Internal Server Error" + #:reason-phrase (W_ "Internal Server Error") #:headers `((source . ,complete-corresponding-source) (date . ,((p:current-date))))) - "Sorry, there was an error.")) + (W_ "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 `((source . ,complete-corresponding-source) - (date . ,((p:current-date))) - ,@(response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - response-body))) - #:unwind? #t - #:unwind-for-type &unknown-client-locale)))))))) + (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 (and cause (exception-with-message? cause)) + (string-append + (response-reason-phrase response) + " " + (format #f (G_ "(there was an error: ~a)") + (exception-message cause))) + (response-reason-phrase response))))) + (return + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))) + ,@(response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + response-body))))))))) (define (serve-one-client* handler implementation server state) ;; Same as serve-one-client, except it is served in a promise. |