[gnunet-scheme] 281/324: config: Implement loading a configuration file.

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit 316f627d4021343f4a81f53dd835308339f90a47
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Sep 13 13:51:07 2021 +0200

    config: Implement loading a configuration file.
    
    * doc/scheme-gnunet.tm (Loading configuration files): Unstub section.
    * gnu/gnunet/config/fs.scm (load-configuration/port!): New procedure.
    * tests/config-fs.scm
      (load-string->alist/unexpanded): New procedure.
      ("load-configuration/port!, literal read-value")
      ("load-configuration/port!, empty")
      ("load-configuration/port!, assignment outside section")
      ("load-configuration/port!, literal read-value after empty line")
      ("load-configuration/port!, section after empty line")
      ("load-configuration/port!, bogus syntax before section")
      ("load-configuration/port!, bogus syntax after section")
      ("load-configuration/port!, skip comment (#) after section")
      ("load-configuration/port!, skip comment (%) after section")
      ("load-configuration/port!, skip empty line after section")
      ("load-configuration/port!, skip comment (#) before section")
      ("load-configuration/port!, skip comment (%) before section")
      ("load-configuration/port!, skip empty line before section")
      ("load-configuration/port!, two sections"): New tests.
---
 doc/scheme-gnunet.tm     |  20 ++++++++-
 gnu/gnunet/config/fs.scm | 115 +++++++++++++++++++++++++++++++++++++++++++++--
 tests/config-fs.scm      |  83 ++++++++++++++++++++++++++++++++++
 3 files changed, 213 insertions(+), 5 deletions(-)

diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index a6c2ad2..b0608e0 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -145,7 +145,25 @@
 
   <subsection|Loading configuration files>
 
-  TODO: loading configurations from the disk
+  Once the location of the configuration file is known, the file can be
+  opened with the Scheme procedure <scm|open-input-file>, which returns an
+  input port.<space|1em>Then the procedure <scm|load-configuration/port!> can
+  be used to determine all section-key-values triples in the configuration.
+
+  <\explain>
+    <scm|(load-configuration/port! <var|set-value!> <var|port>)>
+  <|explain>
+    Load the configuration from the input port <var|port>.
+
+    For each variable, call <var|set-value!> with the section name, variable
+    name and a vector of the form <scm|#(line line-number value)>, where
+    <var|value> a list of expansible objects.
+
+    <todo|document expansible objects><todo|error reporting>
+  </explain>
+
+  <todo|loading configuration files from the disk><todo|expanding
+  configuration files>
 
   <subsection|Value types>
 
diff --git a/gnu/gnunet/config/fs.scm b/gnu/gnunet/config/fs.scm
index 0a39679..02a1916 100644
--- a/gnu/gnunet/config/fs.scm
+++ b/gnu/gnunet/config/fs.scm
@@ -16,17 +16,39 @@
 ;;
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 
+;; There are three steps to loading configuration files:
+;;
+;;   * DONE locating the configuration files
+;;   * DONE parsing the configuration files into a table of
+;;     (section, variable) --> value, without expanding anything
+;;   * TODO 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)
+         locate-user-configuration
+         load-configuration/port!)
   (import (only (rnrs base)
-               begin define and not or)
+               begin define and not or cond define-syntax identifier-syntax
+               if ... eq? values + lambda quote vector)
          (only (ice-9 optargs)
                define*)
+         (only (ice-9 rdelim)
+               read-line)
          (only (guile)
-               getenv in-vicinity string-null?)
+               getenv in-vicinity string-null? define-syntax-rule eof-object?
+               substring error syntax-error define-syntax-parameter
+               syntax-parameterize syntax-violation identity)
          (only (gnu gnunet utils hat-let)
-               let^))
+               let^)
+         (gnu gnunet config parser))
   (begin
     (define (locate-system-configuration)
       "/etc/gnunet.conf")
@@ -60,5 +82,90 @@ The values of environment variables is determined with the 
procedure
                    (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*)))
+
     ;; TODO actually load the configuration, defaults, ...
     ))
diff --git a/tests/config-fs.scm b/tests/config-fs.scm
index f44770f..e457b0a 100644
--- a/tests/config-fs.scm
+++ b/tests/config-fs.scm
@@ -17,6 +17,7 @@
 ;; SPDX-License-Identifier: AGPL3.0-or-later
 
 (import (gnu gnunet config fs)
+       (gnu gnunet config parser)
        (srfi srfi-64))
 (test-begin "config-fs")
 
@@ -62,4 +63,86 @@
    #:getenv
    (alist->getenv '(("HOME" . "")))))
 
+(define (load-string->alist/unexpanded s)
+  (call-with-input-string s
+    (lambda (p)
+      (define a '())
+      (define (set-value! section key value)
+       (pk 's section key value)
+       (set! a `(((,section . ,key) . ,value) ,@a))
+       (values))
+      (load-configuration/port! set-value! p)
+      a)))
+
+;; TODO: better error reporting
+
+(test-equal "load-configuration/port!, literal read-value"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 2 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "[section]\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, empty"
+  '()
+  (load-string->alist/unexpanded ""))
+
+(test-error "load-configuration/port!, assignment outside section"
+  "assignment outside section"
+  (load-string->alist/unexpanded "VAR = VALUE"))
+
+(test-equal "load-configuration/port!, literal read-value after empty line"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "[section]\n\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, section after empty line"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "\n[section]\nVAR = VALUE"))
+
+(test-error "load-configuration/port!, bogus syntax before section"
+  "unrecognised syntax at line ???"
+  (load-string->alist/unexpanded "]\n[section]\n"))
+
+(test-error "load-configuration/port!, bogus syntax after section"
+  "unrecognised syntax at line ???"
+  (load-string->alist/unexpanded "[section]\n]"))
+
+(test-equal "load-configuration/port!, skip comment (#) after section"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "[section]\n#\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, skip comment (%) after section"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "[section]\n#\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, skip empty line after section"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "[section]\n\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, skip comment (#) before section"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "#\n[section]\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, skip comment (%) before section"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "%\n[section]\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, skip empty line before section"
+  `((("section" . "VAR")
+     . #("VAR = VALUE" 3 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded "\n[section]\nVAR = VALUE"))
+
+(test-equal "load-configuration/port!, two sections"
+  `((("section2" . "VAR2")
+     . #("VAR2 = VALUE2" 4 (,(make-literal-position 7 13))))
+    (("section1" . "VAR")
+     . #("VAR = VALUE" 2 (,(make-literal-position 6 11)))))
+  (load-string->alist/unexpanded
+   "[section1]\nVAR = VALUE\n[section2]\nVAR2 = VALUE2"))
+
 (test-end "config-fs")

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.