;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see
Sorry, an error happened.
")) xml->sxml) ,(user-message-sxml error)))) <>)) (and (caused-by-user? error) (caused-by-user-webid error)) error) ;; Other kind of exception (raise-exception error))) (lambda () (receive (response response-body response-meta) (handle endpoint request request-body) (values response response-body (assq-ref response-meta 'user) #f))) #:unwind? #t))) (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))))) (values (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. (call-with-values (lambda () (read-client implementation server)) (lambda (client request body) (future (with-threads (if client (receive (response body state) (handle-request handler request body state) (write-client implementation server client response body) state) state)))))) (define* (run-server* handler #:key (implementation 'http) (open-params '()) . state) ;; Same as the traditional run-server, but the requests are handled ;; in a future and the state is discarded. (let* ((implementation (lookup-server-impl implementation)) (server (open-server implementation open-params))) (let lp () (serve-one-client* handler implementation server state) (lp)))) (define (inner-main) (setvbuf (current-output-port) 'none) (setvbuf (current-error-port) 'none) (setlocale LC_ALL "") (bindtextdomain cfg:package cfg:localedir) (textdomain cfg:package) (let ((version-sym (string->symbol (G_ "command-line|version"))) (describe-project-sym (string->symbol (G_ "command-line|describe-project"))) (complete-corresponding-source-sym (string->symbol (G_ "command-line|complete-corresponding-source"))) (help-sym (string->symbol (G_ "command-line|help"))) (port-sym (string->symbol (G_ "command-line|server|port"))) (configuration-sym (string->symbol (G_ "command-line|server|configuration"))) (log-file-sym (string->symbol (G_ "command-line|log-file"))) (error-file-sym (string->symbol (G_ "command-line|error-file"))) (locale-release-date (strftime (locale-date-format) (localtime (time-second (date->time-utc cfg:release-date)))))) (let ((options (let ((spec `((,complete-corresponding-source-sym (single-char #\S) (value #t)) (,version-sym (single-char #\v) (value #f)) (,describe-project-sym (value #f)) (,help-sym (single-char #\h) (value #f)) (,log-file-sym (single-char #\l) (value #t)) (,error-file-sym (single-char #\e) (value #t)) (,configuration-sym (single-char #\c) (value #t)) (,port-sym (single-char #\p) (value #t))))) (getopt-long (command-line) spec)))) (cond ((option-ref options help-sym #f) (format #t (G_ "Usage: ~a [OPTIONS]... ") (car (command-line))) (format #t (G_ " Run disfluid.")) (format #t "\n") (format #t (G_ " This program is covered by the GNU Affero GPL, version 3 or later. This license requires you to provide a way for any user over the network to download the complete corresponding source code (with your modifications) at no cost. The server adds a \"Source:\" header to all responses.")) (format #t "\n") (format #t "\n") (format #t (G_ " General options:")) (format #t (G_ " -h, --~a: display a short help message and exit.") help-sym) (format #t (G_ " -v, --~a: display the version information (~a, released ~a) and exit.") version-sym cfg:version locale-release-date) (format #t (G_ " --~a: describe the project in the DOAP vocabulary and exit.") describe-project-sym) (format #t (G_ " -l FILE.log, --~a=FILE.log: redirect the program standard output to FILE.log.") log-file-sym) (format #t (G_ " -e FILE.err, --~a=FILE.err: redirect the program errors to FILE.err.") error-file-sym) (format #t "\n") (format #t (G_ " Running a server:")) (format #t (G_ " -S MEANS, --~a=MEANS: specify a way to download the complete corresponding source code. For instance, this would be an URI pointing to a tarball. This option is required if a server is implemented.") complete-corresponding-source-sym) (format #t (G_ " -p PORT, --~a=PORT: set the server port to bind, 8080 by default.") port-sym) (format #t (G_ " -c FILE, --~a=FILE: set up a server with configuration from FILE.") configuration-sym) (format #t "\n") (format #t (G_ " Environment variables:")) (format #t (G_ " XML_CATALOG_FILES: the server will fetch resources on the web. By setting this environment variable to a space-separated list of catalog URIs, the server will redirect these requests to another server. Currently, it is not possible to load files from the file system, because there is no way to specify the content-type.")) (when (getenv "XML_CATALOG_FILES") (format #t (G_ "the-environment-variable| It is currently set to ~s.") (getenv "XML_CATALOG_FILES"))) (format #t (G_ " LANG: set the locale of the user interface (for the server commands, the user is the system administrator).")) (when (getenv "LANG") (format #t (G_ "the-environment-variable| It is currently set to ~s.") (getenv "LANG"))) (format #t (G_ " XDG_DATA_HOME: where the program stores persistent data. The identity provider stores the refresh tokens. The full server stores the resources there. For a system service, it is recommended to set it to /var/lib.")) (when (getenv "XDG_DATA_HOME") (format #t (G_ "the-environment-variable| It is currently set to ~s.") (getenv "XDG_DATA_HOME"))) (format #t (G_ " XDG_CACHE_HOME: where the program stores and updates the seed file, and the web client cache. You can remove this directory at any time. The seed file will be initialized from /dev/random.")) (when (getenv "XDG_CACHE_HOME") (format #t (G_ "the-environment-variable| It is currently set to ~s.") (getenv "XDG_CACHE_HOME"))) (format #t (G_ " HOME: if XDG_DATA_HOME or XDG_CACHE_HOME is not set, they are computed from the value of the HOME environment variable. It is not used otherwise.")) (when (getenv "HOME") (format #t (G_ "the-environment-variable| It is currently set to ~s.") (getenv "HOME"))) (format #t "\n") (format #t "\n") (format #t (G_ " If you find a bug, then please send a report to ~a.") cfg:package-bugreport) (format #t "\n")) ((option-ref options version-sym #f) (format #t (G_ "~a version ~a Rreleased ~a\n") cfg:package cfg:version locale-release-date)) ((option-ref options describe-project-sym #f) (format #t "@prefix earl: