path: root/gnu/gnunet/config/fs.scm

;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;; Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
;;
;; scheme-GNUnet 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.
;;
;; scheme-GNUnet 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 <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later

;; There are three steps to loading configuration files:
;;
;;   * locating the configuration files
;;   * parsing the configuration files into a table of
;;     (section, variable) --> value, without expanding anything
;;   * expanding the previous table
;;
;; Expanding the table and loading the table have to be done separately,
;; because variables do not have to be defined in any specific order,
;; so a variable defined early could refer to a variable defined later.
;;
;; The last two steps are largely implemented by (gnu gnunet config expand)
;; and (gnu gnunet config parser), but some glue is required to make them
;; work with ports.

(define-library (gnu gnunet config fs)
  (export locate-system-configuration
	  locate-user-configuration
	  load-configuration
	  load-configuration/port!
	  make-expanded-configuration)
  (import (only (rnrs base)
		begin define and not or cond define-syntax identifier-syntax
		if ... eq? values + lambda quote vector car cdr cons string?
		string-length vector? vector-ref string=? list)
	  (only (rnrs control)
		when)
	  (prefix (rnrs hashtables)
		  rnrs:)
	  (only (ice-9 optargs)
		define*)
	  (only (ice-9 rdelim)
		read-line)
	  (only (guile)
		getenv in-vicinity string-null? define-syntax-rule eof-object?
		substring error syntax-error define-syntax-parameter
		syntax-parameterize syntax-violation identity
		make-hash-table hash-set! hash-ref hash-for-each
		call-with-input-file for-each file-exists?
		search-path %load-path)
	  (only (gnu gnunet utils hat-let)
		let^)
	  (gnu gnunet config db)
	  (gnu gnunet config expand)
	  (gnu gnunet config parser))
  (begin
    (define (locate-defaults)
      (search-path %load-path "gnu/gnunet/config/default.conf"))

    (define (locate-system-configuration)
      "/etc/gnunet.conf")

    (define* (locate-user-configuration #:key (getenv getenv))
      "Determine the location of the user configuration file,
as a string, or @code{#false} if it could not be determined.
If the location of the user configuration file is known,
but the file does not exist, it is returned anyway, as a string.

If the environment variable @code{XDG_CONFIG_HOME} is set, the
location of the file @code{gnunet.conf} in the directory
@code{XDG_CONFIG_HOME} is returned.  If the environment variable
is not set, the location of the file at @code{.config/gnunet.conf}
in the home directory specified by the environment variable
@code{HOME} is returned, if that environment variable exist.
If both are unset, @code{#false} is returned.

The values of environment variables is determined with the procedure
@var{getenv}."
      (define (locate/HOME)
	(define HOME (getenv "HOME"))
	;; It is possible, though inadvisable, for HOME
	;; to be unset.
	(and HOME (not (string-null? HOME))
	     (in-vicinity HOME (in-vicinity ".config" "gnunet.conf"))))
      (let^ ((! XDG_CONFIG_HOME (getenv "XDG_CONFIG_HOME"))
	     ;; If the environment variable is unset, fall-back to
	     ;; $HOME.
	     (? (or (not XDG_CONFIG_HOME)
		    (string-null? XDG_CONFIG_HOME))
		(locate/HOME)))
	    (in-vicinity XDG_CONFIG_HOME "gnunet.conf")))

    (define (load-configuration/port! set-value! port)
      "Load the configuration from the input port @var{port}.

For each variable, call @code{set-value!} with the section name,
variable name, and a vector of the form @code{#(line line-number value)},
where @var{value} is a list of expansible objects."
      (define (read-object)
	(define line (read-line port))
	(if (eof-object? line)
	    (values line line)
	    (values line (parse-line line))))
      ;; The current line number
      (define-syntax-parameter line-number
	(lambda (stx)
	  (syntax-violation 'ln "line-number outside loop" stx)))
      ;; The current line, as a string
      (define-syntax-parameter line
	(lambda (stx)
	  (syntax-violation 'l "line outside loop" stx)))
      ;; The result of parsing the current line.
      (define-syntax-parameter object
	(lambda (stx)
	  (syntax-violation 'o "object outside loop" stx)))
      (define-syntax-rule (define-loop (loop arg ...) exp ...)
	(define (loop line-number* line* object* arg ...)
	  (syntax-parameterize ((line-number (identifier-syntax line-number*))
				(line (identifier-syntax line*))
				(object (identifier-syntax object*)))
	    exp ...)))
      (define-syntax-rule (define-loops (((loop loop*) arg ...) exp ...) ...)
	(begin
	  (begin
	    (define-loop (loop arg ...)
	      exp ...)
	    (define-syntax-rule (loop* arg ...)
	      (let^ ((<-- (line object) (read-object)))
		    (loop (+ 1 line-number) line object arg ...))))
	  ...))
      (define-loops
	(((no-section no-section*))
	 (cond ((#{[]-position?}# object)
		(section*
		 (substring line
			    (position:section-name-start object)
			    (position:section-name-end object))))
	       ((=-position? object)
		(error "assignment outside section"))
	       ((@inline@-position? object)
		(error "inclusion directives are not supported"))
	       ((eq? object #f)
		(error "unrecognised syntax at line ???"))
	       ((eof-object? object) (values)) ; done
	       ;; comments, empty line
	       (#t (no-section*))))
	(((section section*) section-name)
	 (cond ((#{[]-position?}# object)
		(section*
		 (substring line
			    (position:section-name-start object)
			    (position:section-name-end object))))
	       ((=-position? object)
		(let^ ((! variable-name
			  (substring line
				     (position:variable-start object)
				     (position:variable-end object)))
		       (<-- (expo-list . end)
			    (parse-expandable* line
					       (position:value-start object)
					       (position:value-end object)
					       #f)))
		      (set-value! section-name variable-name
				  (vector line line-number expo-list))
		      (section* section-name)))
	       ((@inline@-position? object)
		(error "inclusion directives are not supported"))
	       ((eq? object #f)
		(error "unrecognised syntax at line ????"))
	       ((eof-object? object) (values)) ; done
	       ;; comments, empty line
	       (#t (section* section-name)))))
      ;; TODO: start lines at 0 or 1?  Likewise for columns.
      (syntax-parameterize ((line-number (identifier-syntax 0)))
	(no-section*)))

    (define* (make-expanded-configuration load! #:key (getenv getenv))
      "Make a configuration object.  To populate the configuration,
call the procedure @var{load!} with a @code{set-value!} procedure as expected
by @code{load-configuration/port!}.  The values from @code{set-value!}
are added to the configuration and every variable is expanded."
      (define hash (make-hash-table))
      (define (set-unexpanded-value! section key value-vector)
	(hash-set! hash (cons section key) value-vector))
      (load! set-unexpanded-value!)
      (define config (hash->configuration (rnrs:make-hashtable hash-key key=?)))
      (define (substring=? line0 start0 end0 line1 start1 end1)
	(string=? (substring line0 start0 end0)
		  (substring line1 start1 end1)))
      (define (query line start end)
	(define variable (substring line start end))
	;; In the section PATHS, variables participating in expansion can be
	;; defined.
	(define unexpanded-value
	  (or (hash-ref hash (cons "PATHS" variable))
	      (getenv variable)))
	(cond ((string? unexpanded-value) ; result of getenv
	       (values unexpanded-value
		       (list (make-literal-position
			      0 (string-length unexpanded-value)))))
	      ((vector? unexpanded-value)
	       (values (vector-ref unexpanded-value 0) ; line
		       (vector-ref unexpanded-value 2))) ; list of expo objects
	      (#t (values)))) ; undefined variable
      (hash-for-each
       (lambda (key value)
	 (define line (vector-ref value 0))
	 (define expo-list (vector-ref value 2))
	 (define expanded-value
	   (expand->string query substring=? line expo-list))
	 (set-value! identity config (car key) (cdr key) expanded-value))
       hash)
      config)

    ;; XXX no tests
    (define* (load-configuration #:key (getenv getenv)
				 (files (list (locate-defaults)
					      (locate-system-configuration)
					      (locate-user-configuration
					       #:getenv getenv))))
      "Load the user configuration, system configuration and defaults.
The configuration files to load can be overridden by setting @var{files}
appropriately."
      (define configurations
	(list (locate-system-configuration)
	      (locate-user-configuration)))
      (define (load! set-value!)
	(define (load-file! file)
	  (when (and file (file-exists? file))
	    (call-with-input-file file
	      (lambda (p)
		(load-configuration/port! set-value! p))
	      #:guess-encoding #t
	      #:encoding "UTF-8")))
	(for-each load-file! configurations))
      (define c (make-expanded-configuration load! #:getenv getenv))
      c)

    ;; TODO error reporting
    ))