[gnunet-scheme] branch master updated (88c05a7 -> b8e0342)

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a change to branch master
in repository gnunet-scheme.

    from 88c05a7  dht/struct: Define /dht:path-element.
     new 82f122e  utils/hat-let: New ^! construct.
     new b8e0342  dht/client: In 'datum->search-result', verify the path 
lengths.

The 2 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails.  The revisions
listed as "add" were already present in the repository and have only
been added to this reference.


Summary of changes:
 gnu/gnunet/dht/client.scm        | 99 +++++++++++++++++++++++++++++++++++-----
 gnu/gnunet/utils/hat-let.scm     | 13 +++++-
 tests/distributed-hash-table.scm | 64 ++++++++++++++++++++------
 3 files changed, 149 insertions(+), 27 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 5925c86..1f922b2 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -32,6 +32,13 @@
          &overly-large-datum make-overly-large-datum overly-large-datum?
          overly-large-datum-type overly-large-datum-length
 
+         %overly-large-paths make-overly-large-paths overly-large-paths?
+         overly-large-paths-datum-length
+         overly-large-paths-get-path-length overly-large-paths-put-path-length
+
+         &malformed-path make-malformed-path malformed-path?
+         malformed-path-what malformed-path-size
+
          make-datum datum? datum-type datum-key datum-value datum-expiration
          datum->insertion insertion? insertion->datum
          insertion-desired-replication-level
@@ -85,11 +92,12 @@
          (only (gnu gnunet utils bv-slice)
                slice-length slice/read-only make-slice/read-write slice-copy!
                slice-slice verify-slice-readable)
+         (gnu gnunet utils hat-let)
          (only (rnrs base)
                and >= = quote * + - define begin ... let*
                quote case else values apply let cond if >
                <= expt assert exact? integer? lambda for-each
-               not expt min max)
+               not expt min max div-and-mod positive?)
          (only (rnrs control)
                unless when)
          (only (rnrs records syntactic)
@@ -157,6 +165,33 @@ appropriate exception."
       (type   overly-large-datum-type)
       ;; length of the (overly large) value
       (length overly-large-datum-length))
+
+    ;; A condition indicating that the combination of get path, put path
+    ;; and datum is too long -- it is the combination that is too long,
+    ;; not necessarily any part in particular.
+    ;;
+    ;; TODO: see &overly-large-datum
+    (define-condition-type &overly-large-paths &error
+      make-overly-large-paths
+      overly-large-paths?
+      ;; length of datum value (does not include the key or type)
+      (datum-length overly-large-paths-datum-length)
+      ;; The length (not the size!) of the get path, i.e. the number
+      ;; of path elements.  Zero if there is no get path.
+      (get-path-length overly-large-paths-get-path-length)
+      ;; Likewise, for the put path.
+      (put-path-length overly-large-paths-put-path-length))
+
+    ;; The would-be get-path or put-path does not have the correct size
+    ;; to be a path.
+    (define-condition-type &malformed-path &error
+      make-malformed-path
+      malformed-path?
+      ;; the symbol 'get-path' or 'put-path'
+      (what malformed-path-what)
+      ;; size of the would-be path (in octets)
+      (size malformed-path-size))
+
     ;; TODO: use the data structures below and test them
 
     ;; An key-value entry in the DHT.
@@ -255,16 +290,57 @@ be recovered with the accessor 
@code{search-result->datum}. It can be tested if
 an object is a search result with the predicate @code{search-result?}. The
 optional keyword arguments @code{get-path} and @code{put-path} are currently
 undocumented and untested."
