;; This file is part of scheme-GNUnet.
;; Copyright (C) 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

(use-modules (gnu gnunet config parser)
	     (quickcheck)
	     (quickcheck generator)
	     (quickcheck arbitrary)
	     (quickcheck property)
	     ((rnrs conditions) #:select (&assertion))
	     (ice-9 match)
	     (srfi srfi-8)
	     (srfi srfi-26))

;; Test the line parser on some valid inputs.
(define-syntax-rule (cond/pos (x y) (pred? accessor ...) ...)
  (cond ((and (pred? x) (pred? y))
	 (and (= (accessor x) (accessor y)) ...))
	...
	((and (or (pred? x) ...)
	      (or (pred? y) ...)) #f)
	(#t (error "what madness is this?"))))

(define (lipo=? x y)
  "Are two line position objects equal?"
  (cond/pos (x y)
	    (#{%-position?}# position:%)
	    (#{#-position?}# position:#)
	    (=-position?
	     position:variable-start
	     position:variable-end
	     position:=
	     position:value-start
	     position:value-end)
	    (#{[]-position?}#
	     position:section-name-start
	     position:section-name-end)
	    (@inline@-position?
	     position:@inline@-start
	     position:@inline@-end)
	    ((cut eq? <> #f))
	    ((cut eq? <> #t))))

(define-syntax-rule (test-lipo name text expected)
  (test-assert name
    (lipo=? (parse-line text) expected)))

(test-lipo "trivial empty line" "" #t)
(test-lipo "empty line: lf" "\n" #t)
(test-lipo "empty line: cr" "\r" #t)
(test-lipo "empty line: space" " " #t)
(test-lipo "empty line: space + lf" " \n" #t)
(test-lipo "empty line: tab" "\t" #t)

(test-lipo "section name" "[hello]"
	   (#{make-[]-position}# 1 6))
(test-lipo "section name with spaces" "[  hello ]"
	   (#{make-[]-position}# 1 9))
;; Used for some services.
(test-lipo "section name with dots" "[hell.o.gnu]"
	   (#{make-[]-position}# 1 11))
;; Allowed in upstream.
(test-lipo "section name with leading space" "\t[hello]"
	   (#{make-[]-position}# 2 7))
(test-lipo "section name with more leading space" "\t [hello]"
	   (#{make-[]-position}# 3 8))
(test-lipo "section name with trailing space" "[hello]\t"
	   (#{make-[]-position}# 1 6))
(test-lipo "section name with more trailing space" "[hello]\t\t"
	   (#{make-[]-position}# 1 6))

(test-lipo "section name with missing ]" "[hell" #f)
(test-lipo "section name with missing [" "hell]" #f)

(test-lipo "empty % comment" "%" (#{make-%-position}# 0))
(test-lipo "empty # comment" "#" (#{make-#-position}# 0))
(test-lipo "% comment with text" "%text" (#{make-%-position}# 0))
(test-lipo "# comment with text" "#text" (#{make-#-position}# 0))
(test-lipo "% comment with leading whitespace" " %text"
	   (#{make-%-position}# 1))
(test-lipo "# comment with leading whitespace" " #text"
	   (#{make-#-position}# 1))
(test-lipo "% comment with more leading whitespace" " \t%text"
	   (#{make-%-position}# 2))
(test-lipo "# comment with more leading whitespace" " \t#text"
	   (#{make-#-position}# 2))
(test-lipo "# comment with %" "#%stuff" (#{make-#-position}# 0))
(test-lipo "% comment with #" "%#stuff" (#{make-%-position}# 0))

(test-lipo "= not allowed with empty variable name" "=value" #f)
(test-lipo "even with spaces" "   =value" #f)
(test-lipo "= with variable and value" "var=value"
	   (make-=-position 0 3 3 4 9))
(test-lipo "= with spacy variable and spacy value" "\t\tvar =\tvalue   "
	   (make-=-position 2 5 6 8 13))
;; parse-line does not impose what the end-of-line characters are.
(test-lipo "= with spacier variable and spacy value" "\t\tvar \n=\tvalue   "
	   (make-=-position 2 5 7 9 14))
(test-lipo "= with spaces in value" "var=val ue"
	   (make-=-position 0 3 3 4 10))
(test-lipo "line parser does not perform unquoting" "var = 'val ue'"
	   (make-=-position 0 3 4 6 14))
(test-lipo "quotes still make nice delimiters" "var = ' value '"
	   (make-=-position 0 3 4 6 15))
;; "VAR = VALUE # comment" seems acceptable to me actually,
;; but upstream interprets it as "VAR" = "VALUE # comment"
;; IIUC.
(test-lipo "= cannot be followed by a % comment" "var = value %comment "
	   (make-=-position 0 3 4 6 20))
(test-lipo "= cannot be followed by a # comment" "var = value #comment "
	   (make-=-position 0 3 4 6 20))

;; Bug discovered with the QuickCheck tests below!
(test-lipo "= with empty value" "x="
	   (make-=-position 0 1 1 2 2))
(test-lipo "= with spacy empty value" "x= "
	   ;; (0 1 1 3 3) would also be correct.
	   (make-=-position 0 1 1 2 2))
(test-lipo "= with spacier empty value" "x=  "
	   ;; (0 1 1 3 3) and (0 1 1 4 4) would also be correct.
	   (make-=-position 0 1 1 2 2))

(define-syntax-rule (test-inline-po name line expected-fipo)
  (test-equal name expected-fipo
	      (let ((l (parse-line line)))
		(if (@inline@-position? l)
		    (cons (position:@inline@-filename-start l)
			  (position:@inline@-filename-end l))
		    'What?))))

(test-lipo "@INLINE@ with file name" "@INLINE@ /x/${stuff}.config"
	   (make-@inline@-position 0 27))
(test-inline-po "@INLINE@ file name positions" "@INLINE@ stuff" (cons 9 14))
(test-lipo "@INLINE@ with file name + space" "@INLINE@ X\t"
	   (make-@inline@-position 0 10))
(test-inline-po "@INLINE@ + space file name positions" "@INLINE@ stuff "
  (cons 9 14))
(test-lipo "@INLINE@ with file name + more space" "@INLINE@ X\t\t"
	   (make-@inline@-position 0 10))
(test-inline-po "@INLINE@ more space file name positions" "@INLINE@ X \t"
		(cons 9 10))
(test-lipo "space + @INLINE@ with file name" " @INLINE@ X"
	   (make-@inline@-position 1 11))
(test-inline-po "space + @INLINE@ file name positions" " @INLINE@ X"
		(cons 10 11))

;; TODO: are empty file names acceptable?
;; If so, change the tests (see #; commented out code).
(test-lipo "@INLINE@ without space" "@INLINE@" #false)
(test-lipo "@INLINE@ with empty file name" "@INLINE@ "
	   #f
	   #;(make-@inline@-position 0 9))
#;
(test-inline-po "@INLINE@ with empty file name (position)" "@INLINE@ "
		(cons 9 9))
(test-lipo "@INLINE@ with empty file name + space" "@INLINE@ \t"
	   #f
	   #;(make-@inline@-position 0 9))
#;
(test-inline-po "@INLINE@ with empty file name + space (position)" "@INLINE@  "
		(cons 9 9))



;; This fairly trivial procedure is copied from tests/kinds/octal.scm
;; (disarchive by Timothy Sample)
;; https://git.ngyro.com/disarchive/tree/tests/kinds/octal.scm?id=27a0fc79aacaaab0388e974b07cda885079f0f05).
(define (char-set->arbitrary cs)
  (arbitrary
   (gen (choose-char cs))
   (xform (lambda (chr gen)
            (generator-variant (char->integer chr) gen)))))

;; Test the line parser on random inputs
(define $interesting-char
  (char-set->arbitrary (string->char-set "[]=#% \tab")))
(define $interesting-random-string
  ($string $interesting-char))
(define $interesting-infix
  ($choose ((cute string=? "") ($const ""))
	   ((cute string=? "@INCLUDE@") ($const "@INCLUDE@"))))

(define-syntax-rule (false-if-assertion exp exp* ...)
  (with-exception-handler
      (lambda (e) #f)
    (lambda () exp exp* ...)
    #:unwind? #t
    #:unwind-for-type &assertion))

(define (in-bounds? line pos)
  "Verify the position information @var{pos} is at least
in-bounds for the string @var{line}."
  (cond ((%-position? pos)
	 (and (<= 0 (position:% pos))
	      (< (position:% pos) (string-length line))))
	((#{#-position?}# pos)
	 (and (<= 0 (#{position:#}# pos))
	      (< (#{position:#}# pos) (string-length line))))
	((=-position? pos)
	 (and (<= 0 (position:= pos))
	      (< (position:= pos) (string-length line))))
	((#{[]-position?}# pos)
	 (and (<= 0 (position:section-name-start pos)
		  (position:section-name-end pos))
	      (< (position:section-name-end pos)
		 (string-length line))))
	((@inline@-position? pos)
	 (and (<= 0 (position:@inline@-start pos)
		  (position:@inline@-end pos))
	      (< (position:@inline@-end pos)
		 (string-length line))))
	((eq? pos #f) #t)
	((eq? pos #t) #t)
	(#f (error "what madness is this?"))))

(configure-quickcheck
 ;; Increase this when testing.
 (stop? (lambda (success-count _)
	  (>= success-count #;16384 2048)))
 ;; Large inputs don't produce much additional value.
 (size (lambda (test-number)
	 (if (zero? test-number)
	     0
	     (1+ (inexact->exact (floor/ (log test-number) (log 8))))))))

(test-assert "line position parser does not crash"
  (quickcheck
   (property ((pre $interesting-random-string)
	      (in $interesting-infix)
	      (post $interesting-random-string))
     (false-if-assertion
      (begin (parse-line (string-append pre in post))
	     #t)))))

(test-assert "line position parser produces in-bounds results"
  (quickcheck
   (property ((pre $interesting-random-string)
	      (in $interesting-infix)
	      (post $interesting-random-string))
     (let ((line (string-append pre in post)))
       (false-if-assertion
	(in-bounds? line (parse-line line)))))))



;; Test the position-preserving variable substitution parser.
;; First verify some properties on random data.

(configure-quickcheck
 ;; Increase this when testing changes.
 (stop? (lambda (success-count _)
	  (>= success-count 2048 #;000 success-count)))
 ;; Large inputs don't produce much additional value.
 (size (lambda (test-number)
	 (if (zero? test-number)
	     0
	     (min 6 (1+ (inexact->exact (floor/ (log test-number) (log 4)))))))))

(define (expo:start expo)
  "Given a position object, return the starting position of
the region of text it covers."
  (cond ((#{${:-}-position?}# expo)
	 ;; - 2: remove the ${ in ${VAR:-DEFAULT}
	 (- (#{expo:${:-}-name-start}# expo) 2))
	((#{${}-position?}# expo)
	 ;; - 2: remove the ${ in ${VAR}
	 (- (#{expo:${}-name-start}# expo) 2))
	(($-position? expo)
	 ;; - 1: remove the $ in $VAR
	 (- (expo:$-name-start expo) 1))
	((literal-position? expo)
	 (expo:literal-start expo))))

(define (expo:end expo)
  "Given a position object, return the end position (exclusive) of
the region of text it covers."
  (cond ((#{${:-}-position?}# expo)
	 ;; + 1: add the } in ${VAR:-DEFAULT}
	 (+ 1 (#{expo:${:-}-value-end}# expo) 1))
	((#{${}-position?}# expo)
	 ;; + 1: add the } in ${VAR}
	 (+ (#{expo:${}-name-end}# expo) 1))
	(($-position? expo)
	 (expo:$-name-end expo))
	((literal-position? expo)
	 (expo:literal-end expo))))

(define (expo:contiguous? expos)
  "Is the list expansion position objects @var{expos} contiguous?
If so, return the last object in @var{expos}.  Otherwise, return
@code{#f}."
  (define (internally-contiguous? x)
    (cond ((#{${:-}-position?}# x)
	   (let ((parts (#{expo:${:-}-value-parts}# x)))
	     (if (null? parts)
		 x
		 (expo:contiguous? parts))))
	  ((#{${}-position?}# x) #t)
	  (($-position? x) #t)
	  ((literal-position? x) #t)
	  (#t (error "what is this madness?"))))
  (match expos
    (() #t)
    ((x) (internally-contiguous? x))
    ((x y . rest)
     (and (= (expo:end x) (expo:start y))
	  (internally-contiguous? x)
	  (expo:contiguous? (cdr expos))))))

(define $interesting-char/expo
  (char-set->arbitrary (string->char-set "${:-}ab")))
(define-syntax-rule ($choose-with-eq? x ...)
  ($choose ((cute eq? x) ($const x)) ...))
(define $nested ($choose-with-eq? #f '#{${}}# '#{${:-}}#))

(define-syntax-rule (true-if-parse-error exp exp* ...)
  (with-exception-handler
      (lambda (e) #t)
    (lambda () exp exp* ...)
    #:unwind? #t
    #:unwind-for-type &expansion-violation))

(define $text-and-range
  (arbitrary
   (gen
    (sized-generator
     (lambda (size)
       (generator-let* ((text-length (choose-integer 0 size))
			(text (choose-string
			       (arbitrary-gen $interesting-char/expo)
			       text-length))
			(start (choose-integer 0 text-length))
			(end (choose-integer start text-length)))
		       (generator-return (list text start end))))))
   (xform #f)))

;; Unfortunatly, these QuickCheck tests do not reach all lines
;; of the procedure in practice.  TODO: write a fuzzer for Guile.
;;
;; (Should be feasible using the tracing framework.)
(test-assert "expansion parser does not crash"
  (quickcheck
   (property ((text-and-range $text-and-range)
	      (nested? $nested))
     (match text-and-range
       ((text start end)
	(false-if-assertion
	 (true-if-parse-error
	  (parse-expandable* text start end nested?)
	  #t)))))))

(test-assert "expansion position objects are contiguous"
  (quickcheck
   (property ((text-and-range $text-and-range)
	      (nested? $nested))
     (match text-and-range
       ((text start end)
	(true-if-parse-error
	 (receive (expos end)
	     (parse-expandable* text start end nested?)
	   (expo:contiguous? expos))))))))

(define (maybe-parse text start end nested?)
  "Try to parse the range @var{start} to @var{end} of @var{text}.
Return a structure that can be compares with @code{equal?} and
is invariant under translations."
  (with-exception-handler
      (lambda (e)
	(cond ((empty-variable-violation? e)
	       `(empty-variable-violation
		 ,(- (expansion-violation-position e) start)
		 ,(empty-variable-kind e)))
	      ((missing-close-violation? e)
	       `(missing-close-violation
		 ,(- (expansion-violation-position e) start)
		 ,(missing-close-kind e)))
	      ;; See the TODO in parse-expandable*.
	      (#t
	       `(todo
		 ,(- (expansion-violation-position e) start)))))
    (lambda ()
      (receive (expandibles end)
	  (parse-expandable* text start end nested?)
	(cons (map (cute expansible->sexp <> start) expandibles)
	      (- end start))))
    #:unwind? #t
    #:unwind-for-type &expansion-violation))

(define (expansible->sexp pos start)
  (cond ((literal-position? pos)
	 `(literal ,(- (expo:literal-start pos) start)
		   ,(- (expo:literal-end pos) start)))
	(($-position? pos)
	 `($ ,(- (expo:$-name-start pos) start)
	     ,(- (expo:$-name-end pos) start)))
	((#{${}-position?}# pos)
	 `(#{${}}#
	   ,(- (#{expo:${}-name-start}# pos) start)
	   ,(- (#{expo:${}-name-end}# pos) start)))
	;; HACK: work-around buggy Emacs parenthesis
	;; matching detection.
	((#{${:-}-position?}# pos)
	 `(,(string->symbol "${:-}")
	   ,(- (#{expo:${:-}-name-start}# pos) start)
	   ,(- (#{expo:${:-}-name-end}# pos) start)
	   ,(- (#{expo:${:-}-value-start}# pos) start)
	   ,(- (#{expo:${:-}-value-end}# pos) start)
	   ,(map (cute expansible->sexp <> start)
		 (#{expo:${:-}-value-parts}# pos))))))

(test-assert "start and end are respected"
  (quickcheck
   (property ((text-and-range $text-and-range)
	      (nested? $nested))
     (match text-and-range
       ((text start end)
	(equal? (maybe-parse text start end nested?)
		(maybe-parse (substring text start end)
			     0 (- end start) nested?)))))))


;; Now plenty of failure cases.

;; Expand an expansion error @code{c} conforming to
;; @code{cond}.
(define-syntax-rule (test-expansion-error (name nested?) (c text) cond?)
  (test-assert name
    (with-exception-handler (lambda (c) cond?)
      (lambda () (parse-expandable* text 0 (string-length text) nested?))
      #:unwind? #t
      #:unwind-for-type &expansion-violation)))

;; Test unbraced variable expansion, unnested.

(test-expansion-error ("$ + delimiter" #f)
  (c "$/")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 1)))

(test-expansion-error ("$ + delimiter + more" #f)
  (c "$/more")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 1)))

(test-expansion-error ("more + $ + delimiter" #f)
  (c "more$/")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 5)))

(test-expansion-error ("$ + end of string" #f)
  (c "$")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 1)))

(test-expansion-error ("more + $ + end of string" #f)
  (c "more$")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 5)))

;; Test unbraced variable expansion, nested.
(test-expansion-error ("$ + }, nested" '#{${:-}}#)
  (c "$}")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 1)))
(test-expansion-error ("$ + } + delimiter, nested" '#{${:-}}#)
  ;; don't interpret this as the variable } expanded
  ;; folowed by a slash!
  (c "$}/")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '$)
       (= (expansion-violation-position c) 1)))

;; Test braced variables, unnested & some nesting
(test-expansion-error ("empty braced variable" #f)
  (c "${}")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '#{${}}#)
       (= (expansion-violation-position c) 2)))
(test-expansion-error ("empty braced variable with empty default" #f)
  (c "${:-}")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '#{${:-}}#)
       (= (expansion-violation-position c) 2)))
(test-expansion-error ("empty braced variable with nonempty default" #f)
  (c "${:-def}")
  (and (empty-variable-violation? c)
       (eq? (empty-variable-kind c) '#{${:-}}#)
       (= (expansion-violation-position c) 2)))
(test-expansion-error ("unclosed braced variable" #f)
  (c "${")
  (and (missing-close-violation? c)
       (eq? (missing-close-kind c) '#{${}}#)
       (= (expansion-violation-position c) 2)))
(test-expansion-error ("unclosed braced variable with text" #f)
  (c "${text")
  (and (missing-close-violation? c)
       (eq? (missing-close-kind c) '#{${}}#)
       (= (expansion-violation-position c) 6)))
(test-expansion-error ("unclosed braced variable with default" #f)
  (c "${text:-default")
  (and (missing-close-violation? c)
       (eq? (missing-close-kind c) '#{${:-}}#)
       (= (expansion-violation-position c) 15)))
(test-expansion-error ("unclosed braced variable and weird character after -" #f)
  (c "${text:@") ; <-- allowed in upstream
  (and (expansion-violation? c)
       (= (expansion-violation-position c) 7)))



;; Now some success cases.
(define-syntax-rule (test-expansion text expected ...)
  (test-equal text
    (map (cute expansible->sexp <> 0)
	 (list expected ...))
    (match (maybe-parse text 0 (string-length text) #f)
      ((x . y) x)
      (z (cons 'what-is-this-madness z)))))

(test-expansion "$TMP" (make-$-position 1 4))
(test-expansion "$TMP/gnunet_arm.sock"
		(make-$-position 1 4)
		(make-literal-position 4 20))
(test-expansion "${TMP}" (#{make-${}-position}# 2 5))
(test-expansion "${TMP}/gnunet_arm.sock"
		(#{make-${}-position}# 2 5)
		(make-literal-position 6 22))
(test-expansion "${TMP:-/tmp}"
		(#{make-${:-}-position}# 2 5 7 11
		 (list (make-literal-position 7 11))))
(test-expansion "${TMP:-/tmp}/gnunet_arm.sock"
		(#{make-${:-}-position}# 2 5 7 11
		 (list (make-literal-position 7 11)))
		(make-literal-position 12 28))
(test-expansion "some ${STUFF:-${TMP:-/tmp}/etc$etera}/other"
		(make-literal-position 0 5)
		(#{make-${:-}-position}# 7 12 14 36
		 (list (#{make-${:-}-position}# 16 19 21 25
			(list (make-literal-position 21 25)))
		       (make-literal-position 26 30)
		       (make-$-position 31 36)))
		(make-literal-position 37 43))

;; TODO: what should ${{} be parsed as?
;; As ${} } or as the braced variable expansion with name
;; {?

;;; Local Variables:
;;; eval: (put 'property 'scheme-indent-function 1)
;;; eval: (put 'test-expansion-error 'scheme-indent-function 1)
;;; End: