diff options
Diffstat (limited to 'src/scm/webid-oidc/program.scm')
| -rw-r--r-- | src/scm/webid-oidc/program.scm | 247 |
1 files changed, 128 insertions, 119 deletions
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 2eda34c..9d65b70 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 parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (ice-9 optargs) @@ -103,81 +104,95 @@ (prepare-log-file log-file)) (when error-file (prepare-error-file error-file)) - (call/ec - (lambda (return) - (with-exception-handler - (lambda (error) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "~a: ~a: Internal server error: ~a\n") - (date->string (time-utc->date (current-time))) - (request-ip-address request) - (error->str error))) - (return - (build-response #:code 500 - #:reason-phrase "Internal Server Error" - #:headers `((source . ,complete-corresponding-source))) - "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))))) + (parameterize ((p:data-home + (string-append + (or (getenv "XDG_DATA_HOME") + (string-append (getenv "HOME") "/.local/share")) + "/disfluid")) + (p:cache-home + (string-append + (or (getenv "XDG_CACHE_HOME") + (string-append (getenv "HOME") "/.cache")) + "/disfluid")) + ;; Fix the date + (p:current-date ((p:current-date)))) + (call/ec + (lambda (return) + (with-exception-handler + (lambda (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))) + (return + (build-response #:code 500 + #:reason-phrase "Internal Server Error" + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))))) + "Sorry, there was an error.")) + (lambda () + (with-exception-handler + (lambda (error) (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 (cons `(source . ,complete-corresponding-source) - (response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - response-body))) - #:unwind? #t - #:unwind-for-type &unknown-client-locale))))))) + (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)))))))) (define (serve-one-client* handler implementation server state) ;; Same as serve-one-client, except it is served in a promise. @@ -753,8 +768,6 @@ Rreleased ~a\n") (make-identity-provider server-name key-file subject encrypted-password jwks-uri authorization-endpoint-uri token-endpoint-uri - (make-jti-list) - #:current-time current-time #:http-get cache-http-get))) (run-server* (handler-with-log @@ -821,49 +834,45 @@ Rreleased ~a\n") (format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n") token-endpoint-uri-sym) (exit 1)) - (let ((jti-list (make-jti-list))) - (let ((resource-handler - (make-resource-server - #:server-uri server-name - #:owner subject - #:authenticator - (if header - (begin - (set! header - (string->symbol - (string-downcase - (symbol->string header)))) - (lambda (request request-body) - (let ((value (assq-ref (request-headers request) header))) - (and value (string->uri value))))) - (make-authenticator - jti-list - #:server-uri server-name - #:http-get cache-http-get)) - #:http-get cache-http-get)) - (identity-provider-handler - (make-identity-provider - server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri - jti-list - #:current-time current-time - #:http-get cache-http-get))) - (create-root server-name subject) - (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source - (lambda (request request-body) - (let ((path (uri-path (request-uri request)))) - (if (or (equal? path "/.well-known/openid-configuration") - (equal? path (uri-path jwks-uri)) - (equal? path (uri-path authorization-endpoint-uri)) - (equal? path (uri-path token-endpoint-uri))) - (identity-provider-handler request request-body) - (resource-handler request request-body))))) - 'http - (list #:port port))))) + (let ((resource-handler + (make-resource-server + #:server-uri server-name + #:owner subject + #:authenticator + (if header + (begin + (set! header + (string->symbol + (string-downcase + (symbol->string header)))) + (lambda (request request-body) + (let ((value (assq-ref (request-headers request) header))) + (and value (string->uri value))))) + (make-authenticator + #:server-uri server-name + #:http-get cache-http-get)) + #:http-get cache-http-get)) + (identity-provider-handler + (make-identity-provider + server-name key-file subject encrypted-password jwks-uri + authorization-endpoint-uri token-endpoint-uri + #:http-get cache-http-get))) + (create-root server-name subject) + (run-server* + (handler-with-log + (option-ref options log-file-sym #f) + (option-ref options error-file-sym #f) + complete-corresponding-source + (lambda (request request-body) + (let ((path (uri-path (request-uri request)))) + (if (or (equal? path "/.well-known/openid-configuration") + (equal? path (uri-path jwks-uri)) + (equal? path (uri-path authorization-endpoint-uri)) + (equal? path (uri-path token-endpoint-uri))) + (identity-provider-handler request request-body) + (resource-handler request request-body))))) + 'http + (list #:port port)))) (else (format (current-error-port) (G_ "Unknown command ~s\n") command) |