scheme-gnunet/tests/cadet.scm

;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;; Copyright © 2022 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
(define-module (test-distributed-hash-table))
(import (gnu gnunet cadet client)
	(gnu gnunet cadet network)
	(gnu gnunet utils bv-slice)
	(gnu gnunet utils hat-let)
	(gnu gnunet netstruct syntactic)
	(gnu gnunet crypto struct)
	(gnu gnunet hashcode struct)
	(rnrs bytevectors)
	(ice-9 match)
	(srfi srfi-8)
	(srfi srfi-64)
	(tests utils)
	(quickcheck)
	(quickcheck property)
	(quickcheck generator)
	(quickcheck arbitrary))

(test-begin "CADET")
(test-assert "(CADET) close, not connected --> all fibers stop, no callbacks called"
  (close-not-connected-no-fallbacks "cadet" connect disconnect!))
(test-assert "(CADET) garbage collectable"
  (garbage-collectable "cadet" connect))

(define %peer-identity
  (bv-slice/read-write (u8-list->bytevector (iota (sizeof /peer-identity '())))))
(define %port
  (bv-slice/read-write
   (u8-list->bytevector (map (lambda (x) (- 255 x))
			     (iota (sizeof /hashcode:512 '()))))))
(test-assert "cadet-address?"
  (and (cadet-address? (make-cadet-address %peer-identity %port))
       (not (cadet-address? 'foobar))))

(test-equal "cadet-address, deconstruct"
  '(#true #true)
  (let ((cadet (make-cadet-address %peer-identity %port)))
    ;; TODO: extend 'bytevector=?' to accept ranges, then define
    ;; 'slice=?'.
    (list (equal? (cadet-address-peer cadet) (slice/read-only %peer-identity))
	  (equal? (cadet-address-port cadet) (slice/read-only %port)))))

(test-error "cadet-address, wrong peer identity size (1)" #f
	    (make-cadet-address (make-slice/read-write 0) %port))
(test-error "cadet-address, wrong peer identity size (2)" #f
	    (make-cadet-address
	     (make-slice/read-write (- (sizeof /peer-identity '()) 1)) %port))
(test-error "cadet-address, wrong peer identity size (3)" #f
	    (make-cadet-address
	     (make-slice/read-write (+ (sizeof /peer-identity '()) 1)) %port))

(test-error "cadet-address, wrong port size (1)" #f
	    (make-cadet-address %peer-identity (make-slice/read-write 0)))
(test-error "cadet-address, wrong port size (2)" #f
	    (make-cadet-address
	     %peer-identity
	     (make-slice/read-write (- (sizeof /hashcode:512 '()) 1))))
(test-error "cadet-address, wrong port size (3)" #f
	    (make-cadet-address
	     %peer-identity
	     (make-slice/read-write (+ (sizeof /hashcode:512 '()) 1))))

(test-assert "cadet-address, read-only port"
  (let ((slice (cadet-address-port (make-cadet-address %peer-identity %port))))
    (and (slice-readable? slice) (not (slice-writable? slice)))))
(test-assert "cadet-address, read-only peer"
  (let ((slice (cadet-address-peer (make-cadet-address %peer-identity %port))))
    (and (slice-readable? slice) (not (slice-writable? slice)))))

(test-assert "cadet-address, independent slices"
  (let ((struct (make-cadet-address %peer-identity %port)))
    (and (slice-independent? %peer-identity (cadet-address-peer struct))
	 (slice-independent? %port (cadet-address-port struct)))))

(test-equal "cadet-address, equal?"
  (make-cadet-address %peer-identity %port)
  (make-cadet-address (slice-copy/read-only %peer-identity)
		      (slice-copy/read-only %port)))

;; TODO: integrate in guile-quickcheck, (tests utils)
(define ($integer-in-range lower upper)
  (arbitrary
   (gen (choose-integer lower upper))
   (xform #false)))
(define ($sized-bytevector size)
  (arbitrary
   (gen (choose-bytevector size))
   (xform #false)))
(define ($arbitrary-lift f . a)
  (arbitrary
   (gen (apply generator-lift f (map arbitrary-gen a)))
   (xform #false))) ; TODO
(define ($sized-bytevector-slice/read-write size)
  ($arbitrary-lift bv-slice/read-write ($sized-bytevector size)))
(define ($sized-bytevector-slice/read-only size)
  ($arbitrary-lift slice/read-only ($sized-bytevector-slice/read-write size)))

(define $channel-number ($integer-in-range 0 (- (expt 2 32) 1)))
(define $peer ($sized-bytevector-slice/read-only (sizeof /peer-identity '())))
(define $port ($sized-bytevector-slice/read-only (sizeof /hashcode:512 '())))
(define $options ($integer-in-range 0 (- (expt 2 32) 1)))
(define $cadet-address ($arbitrary-lift make-cadet-address $peer $port))
(define $priority-preference ($integer-in-range 0 (- (expt 2 32) 1)))
;; Actual sizes can be a lot larger
(define $cadet-data ($sized-bytevector-slice/read-only 500))

(define (normalise list)
  (map (match-lambda
	 ((? slice? s) (slice-copy/read-only s))
	 (foo foo))
       list))

(define-syntax-rule
  (test-roundtrip testcase analyse construct (name $arbitrary) ...)
  (test-assert testcase
    (quickcheck
     (property ((name $arbitrary) ...)
	       (let^ ((! expected (pk 'e (list name ...)))
		      (! constructed (construct name ...))
		      (<-- analysed (analyse constructed))
		      (! analysed (normalise analysed)))
		     (and (slice-readable? constructed)
			  (slice-writable? constructed)
			  (equal? expected analysed)))))))

(test-roundtrip "analyse + construct round-trips (local-channel-create)"
		analyse-local-channel-create construct-local-channel-create
		(cadet-address $cadet-address)
		(channel-number $channel-number)
		(options $options))
(test-roundtrip "analyse + construct round-trips (local-channel-destroy)"
		analyse-local-channel-destroy construct-local-channel-destroy
		(channel-number $channel-number))
(test-roundtrip "analyse + construct round-trips (local-data)"
		analyse-local-data construct-local-data
		(channel-number $channel-number)
		(priority-preference $priority-preference)
		(data $cadet-data))
(test-roundtrip "analyse + construct round-tripes (local-acknowledgement)"
		analyse-local-acknowledgement construct-local-acknowledgement
		(channel-number $channel-number))

;; header information will be tested elsewhere (TODO)

(test-end "CADET")