path: root/gnu/gnunet/config/value-parser.scm

;; This file is part of scheme-GNUnet.
;; Copyright (C) 2005-2021 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: AGPL3.0-or-later

;; Brief: parse values in configuration files
;; Upstream source: src/util/configuration.c
;; Upstream author (GNUnet, C): Christian Grothoff
;; Downstream author (GNUnet, Scheme): Maxime Devos
;; Tests: tests/config-value-parser.scm
;;
;; Values are parsed with procedures names @code{value->X}.
;; These procedures do not eat whitespace.
;; In case of a syntax error, a subtype of @code{&value-parse-error}
;; is raised.

(define-library (gnu gnunet config value-parser)
  (export &value-parse-error value-parse-error?
	  make-value-parse-error value-parse-error-text
	  &value-parse/natural-error value-parse/natural-error?
	  make-value-parse/natural-error
	  &value-parse/float-error value-parse/float-error?
	  make-value-parse/float-error
	  &value-parse/boolean-error value-parse/boolean-error?
	  make-value-parse/boolean-error
	  &value-parse/size-error value-parse/size-error?
	  make-value-parse/size-error
	  &value-parse/choice-error value-parse/choice-error?
	  make-value-parse/choice-error
	  value->natural value->float #;value->relative-time
	  value->boolean value->size value->choice
	  value->file-name)
  (import (only (gnu gnunet utils hat-let)
		let^)
	  (only (rnrs base)
		define if or and begin lambda let
		> = >= string=? string? cond
		expt + * assert vector-length vector-ref
		string-length char=? string-ref
		string->number not substring
		integer? exact? vector?)
	  (only (rnrs exceptions)
		raise)
	  (only (rnrs conditions)
		define-condition-type &error)
	  (only (rnrs r5rs)
		exact->inexact)
	  (only (srfi :4)
		u64vector u64vector-ref u64vector-length)
	  (only (srfi :43)
		vector-index)
	  ;; For cut.
	  (srfi srfi-26)
	  (only (guile)
		string->char-set make-regexp regexp-exec
		string-skip string-index))
  (begin
    (define-condition-type &value-parse-error &error
      make-value-parse-error value-parse-error?
      (text value-parse-error-text))

    (define-condition-type &value-parse/natural-error &value-parse-error
      make-value-parse/natural-error value-parse/natural-error?)
    (define-condition-type &value-parse/float-error &value-parse-error
      make-value-parse/float-error value-parse/float-error?)
    (define-condition-type &value-parse/boolean-error &value-parse-error
      make-value-parse/boolean-error value-parse/boolean-error?)
    (define-condition-type &value-parse/size-error &value-parse-error
      make-value-parse/size-error value-parse/size-error?)
    (define-condition-type &value-parse/choice-error &value-parse-error
      make-value-parse/choice-error value-parse/choice-error?)

    (define (value->natural text)
      "Parse @var{text} as a natural number.
In case of a parse error, raise an appropriate
@code{&value-parse/natural-error}."
      ;; string->number can *not* be used as-is here,
      ;; as it is supports too much syntax.
      ;; E.g., try (string->number "#x10" 10).
      (if (or (= (string-length text) 0)
	      (and (> (string-length text) 1)
		   (char=? (string-ref text 0) #\0))
	      (string-skip text cs:digits))
	  (raise (make-value-parse/natural-error text))
	  (string->number text)))

    (define float-regex
      (make-regexp "^((0|[1-9][0-9]*)(\\.[0-9]*)?|\\.[0-9]+)$"))

    (define (value->float text)
      "Parse @var{text} as a floating-point number.
In case of a parse error, raise an appropriate
@ code{&value-parse/float-error}."
      (if (regexp-exec float-regex text)
	  (exact->inexact (string->number text))
	  (raise (make-value-parse/float-error text))))

    (define (value->boolean text)
      "Parse @var{text} as a boolean (@code{#t} or @code{#f}).
In case of a parse error, raise an appropriate
@code{&value-parse/boolean-error}."
      (cond ((string=? text "YES") #t)
	    ((string=? text "NO") #f)
	    (#t (raise (make-value-parse/boolean-error text)))))

    (define cs:digits (string->char-set "0123456789"))

    ;; From gnunet/src/util/strings.c (convert_with_table),
    ;; with some changes.
    (define (convert-with-table text keys values error-thunk)
      "Let @var{text} be a string @code{\"N X M Y ...\"}, where @var{N}
@var{M} ... represent exact natural in decimal, and @var{X} @var{Y} ...
units from @var{keys}.  Return the sum of @var{N} @var{X} ..., where
@var{N} .. is interpreted as an integer and @var{X} is intepreted as a
unit, with value looked up in @var{keys} and @var{values}.

In case of a parsing error, the thunk @var{thunk-thunk} is called, and
probably should raise some kind of parsing error.  Spaces between @var{N}
and @var{X} ... are optional.

@var{keys} is a vector of non-empty strings that do not contain decimal
digits or spaces.  @var{values} is a SRFI-4 u64vector."
      (let^ ((/o/ loop
		  (start 0)
		  (accumulated 0))
	     ;; Find the start and end location of the number.
	     ;; Skip digits instead of searching for the whitespace
	     ;; between the number and unit.
	     ;;
	     ;; Otherwise, @var{number} below could be @code{#f},
	     ;; inexact or not an integer, or too much syntax would
	     ;; be recognised.  E.g., try @code{(string->number "#xf")}.
	     ;; Also, inputs like @code{"10s"} without a space should
	     ;; be recognised.
	     (! end-of-number (string-skip text cs:digits start))
	     ;; The number is supposed to be followed by a unit,
	     ;; and the number must be present!
	     (? (or (not end-of-number)
		    (= start end-of-number))
		(error-thunk))
	     ;; TODO: should multiple leading zeros be disallowed?
	     ;; Disallow leading zeros (unless the number is 0,
	     ;; in which case a single zero is accepted).
	     (? (and (> end-of-number (+ start 1))
		     (char=? (string-ref text start) #\0))
		(error-thunk))
	     ;; Parse the number.
	     (! number (string->number (substring text start end-of-number)))
	     (!! (and (integer? number)
		      (exact? number)
		      (>= number 0)))
	     ;; Find the start and end position of the unit.
	     ;; Skip the spaces between the number and the unit.
	     (! start-of-unit (string-skip text #\  end-of-number))
	     ;; There is supposed to be a (non-empty) unit!
	     (? (not start-of-unit) (error-thunk))
	     ;; Find out where the unit ends, by searching for the
	     ;; first whitespace (or end of string) after the unit.
	     (! end-of-unit (string-index text #\ start-of-unit))
	     (! unit (if end-of-unit
			 ;; substring/shared, substring/read-only,
			 ;; substring/copy and string-copy would work
			 ;; as well.
			 (substring text start-of-unit end-of-unit)
			 (substring text start-of-unit)))
	     ;; Look up the unit in @var{keys}.
	     (! unit-index
		(vector-index (cut string=? <> unit) keys))
	     ;; The unit might not be defined.
	     (? (not unit-index) (error-thunk))
	     (! unit-value (u64vector-ref values unit-index))
	     ;; Add the value of "N X".
	     (! accumulated (+ accumulated (* number unit-value)))
	     (? (not end-of-unit) accumulated)
	     ;; And continue with the rest of the string!
	     (! start (string-skip text #\  end-of-unit))
	     ;; Spaces are only allowed between numbers and units,
	     ;; not after the last unit.
	     (? (not start) (error-thunk)))
	    (loop start accumulated)))

    (define size-keys
      #("B"
	"KiB" "MiB" "GiB" "TiB" "PiB" "EiB"
	;; Yes, "kB" and not "KB".
	;; See strings.c in GNUnet C source code.
	;; TODO: check whether this is a bug.
	"kB" "MB" "GB" "TB" "PB" "EB"))
    (define size-values
      (u64vector
       1
       1024
       (expt 1024 2)
       (expt 1024 3)
       (expt 1024 4)
       (expt 1024 5)
       (expt 1024 6)
       1000
       (expt 1000 2)
       (expt 1000 3)
       (expt 1000 4)
       (expt 1000 5)
       (expt 1000 6)))
    (assert (= (vector-length size-keys)
	       (u64vector-length size-values)))

    (define (value->size text)
      "Evaluate a size (in bytes) expression @var{text}, e.g.
@code{\"1B 1 GiB 4 kB\"}."
      (convert-with-table text size-keys size-values
			  (lambda ()
			    (raise (make-value-parse/size-error text)))))

    ;; TODO: what would be most useful, epoch time, SRFI time,
    ;; which units ...
    #;
    (define (value->relative-time text)
      "Evaluate a relative time expression (in ???) @var{text}, e.g.
@code{\"1h 2m 3s\"}."
      (convert-with-table text relative-time-keys relative-time-values
			  (lambda ()
			    (raise (make-value-parse/relative-time-error)))))

    (define (value->choice text options-vector)
      "Let @var{options-vector} be a vector @code{#(x y ...)} with in the
even positions strings @var{x} ..., and in the odd positions objects @var{y}
...  If @var{text} is in @code{#(x ...)}, return the corresponding value in
@code{#(y ...)}, otherwise raise a @code{&value-parse/choice-error}."
      (assert (and (string? text) (vector? options-vector)))
      ;; Loop invariants:
      ;;  * @var{i} is a natural number
      ;;  * @var{i} is even
      ;;  * @var{i} is at most the length of @var{options-vector}
      ;;  * ∀ natural j, j even and j < i ==> options-vector[j] ≠ text
      ;;    (Alternatively: if @var{text} does appear in @var{options-vector},
      ;;    it will be at position @var{i} or higher.)
      (let loop ((i 0))
	(cond ((>= i (vector-length options-vector))
	       (raise (make-value-parse/choice-error text)))
	      ;; The key to test is at the current (even) position
	      ((string=? (vector-ref options-vector i) text)
	       ;; The value is at the next (odd) position.
	       (vector-ref options-vector (+ i 1)))
	      (#t (loop (+ 2 i))))))

    ;; TODO!
    #;
    (define (value->data text size)
      ... (raise (make-value-parse/data-error text))
      ... (raise (make-value-parse/data-size-error text))
      ...)

    ;; TODO why is expansion done only in file names
    ;; in C GNUnet?
    (define (value->file-name text)
      "Parse @var{text} as a file name (a string).
This actually is simply a no-op."
      (assert (string? text))
      text)))