[gnunet-scheme] 104/324: config: Implement variable expansion.

[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 59247284c041c9fe72569e1679ee7a690d0d0e71
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Apr 5 14:05:25 2021 +0200

    config: Implement variable expansion.
    
    * gnu/gnunet/config/expand.scm: Define procedures for expanding
      variable references.
    * tests/config-expand.scm: Test the module.
    * README.org (Configuration): Note the module exists.
    * Makefile.am
      (Modules): Compile the module.
      (SCM_TESTS): Run the test.
---
 Makefile.am                  |   5 +-
 README.org                   |   2 +
 gnu/gnunet/config/expand.scm | 196 ++++++++++++++++++++++++++++
 tests/config-expand.scm      | 296 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 498 insertions(+), 1 deletion(-)

diff --git a/Makefile.am b/Makefile.am
index 79a3187..84d0438 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -47,7 +47,9 @@ modules = \
   gnu/gnunet/utils/hat-let.scm \
   gnu/gnunet/utils/netstruct.scm \
   gnu/gnunet/utils/platform-enum.scm \
+  \
   gnu/gnunet/config/parser.scm \
+  gnu/gnunet/config/expand.scm \
   \
   gnu/gnunet/util/cmsg.scm \
   gnu/gnunet/icmp/struct.scm \
@@ -98,7 +100,8 @@ SCM_TESTS = \
   tests/message-io.scm \
   tests/bv-slice.scm \
   tests/cmsg.scm \
-  tests/config-parser.scm
+  tests/config-parser.scm \
+  tests/config-expander.scm
 
 SCM_TESTS_ENVIRONMENT = \
   GUILE_AUTO_COMPILE=0 \
diff --git a/README.org b/README.org
index 1c504ee..3414a62 100644
--- a/README.org
+++ b/README.org
@@ -75,6 +75,8 @@
    + TODO filling the queues
 ** Configuration
    + gnu/gnunet/config/parser.scm: Parse configuration files.
+   + gnu/gnunet/config/expand.scm: Perform variable expansion.
+
    TODO: writing, modifying, querying ...
 ** Network structures
    Features:
diff --git a/gnu/gnunet/config/expand.scm b/gnu/gnunet/config/expand.scm
new file mode 100644
index 0000000..6d032d4
--- /dev/null
+++ b/gnu/gnunet/config/expand.scm
@@ -0,0 +1,196 @@
+;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;; Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
+;; Copyright (C) 2006, 2007, 2008, 2009, 2013, 2020 GNUnet e.V.
+;;
+;; 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
+
+;; Author: Christian Grothoff (upstream, C)
+;; Author: Maxime Devos (downstream, Scheme)
+;; Brief: perform variable expansion.
+(define-library (gnu gnunet config expand)
+  (export expand port-writer expand->string
+
+         &expansion-error expansion-error?
+         &expansion-loop-error make-expansion-loop-error
+         expansion-loop-error? expansion-loop-error-visited
+         &undefined-variable-error undefined-variable-error?
+         make-undefined-variable-error undefined-variable-line
+         undefined-variable-start undefined-variable-end)
+  (import (only (rnrs base)
+               define call-with-values let-syntax syntax-rules
+               cond assert begin lambda quote ... procedure?
+               cons vector values vector-ref
+               - for-each and)
+         (only (rnrs control)
+               case-lambda when)
+         (only (rnrs io ports)
+               put-string)
+         (only (rnrs exceptions)
+               raise)
+         (only (rnrs conditions)
+               define-condition-type &error)
+         (only (srfi :1) any)
+         (only (guile)
+               call-with-output-string)
+         (only (gnu gnunet config parser)
+               literal-position? expo:literal-start expo:literal-end
+               $-position? expo:$-name-start expo:$-name-end
+               #{${}-position?}# #{expo:${}-name-start}#
+               #{expo:${}-name-end}# #{${:-}-position?}#
+               #{expo:${:-}-name-start}# #{expo:${:-}-name-end}#
+               #{expo:${:-}-value-parts}#)
+         (only (gnu gnunet utils hat-let)
+               let^))
+  (begin
+    (define-condition-type &expansion-error &error
+      %make-expansion-error expansion-error?)
+
+    ;; TODO perhaps more context information could be useful?
+    ;; As in, a stack of variables we were expanding?
+    ;; (The fields and constructor can change.)
+    (define-condition-type &undefined-variable-error &expansion-error
+      make-undefined-variable-error undefined-variable-error?
+      (line undefined-variable-line)
+      (start undefined-variable-start)
+      (end undefined-variable-end))
+
+    (define-condition-type &expansion-loop-error &expansion-error
+      make-expansion-loop-error expansion-loop-error?
+      ;; A list (length >= 2) of #(line start end).
+      ;; Each element represents a variable reference.
+      ;; The variable references are ordered from deepest
+      ;; to least deep.  The first element is a variable
+      ;; reference that occurred later.
+      (visited expansion-loop-error-visited))
+
+    
+    ;; The basic expansion code.
+    (define (expand write-region query region=? line expo-list)
+      "Expand @var{expo-list}, a list of expansions objects
+(that is, a list of @code{<expo:...>} objects from the module
+@code{(gnu gnunet config parser)}).  The positions in @var{expo-list}
+are relative to the line @var{line}.
+
+The procedure @var{write-region} is called in-order with the
+line, start (inclusive) and end (exclusive) position of a region of
+text to write.
+
+When a variable reference is encountered, the procedure @var{query}
+is called with the line, start (inclusive) and end (exclusive) position
+of the variable name, returning no value if the variable is undefined.
+If the variable is defined, two values are returned: the line of the
+variable definition, and a list of expansion objects
+
+To ensure infinite recursion, the six-argument procedure @code{region=?}
+can be called on two regions containing a variable reference, to test
+if they refer to the same variable.  In case a variable loop is encountered,
+some text regions might already be written, and an appropriate
+@code{&expansion-loop-error} is raised.
+
+The condition @code{&undefined-variable-error} can also be raised.  Other
+expansion errors might be defined in the future; they will be
+subtypes of @©ode{&expansion-error}.
+
+Quotes are not removed from literal expansion objects.
+No restrictions are set on what constitutes a line."
+      (assert (and (procedure? write-region)
+                  (procedure? query)
+                  (procedure? region=?)))
+      (expand* write-region query region=? line expo-list '()))
+
+    ;; The variables we're expanding are accumulated in @var{visited}.
+    ;;
+    ;; It would be possible to use a parameter instead, but that wouldn't
+    ;; behave nicely if the procedures @code{region=?}, @code{write-region}
+    ;; or @code{query/basic} try to parse a GNUnet configuration file
+    ;; -- I don't know *why* anyone would do that, but let's prevent
+    ;; potential headaches anyway.
+    (define (expand* write-region query/basic region=? line expo-list visited)
+      (define (recurse line expo-list visited)
+       (expand* write-region query/basic region=? line expo-list visited))
+      ;; Like @code{recurse}, but add a variable reference to the 
@code{visited}
+      ;; list.
+      (define (recurse/visit new-line expo-list start end)
+       (recurse new-line expo-list (cons (vector line start end) visited)))
+      ;; Like @code{query/basic}, but first make sure we are
+      ;; not already expanding an equivalent variable reference.
+      (define (query line start end)
+       (when (any (lambda (x)
+                    (region=? (vector-ref x 0) (vector-ref x 1)
+                              (vector-ref x 2) line start end))
+                  visited)
+         (raise (make-expansion-loop-error
+                 (cons (vector line start end) visited))))
+       (query/basic line start end))
+      (define (query-required line start end)
+       (call-with-values (lambda () (query line start end))
+         (case-lambda
+           (() (raise (make-undefined-variable-error line start end)))
+           ((line expo-list) (values line expo-list))
+           (e e))))
+      (define (expand expo)
+       (let-syntax ((type-cond
+                     (syntax-rules ()
+                       ((_ (predicate exp) ...)
+                        (cond ((predicate expo) exp)
+                              ...
+                              (#t (assert #f)))))))
+         (type-cond
+          (literal-position?
+           (write-region line (expo:literal-start expo)
+                         (expo:literal-end expo)))
+          ($-position?
+           (let^ ((! start (expo:$-name-start expo))
+                  (! end (expo:$-name-end expo))
+                  (<-- (line expo-list)
+                       (query-required line start end)))
+                 (recurse/visit line expo-list start end)))
+          (#{${}-position?}#
+           (let^ ((! start (#{expo:${}-name-start}# expo))
+                  (! end (#{expo:${}-name-end}# expo))
+                  (<-- (line expo-list)
+                       (query-required line start end)))
+                 (recurse/visit line expo-list start end)))
+          (#{${:-}-position?}#
+           (let^ ((! start (#{expo:${:-}-name-start}# expo))
+                  (! end (#{expo:${:-}-name-end}# expo)))
+                 (call-with-values
+                     (lambda () (query line start end))
+                   (case-lambda
+                     ;; If this variable is undefined, use the default.
+                     (()
+                      (recurse line (#{expo:${:-}-value-parts}# expo) visited))
+                     ((line expo-list)
+                      (recurse/visit line expo-list start end)))))))))
+      (for-each expand expo-list)
+      (values))
+
+    
+    (define (port-writer port)
+      "Make a @code{write-region} procedure for @code{expand}
+expecting lines to be strings, that writes text regions to the port
+@var{port}."
+      (define (write-region line start end)
+       (put-string port line start (- end start)))
+      write-region)
+
+    (define (expand->string query region=? line expo-list)
+      "Like @code{expand}, but expect lines to be strings and return
+the expanded text as a string.  TODO something about interrupts,
+query and continuations."
+      (call-with-output-string
+       (lambda (port)
+         (expand (port-writer port) query region=? line expo-list))))))
diff --git a/tests/config-expand.scm b/tests/config-expand.scm
new file mode 100644
index 0000000..8badbf5
--- /dev/null
+++ b/tests/config-expand.scm
@@ -0,0 +1,296 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 Maxime Devos
+;;
+;; 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: AGPL3.0-or-later
+
+(use-modules (gnu gnunet config parser)
+            (gnu gnunet config expand)
+            (srfi srfi-64))
+
+(define (region=? line1 start1 end1
+                 line2 start2 end2)
+  (string=? (substring/shared line1 start1 end1)
+           (substring/shared line2 start2 end2)))
+
+(define (query/not line start end)
+  (error "this test should not call the query procedure"))
+
+(define (region=?/not line1 start1 end1
+                     line2 start2 end2)
+  (error "this test should not call the region=? procedure"))
+
+;; § Literals
+(test-equal "literal"
+  "text"
+  (expand->string query/not region=?/not "text"
+                 (list (make-literal-position 0 4))))
+
+(test-equal "part of literal (1)"
+  "text"
+  (expand->string query/not region=?/not "some text"
+                 (list (make-literal-position 5 9))))
+
+(test-equal "part of literal (2)"
+  "some"
+  (expand->string query/not region=?/not "some text"
+                 (list (make-literal-position 0 4))))
+
+(test-equal "quotes are not removed"
+  "'text'"
+  (expand->string query/not region=?/not "'text'"
+                 (list (make-literal-position 0 6))))
+
+(test-equal "zero literals"
+  ""
+  (expand->string query/not region=?/not 'anything '()))
+
+(test-equal "two overlapping literals"
+  "spoon"
+  (expand->string query/not region=?/not "spon"
+                 (list (make-literal-position 0 3)
+                       (make-literal-position 2 4))))
+;; § Variable references
+(define (alist->query alist)
+  (lambda (line start end)
+    (let ((entry (assoc (substring line start end) alist)))
+      (if entry
+         (apply values (cdr entry))
+         (error "this variable was not meant to be encountered"
+                line start end)))))
+
+(test-equal "variable reference ($)"
+  "iable"
+  (expand->string (alist->query `(("var" "variable"
+                                  (,(make-literal-position 3 8)))))
+                 region=?/not "$var"
+                 (list (make-$-position 1 4))))
+
+(test-equal "variable reference (${})"
+  "iable"
+  (expand->string (alist->query `(("var" "variable"
+                                  (,(make-literal-position 3 8)))))
+                 region=?/not "${var}"
+                 (list (#{make-${}-position}# 2 5))))
+
+(test-equal "variable reference (${:-})"
+  "iable"
+  (expand->string (alist->query `(("var" "variable"
+                                  (,(make-literal-position 3 8)))))
+                 region=?/not "${var:-default}"
+                 (list (#{make-${:-}-position}# 2 5 7 14 '()))))
+
+;; This is the expander, not the parser.
+(test-equal "expander does not care about delimiters ($)"
+  "iable"
+  (expand->string (alist->query `(("#@}!/" "variable"
+                                  (,(make-literal-position 3 8)))))
+                 region=?/not "${pre}#@}!/${post}"
+                 (list (make-$-position 6 11))))
+
+(test-equal "expander does not care about delimiters (${})"
+  "iable"
+  (expand->string (alist->query `(("#@}!/" "variable"
+                                  (,(make-literal-position 3 8)))))
+                 region=?/not "${pre}#@}!/${post}"
+                 (list (#{make-${}-position}# 6 11))))
+
+(test-equal "expander does not care about delimiters (${:-})"
+  "iable"
+  (expand->string (alist->query `(("#@}!/" "variable"
+                                  (,(make-literal-position 3 8)))))
+                 region=?/not "${pre}#@}!/${post}"
+                 (list (#{make-${:-}-position}# 6 11 13 15 '()))))
+
+(test-equal "undefined variable -> default (${:-})"
+  "default"
+  (expand->string (alist->query '(("var")))
+                 region=?/not "var  default"
+                 (list (#{make-${:-}-position}# 0 3 5 12
+                        (list (make-literal-position 5 12))))))
+
+(test-equal "undefined variable -> default (${:-}, recursive)"
+  "default"
+  (expand->string (alist->query `(("var")
+                                 ("var2" "default"
+                                  (,(make-literal-position 0 7)))))
+                 region=?/not "var  var2"
+                 (list (#{make-${:-}-position}# 0 3 5 9
+                        (list (make-$-position 5 9))))))
+
+;; § Exceptions (undefined variable)
+;;
+;; Convert the exception into a S-expression
+;; to be able to compare results with @code{equal?}.
+(define (expand->string/catch query region=? line expo-list)
+  (with-exception-handler
+      (lambda (e)
+       (cond ((undefined-variable-error? e)
+              `(undefined-variable-error
+                (line ,(undefined-variable-line e))
+                (start ,(undefined-variable-start e))
+                (end ,(undefined-variable-end e))))
+             ((expansion-loop-error? e)
+              `(expansion-loop-error
+                (visited . ,(expansion-loop-error-visited e))))
+             (#t (error "what is this madness"))))
+    (lambda ()
+      (expand->string query region=? line expo-list))
+    #:unwind? #t
+    #:unwind-for-type &expansion-error))
+
+(test-equal "undefined variable -> exception ($)"
+  `(undefined-variable-error
+    (line "var")
+    (start 0)
+    (end 3))
+  (expand->string/catch (alist->query '(("var")))
+                       region=?/not "var"
+                       (list (make-$-position 0 3))))
+
+(test-equal "undefined variable -> exception (${})"
+  `(undefined-variable-error
+    (line "var")
+    (start 0)
+    (end 3))
+  (expand->string/catch (alist->query '(("var")))
+                       region=?/not "var"
+                       (list (#{make-${}-position}# 0 3))))
+
+;; Like @code{region=?}, but #(line start end) must be in @var{acceptable}.
+(define (region=?/restricted . acceptable)
+  (lambda (line1 start1 end1 line2 start2 end2)
+    (unless (and (member (vector line1 start1 end1) acceptable)
+                (member (vector line2 start2 end2) acceptable))
+      (error "where did this variable reference come from?"
+            (vector line1 start1 end1)
+            (vector line2 start2 end2)))
+    (region=? line1 start1 end1 line2 start2 end2)))
+
+(test-equal "undefined variable (nested) -> exception ($, correct line)"
+  `(undefined-variable-error
+    (line "var1 = $var2")
+    (start 8)
+    (end 12))
+  (expand->string/catch (alist->query `(("var1" "var1 = $var2"
+                                        (,(make-$-position 8 12)))
+                                       ("var2")))
+                       (region=?/restricted
+                        #("$var1" 1 5)
+                        #("var1 = $var2" 8 12))
+                       "$var1"
+                       (list (make-$-position 1 5))))
+
+(test-equal "undefined variable (nested) -> exception (${}, correct line)"
+  `(undefined-variable-error
+    (line "var1 = ${var2}")
+    (start 9)
+    (end 13))
+  (expand->string/catch (alist->query `(("var1" "var1 = ${var2}"
+                                        (,(#{make-${}-position}# 9 13)))
+                                       ("var2")))
+                       (region=?/restricted
+                        #("$var1" 1 5)
+                        #("var1 = ${var2}" 9 13))
+                       "$var1"
+                       (list (make-$-position 1 5))))
+
+;; § Exceptions (loops)
+
+;; Verify the line number information and verify the loopiness is
+;; visible in the ‘visited’ list.
+
+(test-equal "loop ($, $)"
+  `(expansion-loop-error
+    (visited #("var = the $variable" 11 19)
+            #("variable = $var" 12 15)
+            #("$variable" 1 9)))
+  (expand->string/catch (alist->query `(("variable"
+                                        "variable = $var"
+                                        (,(make-$-position 12 15)))
+                                       ("var"
+                                        "var = the $variable"
+                                        (,(make-$-position 11 19)))))
+                       (region=?/restricted
+                        #("variable = $var" 12 15)
+                        #("var = the $variable" 11 19)
+                        #("$variable" 1 9))
+                       "$variable"
+                       (list (make-$-position 1 9))))
+
+(test-equal "loop (${}, ${})"
+  `(expansion-loop-error
+    (visited #("variable = ${var}" 13 16)
+            #("var = the ${variable}" 12 20)
+            #("$var" 1 4)))
+  (expand->string/catch (alist->query `(("variable"
+                                        "variable = ${var}"
+                                        (,(#{make-${}-position}# 13 16)))
+                                       ("var"
+                                        "var = the ${variable}"
+                                        (,(#{make-${}-position}# 12 20)))))
+                       (region=?/restricted
+                        #("variable = ${var}" 13 16)
+                        #("var = the ${variable}" 12 20)
+                        #("$var" 1 4))
+                       "$var"
+                       (list (#{make-$-position}# 1 4))))
+
+
+(test-equal "loop (${:-}, ${:-})"
+  `(expansion-loop-error
+    (visited #("variable = ${var:-}" 13 16)
+            #("var = the ${variable:-}" 12 20)
+            #("$var" 1 4)))
+  (expand->string/catch
+   (alist->query `(("variable"
+                   "variable = ${var:-}"
+                   (,(#{make-${:-}-position}# 13 16 18 18 '())))
+                  ("var"
+                   "var = the ${variable:-}"
+                   (,(#{make-${:-}-position}# 12 20 22 22 '())))))
+   (region=?/restricted
+    #("variable = ${var:-}" 13 16)
+    #("var = the ${variable:-}" 12 20)
+    #("$var" 1 4))
+   "$var"
+   (list (make-$-position 1 4))))
+
+(test-equal "${:-} with default --> no visited entry"
+  `(expansion-loop-error
+    (visited #("var = $var" 7 10)
+            #("${does-not-exist:-$var}" 19 22)))
+  (expand->string/catch
+   (alist->query `(("var" "var = $var"
+                   (,(make-$-position 7 10)))
+                  ("does-not-exist")))
+   (region=?/restricted
+    #("var = $var" 7 10)
+    #("${does-not-exist:-$var}" 19 22))
+   "${does-not-exist:-$var}"
+   (list (#{make-${:-}-position}# 2 16 18 22
+         (list (make-$-position 19 22))))))
+
+;; This should _not_ lead to an &expansion-loop-error.
+(test-equal "variable expanded multiple times"
+  "example example"
+  (expand->string/catch
+   (alist->query `(("var" "example"
+                   (,(make-literal-position 0 7)))))
+   region=?/not
+   "var "
+   (list (make-$-position 0 3)
+        (make-literal-position 3 4)
+        (make-$-position 0 3))))

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