path: root/tests/config-db.scm

;; 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

;; Bugs found with these tests:
;;  * [I] missing arguments to %make
;;  * [I] forgot to export &unwritable-key-error and friends
;;  * [I] forgot to export undefine-key!
;;  * [I] missing arguments for default-set-value!/raw
;;  * [I] undefine-key! on configurations backed by a hash table
;;        did not produce an exception

(use-modules (gnu gnunet config db)
	     (rnrs hashtables)
	     (srfi srfi-8)
	     ((rnrs base) #:select (assert))
	     (ice-9 control))

;; Convert the exception into a S-expression
;; to be able to compare results with @code{equal?}.
(define (call-with-return-exceptions fun . args)
  (with-exception-handler
      (lambda (e)
	(list
	 (cond ((undefined-key-error? e) 'not-found)
	       ((unwritable-key-error? e) 'unwritable)
	       ((unundefinable-key-error? e) 'unundefinable))
	 (config-error-section e)
	 (config-error-key e)))
    (lambda () (apply fun args))
    #:unwind? #t
    #:unwind-for-type &config-error))

(define (read-value/scatch config section key)
  (call-with-return-exceptions
   (lambda ()
     `(found . ,(read-value identity config section key)))))

(define (set-value!/s config section key value)
  (set-value! identity config section key value))
(define (set-value!/scatch config section key value)
  (call-with-return-exceptions
   (lambda () (set-value!/s config section key value))))
(define (undefine-key!/catch config section key)
  (call-with-return-exceptions
   (lambda () (undefine-key! config section key) 'ok)))

(define (alist->hash alist)
  (let ((h (make-hashtable hash-key key=?)))
    (for-each (lambda (key+value)
		(hashtable-set! h (car key+value) (cdr key+value)))
	      alist)
    h))

(test-equal "make-configuration return types"
  '(#t #t #t #t)
  (receive (c set-read-value/raw! set-set-value!/raw! set-undefine-key!!)
      (make-configuration)
    (list (configuration? c)
	  (procedure? set-read-value/raw!)
	  (procedure? set-set-value!/raw!)
	  (procedure? set-undefine-key!!))))

(define-syntax-rule (test-eqnh desc . rest)
  (test-equal (string-append "hash->configuration, " desc) . rest))

(define-syntax-rule (test-newhash-read desc expected alist section key)
  (test-equal (string-append "hash->configuration, read-value, " desc)
    expected
    (read-value/scatch
     (hash->configuration (alist->hash alist))
     section key)))

(test-newhash-read "match" '(found . "value") '((("section" . "x") . "value"))
		   "section" "x")
(test-newhash-read "section does not match"
		   '(not-found "sect" "x")
		   '((("section" . "x") . "value"))
		   "sect" "x")
(test-newhash-read "key does not match"
		   '(not-found "section" "y")
		   '((("section" . "x") . "value"))
		   "section" "y")

(define-syntax-rule (test-reflect desc alist
				  (h c . rest)
				  (section key expected)
				  (section* key* expected*)
				  mutate)
  (test-eqnh desc
	     '(expected expected*)
	     (let ((h (alist->hash alist)))
	       (receive (c . rest) (hash->configuration h)
		 (let ((old (read-value/scatch c section key)))
		   mutate
		   (list old (read-value/scatch c section* key*)))))))



;; In the docstring, it is specified the hash table is used
;; -- not a *copy* of the hash table.

(test-reflect "read-value reflects hash (modified value)"
	      '((("section" . "x") . "value"))
	      (h c . _)
	      ("section" "x" (found . "value"))
	      ("section" "x" (found . "value2"))
	      (hashtable-set! h '("section" . "x") "value2"))

(test-reflect "read-value reflects hash (deleted value)"
	      '((("section" . "x") . "value"))
	      (h c . _)
	      ("section" "x" (found . "value"))
	      ("section" "x" (not-found "section" "x"))
	      (hashtable-delete! h '("section" . "x")))

(test-reflect "read-value reflects hash (new value)"
	      '()
	      (h c . _)
	      ("section" "x" (not-found "section" "x"))
	      ("section" "x" (found . "value"))
	      (hashtable-set! h '("section" . "x") "value"))

;; The hash table is modified, not copied.
;; Also, new values are visible from read-value.
(test-reflect "set-value! & read-value, in-place (new)"
	      '()
	      (h c . _)
	      ("section" "x" (not-found "section" "x"))
	      ("section" "x" (found . "value"))
	      (begin
		(set-value!/s c "section" "x" "value")
		(assert (hashtable-contains? h `(,"section" . ,"x")))))



;; Make sure all callentries are adjusted to use the new hash.
(test-reflect "read-value reflects new hash (modified value)"
	      '((("section" . "x") . "value"))
	      (h c set-hash!)
	      ("section" "x" (found . "value"))
	      ("section" "x" (found . "value2"))
	      (set-hash! (alist->hash '((("section" . "x") . "value2")))))

(test-reflect "read-value reflects new hash (deleted value)"
	      '((("section" . "x") . "value"))
	      (h c set-hash!)
	      ("section" "x" (found . "value"))
	      ("section" "x" (not-found "section" "x"))
	      (set-hash! (alist->hash '())))

(test-reflect "read-value reflects new hash (new value)"
	      '()
	      (h c set-hash!)
	      ("section" "x" (not-found "section" "x"))
	      ("section" "x" (found . "value"))
	      (set-hash! (alist->hash '((("section" . "x") . "value")))))

;; Changing from a mutable to immutable hash (set-value!).
;;
;; set-hash! might have forgotten to change the set-value!
;; callentry correctly, in which case:
;;  (a) the callentry uses the new (immutable) hash,
;;      and tries to modify it.  In that case, (rnrs hashtables)
;;      would raise an exception, which will not be &unwritable-key-error.
;;      --> FAIL.
;;  (b) the callentry is unchanged, and uses the old hash.  In that case,
;;      no exception would be raised.
;;      --> FAIL

(test-eqnh "set-value! fails gracefully (mutable -> immutable hash)"
	   '(unwritable "the-section" "the-key")
	   (receive (c set-hash!)
	       (hash->configuration (alist->hash '()))
	     (set-hash! (hashtable-copy (alist->hash '()) #f))
	     (set-value!/scatch c "the-section" "the-key" "the-value")))

;; Changing from an immutable to mutable hash (set-value!).
;;
;; set-hash! might have forgotten to change the set-value!
;; callentry correctly, in which case:
;; (a) the callentry uses the new (mutable) hash, but believes it to be
;;     immutable, resulting in an &unwritable-key-error.
;;     --> FAIL.
;; (b) the callentry is unchanged, and uses the old hash, resulting in
;;     an &unwritable-key-error
;;     --> FAIL.
(test-eqnh "set-value! + read-value succeeds (immutable -> mutable hash)"
	   '(found . "the-value")
	   (receive (c set-hash!)
	       (hash->configuration (hashtable-copy (alist->hash '()) #f))
	     (set-hash! (alist->hash '()))
	     (set-value!/s c "the-section" "the-key" "the-value")
	     (read-value/scatch c "the-section" "the-key")))

;; Changing from a mutable to immutable hash (undefine-key!).
;;
;; set-hash! might have forgotten to change the undefine-key!
;; callentry, in which case:
;;  (a) the callentry uses the new (immutable) hash, but believes it to
;;      be mutable, resulting in an exception from (rnrs hashtables)
;;      instead of an &unundefinable-key-error.
;;      --> FAIL
;;  (b) the callentry uses the old (mutable) hash, in which case no
;;      &unundefinable-key-error is raised.
;;      --> FAIL
(test-eqnh "undefine-key! fails (mutable -> immutable, key exists)"
	   '(unundefinable "a-section" "a-key")
	   (receive (c set-hash!)
	       (hash->configuration
		(alist->hash '((("a-section" . "a-key") "a-value"))))
	     (set-hash!
	      (hashtable-copy (alist->hash '((("a-section" . "a-key") "a-value")))
			      #f))
	     (undefine-key!/catch c "a-section" "a-key")))

;; undefine-key! should fail because there is no such key to undefine.
(test-eqnh "undefine-key! fails (mutable -> immutable, key does not exists)"
	   '(unundefinable "a-section" "a-key")
	   (receive (c set-hash!)
	       (hash->configuration (alist->hash '()))
	     (set-hash! (hashtable-copy (alist->hash '()) #f))
	     (undefine-key!/catch c "a-section" "a-key")))

(test-eqnh "undefine-key! fails (mutable -> immutable, key disappears)"
	   '(unundefinable "a-section" "a-key")
	   (receive (c set-hash!)
	       (hash->configuration
		(alist->hash '((("a-section" . "a-key") "a-value"))))
	     (set-hash! (hashtable-copy (alist->hash '()) #f))
	     (undefine-key!/catch c "a-section" "a-key")))

(test-eqnh "undefine-key! fails (mutable -> immutable, key appears)"
	   '(unundefinable "a-section" "a-key")
	   (receive (c set-hash!)
	       (hash->configuration (alist->hash '()))
	     (set-hash!
	      (hashtable-copy (alist->hash '((("a-section" . "a-key") . "a-value")))
			      #f))
	     (undefine-key!/catch c "a-section" "a-key")))

;; Changing from a mutable to immutable hash (undefine-key!).
;;
;; set-hash! might have forgotten to change the undefine-key!
;; callentry, in which case:
;; (a) the undefine-key! callentry believes the hash table
;;     is still immutable, leading to an &unundefinable-key-error
;; (b) the undefine-key! callentry uses the new hash table,
;;     but believes it is immutable, leading to an &unundefinable-key-error

(test-eqnh "undefine-key! succeeds correctly (immutable -> mutable, key exists)"
	   '(ok . #f)
	   (receive (c set-hash!)
	       (hash->configuration
		(hashtable-copy (alist->hash '((("b-section" . "b-key") . "b-value")))
				#f))
	     (let ((new (hashtable-copy
			 (alist->hash '((("b-section" . "b-key") . "b-value")))
			 #t)))
	       (set-hash! new)
	       (let ((u (undefine-key!/catch c "b-section" "b-key")))
		 (cons u (hashtable-contains? new '("b-section" . "b-key")))))))

(test-eqnh "undefine-key! succeeds correctly (immutable -> mutable, key appears)"
	   '(ok . #f)
	   (receive (c set-hash!)
	       (hash->configuration
		(hashtable-copy (alist->hash '()) #f))
	     (let ((new (alist->hash '((("b-section" . "b-key") . "b-value")))))
	       (set-hash! new)
	       (let ((u (undefine-key!/catch c "b-section" "b-key")))
		 (cons u (hashtable-contains? new '("b-section" . "b-key")))))))

(test-eqnh "undefine-key! fails correctly (immutable -> mutable, key does not exist)"
	   '((unundefinable "b-section" "b-key") . #f)
	   (receive (c set-hash!)
	       (hash->configuration
		(hashtable-copy (alist->hash '()) #f))
	     (let ((new (alist->hash '())))
	       (set-hash! new)
	       (let ((u (undefine-key!/catch c "b-section" "b-key")))
		 (cons u (hashtable-contains? new '("b-section" . "b-key")))))))

(test-eqnh "undefine-key! fails correctly (immutable -> mutable, key disappears)"
	  '((unundefinable "c-section" "c-key") . #f)
	  (receive (c set-hash!)
	      (hash->configuration
	       (hashtable-copy (alist->hash '((("c-section" . "c-key") . "c-value")))
			       #f))
	    (let ((new (alist->hash '())))
	      (set-hash! new)
	      (let ((u (undefine-key!/catch c "c-section" "c-key")))
		(cons u (hashtable-contains? new '("c-section" . "c-key")))))))

(test-eqnh "undefine-key! is not simply hashtable-clear!"
	   '(found . "w")
	   (receive (c _)
	       (hash->configuration
		(alist->hash '((("x" . "y") . "z") (("u" . "v") . "w"))))
	     (undefine-key! c "x" "y")
	     (read-value/scatch c "u" "v")))


;; We've neglected the object->value an value->object arguments
;; in the previous tests.

(test-equal "read-value, string->number"
  #x12
  (read-value string->number (hash->configuration
			      (alist->hash '((("x" . "y") . "#x12")))) "x" "y"))

(define (calls-in-tail-position? proc)
  (= 1 (stack-length (make-stack (let ((t (make-prompt-tag 'tail-position?)))
				   (call-with-prompt t
				     (lambda () (proc
						 (lambda () (abort-to-prompt t))))
				     identity))))))

(test-assert "read-value, object->value in tail position"
  (calls-in-tail-position?
   (let ((c (hash->configuration (alist->hash '((("x" . "y") . "#x12"))))))
     (lambda (thunk)
       (read-value (lambda (x) (thunk)) c "x" "y")))))

(test-equal "set-value!, object->value has correct argument"
  'value
  (let/ec ec
    (set-value! ec
		(hash->configuration (alist->hash '()))
		"section" "key"
		'value)
    'what))

;; TODO: verify
;; Replacing the hash table is not an atomic operation;
;; while the hash table is being replaced, either the new or the old hash
;; table will be used by the callentries.

;; Check the defaults callentries.
(test-equal "read-value, default callentry"
  '(not-found "x" "y")
  (read-value/scatch (make-configuration) "x" "y"))
(test-equal "set-value!, default callentry"
  '(unwritable "x" "y")
  (set-value!/scatch (make-configuration) "x" "y" "z"))
(test-equal "undefine-key!, default callentry"
  '(unundefinable "x" "y")
  (undefine-key!/catch (make-configuration) "x" "y"))