-          ;; TODO: get-path and put-path
-          (%make (validate-datum datum)
-                 (and get-path
-                      (begin
-                        (verify-slice-readable 'get-path get-path)
-                        (slice/read-only get-path)))
-                 (and put-path
-                      (begin
-                        (verify-slice-readable 'put-path put-path)
-                        (slice/read-only put-path))))))))
+          ;; TODO: can a get-path exist without a put-path?
+          (let^ ((! (make-who)
+                    (make-who-condition 'datum->search-result))
+                 (! datum (validate-datum datum))
+                 (!^ (verify-path what path)
+                     "Test if @var{path} looks like a get path, put path or
+falsehood. If it is false, return @code{#false}, @code{0} and @code{0}.
+Otherwise, if it appears to be a valid path, return @var{path} as a readable
+bytevector slice, the size of the path and the length of the path.  If
+@var{path} is invalid, raise an appropriate exception."
+                    ((? (not path)
+                        (values #false 0 0))
+                     ;; Verify the slice is readable, and make sure the
+                     ;; 'what' field of the &missing-capabilities is
+                     ;; precise -- we can rely on slice/read-only to
+                     ;; perform capability checking, but then the 'what'
+                     ;; field wouldn't be correct.
+                     (_ (verify-slice-readable what path))
+                     ;; Verify the path actually consists of an integral number
+                     ;; of /dht:path-element structures.
+                     (! size (slice-length path))
+                     (<-- (length remainder)
+                          (div-and-mod size (sizeof /dht:path-element '())))
+                     (? (positive? remainder)
+                        (raise (condition
+                                (make-who)
+                                (make-malformed-path what size)))))
+                    ;; We could place an upper bound on the length of
+                    ;; @var{path} here, but that's a bit useless because
+                    ;; we will verify the total length (get-path + put-path)
+                    ;; later anyway.
+                    (values (slice/read-only path) size length))
+                 ;; Verify both the get-path and the put-path (if any),
+                 ;; remove writability and only keep readability.
+                 (<-- (get-path get-path-size get-path-length)
+                      (verify-path 'get-path get-path))
+                 (<-- (put-path put-path-size put-path-length)
+                      (verify-path 'put-path put-path))
+                 ;; Make sure the get-path, put-path, datum and
+                 ;; /:msg:dht:client:result header will fit in a GNUnet
+                 ;; message.  TODO: maybe also consider other messages?
+                 (! hypothetical-message-size
+                    (+ (sizeof /:msg:dht:client:result '())
+                       get-path-size put-path-size))
+                 (? (> hypothetical-message-size %max-message-size)
+                    (raise (condition
+                            (make-who)
+                            (make-overly-large-paths
+                             (slice-length (datum-value datum))
+                             get-path-length put-path-length)))))
+                (%make datum get-path put-path))))))
 
     (define (copy-search-result old)
       "Make a copy of the search result @var{old}, such that modifications to 
the
@@ -441,6 +517,7 @@ message header is assumed to be correct."
                  (extra-size (- (slice-length slice) (sizeof type '())))
                  (field (read% type '(field) header))
                  ...)
+            ;; TODO: C GNUnet uses /dht:path-element now ...
             (compare extra-size (* (+ field ...) (sizeof /peer-identity 
'()))))))
 
     ;; TODO reduce duplication with (gnu gnunet nse client) --- maybe introduce
diff --git a/gnu/gnunet/utils/hat-let.scm b/gnu/gnunet/utils/hat-let.scm
index 825c606..df280a0 100644
--- a/gnu/gnunet/utils/hat-let.scm
+++ b/gnu/gnunet/utils/hat-let.scm
@@ -1,5 +1,5 @@
 ;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;;   Copyright (C) 2020, 2021 GNUnet e.V.
+;;   Copyright (C) 2020--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
@@ -33,8 +33,9 @@
 ;;   * (2 2): Make (! (procedure-name argument) code code* ...)
 ;;            usable.
 ;;   * (2 3): Allow dotted variable lists with <--.
+;;   * (2 4): New: !^
 
-(library (gnu gnunet utils hat-let (2 2))
+(library (gnu gnunet utils hat-let (2 4))
   (export let^)
   ;; Avoid letting users of (gnu gnunet utils hat-let)
   ;; having to import _ from (rnrs base).
@@ -58,6 +59,14 @@
        (let ((x (lambda args body ...)))
         (let^ (etc ...)
               code ...)))
+      ;; Define a procedure, and let the body of the procedure be
+      ;; a let^ form.  @var{docstring} is assumed to be a literal string.
+      ((: ((!^ (x . args) docstring bindings body ...) etc ...) code ...)
+       (let^ ((! (x . args)
+                docstring
+                (let^ bindings body ...))
+             etc ...)
+            code ...))
       ;; Bind y to x
       ((: ((! x y) etc ...) code ...)
        (let ((x y))
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index c588c82..79e1831 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -16,7 +16,12 @@
 ;;
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 (define-module (test-distributed-hash-table))
-(import (gnu gnunet dht client)
+(import (quickcheck)
+       (quickcheck arbitrary)
+       (quickcheck generator)
+       (quickcheck property)
+       (gnu gnunet dht client)
+       (gnu gnunet dht struct)
        (gnu gnunet utils bv-slice)
        (gnu gnunet netstruct syntactic)
        (gnu gnunet hashcode struct)
@@ -249,12 +254,15 @@
       (and (datum=? old new)
           (datum-independent? old new)))))
 
+(define (path-length->size l)
+  (* l (sizeof /dht:path-element '())))
+
 ;; Detected a bug: the datum was not copied
 (test-assert "copy-search-result: equal and independent"
   (let* ((old-key (make-slice/read-write (sizeof /hashcode:512 '())))
         (old-value (make-slice/read-write 70))
-        (old-get-path (make-slice/read-write 9)) ; TODO: correct length
-        (old-put-path (make-slice/read-write 10)))
+        (old-get-path (make-slice/read-write (path-length->size 5)))
+        (old-put-path (make-slice/read-write (path-length->size 9))))
     (slice-u32-set! old-key 9 #xcabba9e (endianness big))
     (slice-u32-set! old-value 5 #xcabba9e (endianness big))
     (slice-u32-set! old-get-path 0 #xcabba9e (endianness big))
@@ -278,16 +286,15 @@
                       search-result-put-path))
 
 ;; These detected a bug: the capabilities were not restricted!
-;; TODO: length
 ;; TODO: can there be a get path without a put path?
-(search-result-get-path-slice-test "search-result-get-path, slice"
-                                  (make-slice/read-write 7))
-(search-result-get-path-slice-test "search-result-get-path, empty"
-                                  (make-slice/read-write 0))
-(search-result-put-path-slice-test "search-result-put-path, slice"
-                                  (make-slice/read-write 7))
-(search-result-put-path-slice-test "search-result-put-path, empty"
-                                  (make-slice/read-write 0))
+(search-result-get-path-slice-test
+ "search-result-get-path, slice" (make-slice/read-write (path-length->size 7)))
+(search-result-get-path-slice-test
+ "search-result-get-path, empty" (make-slice/read-write 0))
+(search-result-put-path-slice-test
+ "search-result-put-path, slice" (make-slice/read-write (path-length->size 7)))
+(search-result-put-path-slice-test
+ "search-result-put-path, empty" (make-slice/read-write 0))
 (test-equal "search-result-get-path, none"
   (list #false) ; TODO: drop 'list' when SRFI-64 bug is fixed
   (list (search-result-get-path (datum->search-result (make-a-datum)))))
@@ -301,7 +308,8 @@
  CAP_WRITE
  CAP_READ
  (datum->search-result
-  (make-a-datum) #:get-path (slice/write-only (make-slice/read-write 7))))
+  (make-a-datum) #:get-path
+  (slice/write-only (make-slice/read-write (path-length->size 7)))))
 
 (test-missing-caps
  "search-result get-path must be readable"
@@ -309,6 +317,34 @@
  CAP_WRITE
  CAP_READ
  (datum->search-result
-  (make-a-datum) #:put-path (slice/write-only (make-slice/read-write 7))))
+  (make-a-datum) #:put-path
+  (slice/write-only (make-slice/read-write (path-length->size 7)))))
+
+(define (test-malformed-path test-case what keyword)
+  (test-assert test-case
+    (quickcheck
+     (property
+      ((elements $natural)
+       (remainder
+       (arbitrary
+        (gen (choose-integer 1 (- (sizeof /dht:path-element '()) 1)))
+        (xform #false))))
+      (let ((size (+ remainder (* (sizeof /dht:path-element '())))))
+       (equal? (guard (c ((malformed-path? c)
+                          (list (condition-who c)
+                                (malformed-path-what c)
+                                (malformed-path-size c))))
+                 (datum->search-result
+                  (make-a-datum) keyword
+                  (make-slice/read-write size)))
+               (list 'datum->search-result what size)))))))
+
+(test-malformed-path
+ "get-path size must be a multiple of the size of a path element"
+ 'get-path #:get-path)
+
+(test-malformed-path
+ "put-path size must be a multiple of the size of a path element"
+ 'put-path #:put-path)
 
 (test-end)

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