path: root/src/scm/webid-oidc/program.scm

;; 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 <https://www.gnu.org/licenses/>.

(define-module (webid-oidc program)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc server log)
  #:use-module (webid-oidc client)
  #:use-module (webid-oidc server create)
  #:use-module (webid-oidc server endpoint)
  #: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:)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 control)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 futures)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 exceptions)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs bytevectors)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (webid-oidc cache)
  #:use-module (web server)
  #:use-module (sxml simple)
  #:declarative? #f)

(define logging-mutex (make-mutex))

(define (use-logging-request f)
  (let ((backend (p:anonymous-http-request)))
    (parameterize
        ((p:anonymous-http-request
          (lambda* (uri . all-args)
            (define date (date->string (time-utc->date (current-time))))
            (define uri-string (if (uri? uri) (uri->string uri) uri))
            (let-keywords
             all-args #t
             ((headers '())
              (method 'GET))
             (with-mutex logging-mutex
               (when (getenv "XML_CATALOG_FILES")
                 (format (current-error-port) (G_ "~a: Warning: XML_CATALOG_FILES is set to ~s.\n")
                         date
                         (getenv "XML_CATALOG_FILES")))
               (format (current-error-port) (G_ "~a: ~s ~a ~s...\n")
                       date method uri-string headers))
             (receive (response response-body)
                 (in-another-thread
                  (apply backend uri all-args))
               (with-mutex logging-mutex
                 (format (current-error-port) (G_ "~a: ~s ~a ~s: ~s ~a bytes\n")
                         date method uri-string headers response
                         (cond
                          ((bytevector? response-body)
                           (bytevector-length response-body))
                          ((string? response-body)
                           (string-length response-body))
                          (else 0))))
               (values response response-body))))))
      (f))))

(define (setup-http-request f)
  (use-logging-request
   (lambda ()
     (let ((base-http-request (p:anonymous-http-request)))
       (parameterize ((p:anonymous-http-request
                       (lambda* (uri . args)
                         (with-mutex logging-mutex
                           (format (current-output-port)
                                   (G_ "~a: connecting to ~s\n")
                                   (date->string (time-utc->date (current-time)))
                                   (uri-host uri)))
                         (apply base-http-request uri args))))
         (use-cache
          (lambda ()
            (use-catalog
             (lambda ()
               (f))))))))))

(define (request-ip-address request)
  ;; The IP address of the remote end
  (let ((socket (request-port request)))
    (let ((peer (getpeername socket)))
      (let ((family (sockaddr:fam peer))
            (address (sockaddr:addr peer)))
        (inet-ntop family address)))))

(define (handler-with-log endpoint log-file error-file complete-corresponding-source)
  (lambda (request request-body . _)
    (when log-file
      (prepare-log-file log-file))
    (when error-file
      (prepare-error-file error-file))
    (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)))
                   (web-locale request))
      (receive (response response-body user cause)
          (call/ec
           (lambda (return)
             (with-exception-handler
                 (lambda (error)
                   (if (web-exception? error)
                       (return
                        (build-response #:code (web-exception-code error)
                                        #:reason-phrase (web-exception-reason-phrase error)
                                        #:headers `((content-type application/xhtml-xml)))
                        (call-with-output-string
                          (cute sxml->xml
                                `(*TOP*
                                  (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                                  (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                                           (xml:lang ,(W_ "xml-lang|en")))
                                        (head
                                         (title ,(W_ "An error happened…")))
                                        (body
                                         ,(call-with-input-string
                                              (format #f (W_ "<p>Sorry, an error happened.</p>"))
                                            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: <http://www.w3.org/ns/earl#> .
@prefix doap: <http://usefulinc.com/ns/doap#> .
@prefix xsd: <http://www.w3.org/2001/XMLSchema#> .
@prefix solid-test: <https://github.com/solid/conformance-test-harness/vocab#> .

<> a earl:Software, earl:TestSubject ;
   doap:name ~s ;
   doap:release [ doap:name ~s ; doap:revision ~s ; doap:created ~s^^xsd:date ] ;
   doap:developer <https://data.planete-kraus.eu/vivien#me> ;
   doap:homepage <https://webid-oidc.planete-kraus.eu> ;
   doap:description \"Solid implementation to protect users’ freedom\"@en,
                    \"Implémentation de Solid pour garantir la liberté des utilisateurs\"@fr ;
   doap:programming-language \"GNU Guile\" ;
   solid-test:features \"authentication\", \"acl\", \"wac-allow\" .
"
                cfg:package
                (format #f "~a ~a" cfg:package cfg:version)
                cfg:version
                (date->string cfg:release-date "~1")))
       (else
        (let ((complete-corresponding-source
               (option-ref options complete-corresponding-source-sym #f))
              (log-file-name
               (option-ref options log-file-sym #f))
              (error-file-name
               (option-ref options error-file-sym #f))
              (port
               (let ((port (string->number (option-ref options port-sym "8080"))))
                 (unless port
                   (format (current-error-port)
                           (G_ "The --~a argument must be a number, not ~s.\n")
                           port-sym
                           (option-ref options port-sym "8080"))
                   (exit 1))
                 (unless (integer? port)
                   (format (current-error-port)
                           (G_ "The --~a argument must be an integer, not ~s.\n")
                           port-sym
                           port)
                   (exit 1))
                 (unless (> port 0)
                   (format (current-error-port)
                           (G_ "The --~a argument must be positive, ~s is invalid.\n")
                           port-sym port)
                   (exit 1))
                 (unless (<= port 65535)
                   (format (current-error-port)
                           (G_ "The --~a argument must be less than 65536, ~s is invalid.\n")
                           port-sym port)
                   (exit 1))
                 port))
              (configuration
               (let ((file-name (option-ref options configuration-sym #f)))
                 (and file-name
                      (load file-name)))))
          (if configuration
              (begin
                (unless complete-corresponding-source
                  (format (current-error-port)
                          (G_ "--~a is required when running a server.\n")
                          complete-corresponding-source-sym)
                  (exit 1))
                (run-server*
                 (handler-with-log configuration
                                   log-file-name
                                   error-file-name
                                   complete-corresponding-source)
                 #:implementation 'http
                 #:open-params (list #:port port)))
              (eval
               '(main)
               (resolve-module '(webid-oidc client gui))))))))))

(define-public (main)
  (setup-http-request inner-main))