[gnunet-scheme] 02/02: dht/client: In 'datum->search-result', verify the path lengths.

[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 b8e0342c9b116b3c648b60bbfb63d32959b95303
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Jan 23 16:52:33 2022 +0000

    dht/client: In 'datum->search-result', verify the path lengths.
    
    * gnu/gnunet/dht/client.scm
      (&overly-large-paths,&malformed-path): New conditions.
      (datum->search-result): Verify the resulting /msgh:dht:client:result
      message would fit within a GNUnet message.  Verify the get path and
      put path are an integral number of path elements.
    * tests/distributed-hash-table.scm
      (path-length->size,test-malformed-path): New procedures.
      ("get-path size must be a multiple of the size of a path element")
      ("put-path size must be a multiple of the size of a path element"):
      New tests.
      ("copy-search-result: equal and independent")
      ("search-result-get-path, slice")
      ("search-result-get-path, empty")
      ("search-result-put-path, slice")
      ("search-result-put-path, empty")
      ("search-result get-path must be readable")
      ("search-result put-path must be readable"): Fix path sizes.
---
 gnu/gnunet/dht/client.scm        | 99 +++++++++++++++++++++++++++++++++++-----
 tests/distributed-hash-table.scm | 64 ++++++++++++++++++++------
 2 files changed, 138 insertions(+), 25 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/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.