[gnunet-scheme] 03/03: dht/client: Improve and test <datum> records.

[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 b7a8906e90836e4c9b9c830c2cdedef4ca83ff55
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Jan 16 17:26:39 2022 +0000

    dht/client: Improve and test <datum> records.
    
    * gnu/gnunet/utils/bv-slice.scm
      (make-verify-slice-cap,verify-slice-readable,verify-slice-writable):
      New procedures.
      (slice-zero!,slice-copy!): Use them.
    * gnu/gnunet/dht/client.scm (validate-key): Use
      'verify-slice-readable' for nicer exceptions.
      (%max-message-size,%max-datum-value-length): New variables.
      (&overly-large-datum): New condition.
      (make-datum): Throw new condition when appropriate.
      (canonical-block-type): Detect non-exact integers.
    * tests/distributed-hash-table.scm
      
(test-missing-caps,test-overly-large-datum,datum-key-test,datum-value-test):
      New macros for tests.
      (make-a-datum,test-datum-overly-large): New procedures for tests.
      ("datum?", "not a datum", "datum-key", "datum-key, read-only is
      sufficient", "datum key must be readable", "datum-value, length 0",
      "datum-value, maximal length", "datum-value", "datum-value, too
      large (1, numeric type)", "datum-value, too large (2, numeric
      type)", "datum-value, too large (1, symbolic type)", "datum-key,
      symbolic type (1)", "datum-key, symbolic type (2)", "datum-key,
      known numeric type (1)", "datum-key, known numeric type (2)",
      "datum-key, unknown numeric type", "datum-type, out-of-bounds",
      "datum-type, wrong enumeration", "datum-type, wrong type (1)",
      "datum-type, wrong type (2)"): New tests.
---
 doc/scheme-gnunet.tm             |   6 +-
 gnu/gnunet/dht/client.scm        |  56 ++++++++++++++----
 gnu/gnunet/utils/bv-slice.scm    |  15 ++++-
 tests/distributed-hash-table.scm | 125 ++++++++++++++++++++++++++++++++++++++-
 4 files changed, 187 insertions(+), 15 deletions(-)

diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index bd7573f..6c3619b 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -7,7 +7,7 @@
   manual>|<doc-author|<author-data|<author-name|Maxime
   Devos>|<author-email|maximedevos@telenet.be>>>>
 
-  Copyright (C) 2021 GNUnet e.V.
+  Copyright (C) 2021, 2022 GNUnet e.V.
 
   Permission is granted to copy, distribute and/or modify this document under
   the terms of the GNU Free Documentation License, Version 1.3 or any later
@@ -1089,6 +1089,10 @@
     <scm|datum-expiration> return the key, value and expiration time
     respectively. It can be tested if an object is a datum object with the
     predicate <scm|datum?>.
+
+    The length of <var|value> may be at most <scm|%max-datum-value-length>.
+    If this bound is exceeded, an appropriate <scm|&overly-large-datum> and
+    <scm|&who> condition is raised.
   </explain>
 
   <\explain>
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 51ed937..dc81244 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -1,5 +1,5 @@
 ;; This file is part of GNUnet
-;; Copyright (C) 2004-2013, 2016, 2021 GNUnet e.V.
+;; Copyright (C) 2004-2013, 2016, 2021, 2022 GNUnet e.V.
 ;;
 ;; GNUnet is free software: you can redistribute it and/or modify it
 ;; under the terms of the GNU Affero General Public License as published
@@ -28,6 +28,10 @@
          bound-replication-level
 
          ;; Non-interactive data structures
+         %max-datum-value-length
+         &overly-large-datum make-overly-large-datum overly-large-datum?
+         overly-large-datum-type overly-large-datum-length
+
          make-datum datum? datum-type datum-key datum-value datum-expiration
          datum->insertion insertion? insertion->datum
          insertion-desired-replication-level
@@ -80,16 +84,20 @@
                read% sizeof set%! select)
          (only (gnu gnunet utils bv-slice)
                slice-length slice/read-only make-slice/read-write slice-copy!
-               slice-slice)
+               slice-slice verify-slice-readable)
          (only (rnrs base)
                and >= = quote * + - define begin ... let*
                quote case else values apply let cond if >
-               <= expt assert integer? lambda for-each
+               <= expt assert exact? integer? lambda for-each
                not expt min max)
          (only (rnrs control)
                unless when)
          (only (rnrs records syntactic)
-               define-record-type))
+               define-record-type)
+         (only (rnrs conditions)
+               &error condition make-who-condition define-condition-type)
+         (only (rnrs exceptions)
+               raise))
   (begin
     ;; The minimal and maximal replication levels the DHT service allows.
     ;; While the service won't reject replication levels outside this range,
@@ -120,7 +128,10 @@ valid replication to the level, to the range the DHT 
service likes."
 
     (define (validate-key key)
       "If @var{key} is, in-fact, a readable /hashcode:512, return it as a
-readable bytevector slice. If not, raise an appropriate exception. "
+readable bytevector slice. If not, raise an appropriate exception.  The 'what'
+in the @code{&missing-capabilities} condition, if any, is the symbol
+@code{key}."
+      (verify-slice-readable 'key key)
       (if (= (slice-length key) (sizeof /hashcode:512 '()))
          (slice/read-only key)
          (error "length of key incorrect")))
@@ -130,6 +141,22 @@ readable bytevector slice. If not, raise an appropriate 
exception. "
 appropriate exception."
       (if (datum? datum) datum (error "not a datum")))
 
+    ;; TODO: more-or-less copied from gnunet_util_lib.h
+    (define %max-message-size 65535)
+
+    (define %max-datum-value-length
+      (- %max-message-size (sizeof /:msg:dht:client:put '())))
+    (assert (<= 0 %max-datum-value-length))
+
+    ;; TODO: maybe check types in 'make-overly-large-datum'.
+    ;; TODO: &error / &serious / &condition?
+    (define-condition-type &overly-large-datum &error
+      make-overly-large-datum
+      overly-large-datum?
+      ;; block type, as an (exact) integer
+      (type   overly-large-datum-type)
+      ;; length of the (overly large) value
+      (length overly-large-datum-length))
     ;; TODO: use the data structures below and test them
 
     ;; An key-value entry in the DHT.
@@ -148,11 +175,20 @@ The keyword argument @var{expiration} is optional, see 
???.
 
 The numeric value of the block type can be retrieved with the accessor
 @code{datum-type}. The accessors @code{datum-key}, @code{datum-value} and
-@code{datum-expiration} return the keyn value and expiration time respectively.
-It can be tested if an object is a datum object with the predicate 
@code{datum?}."
-          (%make (canonical-block-type type)
+@code{datum-expiration} return the key, value and expiration time respectively.
+It can be tested if an object is a datum object with the predicate 
@code{datum?}.
+
+The length of @var{value} may be at most @code{%max-datum-value-length}.
+If this bound is exceeded, an appropriate @code{&overly-large-datum} and
+@code{&who} condition is raised."
+          (define t (canonical-block-type type))
+          (unless (<= (slice-length value) %max-datum-value-length)
+            (raise (condition
+                    (make-who-condition 'make-datum)
+                    (make-overly-large-datum t (slice-length value)))))
+          (%make t
                  (validate-key key)
-                 (slice/read-only value) ; TODO: max size
+                 (slice/read-only value)
                  expiration))))) ; TODO validate expiration
 
     ;; XXX deduplicate
@@ -318,7 +354,7 @@ slices in @var{old} do not impact the new search result."
     (define (canonical-block-type type)
       "Return the numeric value of the block type @var{type}
 (a @code{block-type?} or in-bounds integer)."
-      (cond ((integer? type)
+      (cond ((and (integer? type) (exact? type))
             (unless (and (<= 0 type (- (expt 2 32) 1)))
               (error "block type out of bounds"))
             type)
diff --git a/gnu/gnunet/utils/bv-slice.scm b/gnu/gnunet/utils/bv-slice.scm
index ab6071c..99c0a93 100644
--- a/gnu/gnunet/utils/bv-slice.scm
+++ b/gnu/gnunet/utils/bv-slice.scm
@@ -35,6 +35,8 @@
          slice/read-only
          slice/write-only
          slice/read-write
+         verify-slice-readable
+         verify-slice-writable
          ;; Small operations
          slice-u8-ref
          slice-u16-ref
@@ -225,9 +227,16 @@ If not, raise an appropriate @code{&missing-capabilities}."
       (let ((permitted-cap-bits (slice-capability-bits slice)))
        (raise (make-missing-capabilities what permitted-cap-bits
                                          required-cap-bits)))))
+  (define (make-verify-slice-cap required-cap-bits)
+    (lambda (what slice)
+      "Verify that @var{slice} has the capabilities @var{required-cap-bits}.
+If not, raise an appropriate @code{&missing-capabilities}."
+      (verify-slice-cap what slice required-cap-bits)))
 
   (define slice-readable? (make-slice-cap-p CAP_READ))
   (define slice-writable? (make-slice-cap-p CAP_WRITE))
+  (define verify-slice-readable (make-verify-slice-cap CAP_READ))
+  (define verify-slice-writable (make-verify-slice-cap CAP_WRITE))
 
   (define (make-select-capabilities desired-cap-bits)
     (slice-as-well
@@ -304,7 +313,7 @@ If not, raise an appropriate @code{&missing-capabilities}."
 
   (define (slice-zero! slice)
     "Zero out the writable slice @var{slice}."
-    (verify-slice-cap 'slice slice CAP_WRITE)
+    (verify-slice-writable 'slice slice)
     ;; TODO optimise this and/or optimise guile's compiler
     ;; w.r.t. bytevectors, structs and type inference.
     (let loop ((i 0))
@@ -316,8 +325,8 @@ If not, raise an appropriate @code{&missing-capabilities}."
   (define (slice-copy! from to)
     "Copy the contents of the readable slice @var{from} to
 the writable slice @var{slice}.  The slices may overlap."
-    (verify-slice-cap 'from from CAP_READ)
-    (verify-slice-cap 'to to CAP_WRITE)
+    (verify-slice-readable 'from from)
+    (verify-slice-writable 'to to)
     (assert (= (slice-length from) (slice-length to)))
     (bytevector-copy! (slice-bv from) (slice-offset from)
                      (slice-bv to) (slice-offset to)
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 1cb134b..c80abc4 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -1,5 +1,5 @@
 ;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;; Copyright (C) 2021 GNUnet e.V.
+;; Copyright (C) 2021, 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
@@ -17,10 +17,38 @@
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 (define-module (test-distributed-hash-table))
 (import (gnu gnunet dht client)
+       (gnu gnunet utils bv-slice)
+       (gnu gnunet netstruct syntactic)
+       (gnu gnunet hashcode struct)
+       (gnu gnunet block)
+       (gnu gnunet message protocols)
+       (gnu extractor enum)
+       (rnrs exceptions)
+       (rnrs conditions)
        (rnrs base)
        (srfi srfi-26)
        (srfi srfi-64))
 
+;; Copied from tests/bv-slice.scm.
+(define-syntax-rule (test-missing-caps test-case what permitted required code)
+  (test-equal test-case
+    (list what permitted required)
+    (guard (c ((missing-capabilities? c)
+              (list (missing-capabilities-what c)
+                    (missing-capabilities-permitted c)
+                    (missing-capabilities-required c))))
+      code)))
+
+(define-syntax-rule (test-overly-large-datum test-case who canonical-type
+                                            length)
+  (test-equal test-case
+    (list who canonical-type length)
+    (guard (c ((overly-large-datum? c)
+              (list (overly-large-datum-who c)
+                    (missing-capabilities-permitted c)
+                    (missing-capabilities-required c))))
+      code)))
+
 ;; It's easy to accidentally swap the min and the max,
 ;; or use theoretical bounds instead of effective bounds.
 (test-begin "bound-replication-level")
@@ -73,4 +101,99 @@
 (test-error "way too small" (bound-replication-level (- 
%minimum-replication-level #e1e20)))
 (test-error "non-numeric" (bound-replication-level 'what))
 
+(define* (make-a-datum #:key
+                      (type 0)
+                      (key (make-slice/read-write (sizeof /hashcode:512 '())))
+                      (value (make-slice/read-write 0)))
+  (make-datum type key value))
+(test-assert "datum?"
+  (datum? (make-a-datum)))
+(test-equal "not a datum"
+  '(#false #false #false)
+  (map datum? (list #false 'symbol (make-slice/read-write 0))))
+
+;; For efficiency reasons, make sure the storage is reused.
+(define-syntax-rule (datum-key-test test-case k)
+  (test-assert test-case
+    (let* ((key k) ; only evaluate once, because eq? will be required
+          (datum (make-a-datum #:key key))
+          (new-key (datum-key datum)))
+      (and (datum? datum)
+          (slice-readable? new-key)
+          (not (slice-writable? new-key))
+          (eq? (slice-bv key) (slice-bv new-key))
+          (= (slice-length key) (slice-length new-key))))))
+(define-syntax-rule (datum-value-test test-case v)
+  (test-assert test-case
+    (let* ((value v) ; only evaluate once, because eq? will be required
+          (datum (make-a-datum #:value value))
+          (new-value (datum-value datum)))
+      (and (datum? datum)
+          (slice-readable? new-value)
+          (not (slice-writable? new-value))
+          (eq? (slice-bv value) (slice-bv new-value))
+          (= (slice-length value) (slice-length new-value))))))
+
+(define-syntax-rule (datum-type-test test-case type type/integer)
+  (test-equal test-case
+    type/integer
+    (datum-type (make-a-datum #:type type))))
+
+(datum-key-test "datum-key"
+               (make-slice/read-write (sizeof /hashcode:512 '())))
+(datum-key-test "datum-key, read-only is sufficient"
+               (slice/read-only
+                (make-slice/read-write
+                 (sizeof /hashcode:512 '()))))
+
+(test-missing-caps
+ "datum key must be readable"
+ 'key
+ CAP_WRITE
+ CAP_READ
+ (make-a-datum #:key (slice/write-only (make-slice/read-write
+                                       (sizeof /hashcode:512 '())))))
+
+;; AFAIK a zero length value is allowed, albeit somewhat pointless?
+(datum-value-test "datum-value, length 0" (make-slice/read-write 0))
+(datum-value-test "datum-value, maximal length"
+                 (make-slice/read-write %max-datum-value-length))
+(datum-value-test "datum-value" (make-slice/read-write 900))
+
+(define (test-datum-overly-large test-case type type/integer length)
+  (test-equal test-case
+    (list 'make-datum type/integer length)
+    (guard (c ((overly-large-datum? c)
+              (list (condition-who c)
+                    (overly-large-datum-type c)
+                    (overly-large-datum-length  c))))
+      (make-a-datum #:type type #:value (make-slice/read-write length)))))
+
+(test-datum-overly-large
+ "datum-value, too large (1, numeric type)" 19 19
+ (* 2 %max-datum-value-length))
+
+(test-datum-overly-large
+ "datum-value, too large (2, numeric type)" 19 19
+ (* 2 %max-datum-value-length))
+
+(test-datum-overly-large
+ "datum-value, too large (1, symbolic type)" (symbol-value block-type 
block:revocation) 12
+ (* 2 %max-datum-value-length))
+
+(datum-type-test "datum-key, symbolic type (1)"
+                (symbol-value block-type block:consensus-element) 25)
+(datum-type-test "datum-key, symbolic type (2)"
+                (symbol-value block-type block:dht:hello) 7)
+(datum-type-test "datum-key, known numeric type (1)" 7 7)
+(datum-type-test "datum-key, known numeric type (2)" 8 8)
+(datum-type-test "datum-key, unknown numeric type" 4294967295 4294967295)
+
+(test-error "datum-type, out-of-bounds" (make-a-datum #:type 4294967296))
+(test-error "datum-type, wrong enumeration"
+           (make-a-datum #:type (symbol-value message-type msg:util:dummy)))
+(test-error "datum-type, wrong type (1)" (make-a-datum #:type 'foo))
+;; This detected a bug!
+(test-error "datum-type, wrong type (2)" (make-a-datum #:type 1.0))
+
 (test-end)

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