Use guile parameters

With parameters, the API does not need to care about the directory
where to load files and how to get the time.

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)