[gnunet-scheme] branch master updated (b8e0342 -> 1ebfca1)

[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 b8e0342  dht/client: In 'datum->search-result', verify the path 
lengths.
     new 835ebda  dht/client: Partially document get paths and put paths.
     new 44ccd8c  dht/client: Use /dht:path-element.
     new 25ded09  tests/distributed-hash-table: Randomise keys and values.
     new 8230914  tests/distributed-hash-table: Correct name of test case.
     new 84a3468  dht/client: Write a basic test for insertion.
     new 1ebfca1  tests/distributed-hash-table: Randomise expiration time.

The 6 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:
 doc/scheme-gnunet.tm             |  25 +++++--
 gnu/gnunet/dht/client.scm        |  44 ++++++++----
 tests/distributed-hash-table.scm | 144 +++++++++++++++++++++++++++++++--------
 3 files changed, 166 insertions(+), 47 deletions(-)

diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index f242adf..37ec484 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -1121,11 +1121,26 @@
 
   <\explain>
     <scm|(datum-\<gtr\>search-result <var|datum> #:get-path #:put-path)>
-  </explain|Make a search result object for the datum <var|datum>. The datum
-  can be recovered with the accessor <scm|search-result-\<gtr\>datum>. It can
-  be tested if an object is a search result with the predicate
-  <scm|search-result?>. The optional keyword arguments <scm|get-path> and
-  <scm|put-path> are currently undocumented and untested.>
+  <|explain>
+    Make a search result object for the datum <var|datum>. The datum can be
+    recovered with the accessor <scm|search-result-\<gtr\>datum>. It can be
+    tested if an object is a search result with the predicate
+    <scm|search-result?>. The optional arguments <var|get-path> and
+    <var|put-path>, when not false, are bytevector slices consisting of a
+    list of <scm|/dht:path-element>.
+
+    The <var|get-path> , if any, is the path from the storage location to the
+    current peer. Conversely, the <var|put-path>, if any, is a path from the
+    peer that inserted the datum into the DHT to the storage location. The
+    <var|get-path> and <var|put-path> can be accessed with
+    <scm|search-result-get-path> and <scm|search-result-put-path>
+    respectively.
+
+    When the datum, get path and put path together are too large, a
+    <scm|&overly-large-paths> condition is raised. When the bytevector slice
+    length of <var|get-path> or <var|put-path> is not a multiple of the size
+    of a path element, then a <scm|&malformed-path> condition is raised.
+  </explain>
 
   <subsection|Accessing data in the DHT>
 
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 1f922b2..49c4340 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -83,8 +83,6 @@
          (only (gnu gnunet mq error-reporting)
                report-error)
          (gnu gnunet dht struct)
-         (only (gnu gnunet crypto struct)
-               /peer-identity)
          (only (gnu gnunet message protocols)
                message-type)
          (only (gnu gnunet netstruct syntactic)
@@ -288,8 +286,20 @@ query object with the predicate @code{query?}."
           "Make a search result object for the datum @var{datum}. The datum can
 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."
+optional arguments @var{get-path} and @var{put-path}, when not false, are 
bytevector
+slices consisting of a list of @code{/dht:path-element}.
+
+The @var{get-path} , if any, is the path from the storage location to the
+current peer. Conversely, the @var{put-path}, if any, is a path from the
+peer that inserted the datum into the DHT to the storage location. The
+@var{get-path}} and @var{put-path} can be accessed with
+@code{search-result-get-path} and @code{search-result-put-path} respectively.
+
+When the datum, get path and put path together are too large, a
+@code{&overly-large-paths} condition is raised. When the
+bytevector slice length of @var{get-path} or @var{put-path} is not a
+multiple of the size of a path element, then a @code{&malformed-path}
+condition is raised."
           ;; TODO: can a get-path exist without a put-path?
           (let^ ((! (make-who)
                     (make-who-condition 'datum->search-result))
@@ -504,12 +514,12 @@ TODO actually call @var{confirmed}"
     (define-syntax-rule (well-formed?/path-length slice type (field ...) 
compare)
       "Verify the TYPE message in @var{slice}, which has @var{field ...} ...
 (e.g. one or more of get-path-length or put-path-length) and corresponding
-/peer-identities at the end of the message is well-formed -- i.e., check if 
the length
+/dht:path-element at the end of the message is well-formed -- i.e., check if 
the length
 of @var{slice} corresponds to the size of @var{type} and the get-path-length 
and
 put-path-length.
 
 @var{compare} must be @code{=} if no additional payload follows, or @code{>=}
-if an addiional payload may follow.  The message type and the size in the
+if an additional payload may follow.  The message type and the size in the
 message header is assumed to be correct."
       ;; Warning: slice is evaluated multiple times!
       (and (>= (slice-length slice) (sizeof type '()))
@@ -517,8 +527,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 
'()))))))
+            (compare extra-size (* (+ field ...) (sizeof /dht:path-element 
'()))))))
 
     ;; TODO reduce duplication with (gnu gnunet nse client) --- maybe introduce
     ;; (gnu gnunet client) as in the C implementation?
@@ -528,7 +537,8 @@ even if not connected.  This is an idempotent operation."
       (atomic-box-set! (server-request-close?/box server) #t)
       (signal-condition! (server-request-close-condition server)))
 
-    (define* (connect config #:key (spawn spawn-fiber))
+    (define* (connect config #:key (connected values)
+                     (spawn spawn-fiber))
       "Connect to the DHT service in the background."
       (define request-close?/box (make-atomic-box #f))
       (define request-close-condition (make-condition))
@@ -541,6 +551,7 @@ even if not connected.  This is an idempotent operation."
                 new-put-operations new-put-operation-trigger
                 request-close?/box request-close-condition config
                 id->operation-map
+                #:connected connected
                 #:spawn spawn)
       (%make-server request-close?/box request-close-condition
                    new-get-operations new-get-operation-trigger
@@ -554,6 +565,7 @@ even if not connected.  This is an idempotent operation."
                        request-close?/box request-close-condition config
                        id->operation-map
                        #:key (spawn spawn-fiber)
+                       connected
                        #:rest rest)
       (define (process-client-result handle slice)
        "Process a reply @var{slice} (a @code{/:msg:dht:client:result}
@@ -567,12 +579,13 @@ structure) to the get request @var{handle}."
        (define get-path-length
          (read% /:msg:dht:client:result '(get-path-length) header))
        (define put-path
-         (slice-slice rest 0 (* (sizeof /peer-identity '()) put-path-length)))
+         (slice-slice rest 0 (* (sizeof /dht:path-element '())
+                                put-path-length)))
        (define get-path
-         (slice-slice rest (* (sizeof /peer-identity '()) put-path-length)
-                      (* (sizeof /peer-identity '()) get-path-length)))
+         (slice-slice rest (* (sizeof /dht:path-element '()) put-path-length)
+                      (* (sizeof /dht:path-element '()) get-path-length)))
        (define data
-         (slice-slice rest (* (sizeof /peer-identity '())
+         (slice-slice rest (* (sizeof /dht:path-element '())
                               (+ put-path-length get-path-length))))
        ;; TODO: maybe validate 'key' and 'type'
        ((get:iterator handle)
@@ -640,8 +653,11 @@ structure) to the get request @var{handle}."
       (define (error-handler error . arguments)
        (case error
          ((connection:connected)
+          (connected)
+          ;; TODO: resume old requests
           (pk 'todo-connected)
           'todo)
+         ;; TODO: signal (and wait for) current fibers to stop?
          ((input:regular-end-of-file input:premature-end-of-file)
           (signal-condition! mq-closed)
           (unless (atomic-box-ref request-close?/box)
@@ -650,6 +666,8 @@ structure) to the get request @var{handle}."
                    new-put-operations new-put-operation-trigger
                    request-close?/box request-close-condition
                    config id->operation-map rest)))
+         ;; TODO: is this cargo-copying from (gnu gnunet nse client)
+         ;; correct?
          ((connection:interrupted)
           (values))
          (else
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 79e1831..cc6b8b8 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -23,17 +23,22 @@
        (gnu gnunet dht client)
        (gnu gnunet dht struct)
        (gnu gnunet utils bv-slice)
+       (gnu gnunet utils hat-let)
        (gnu gnunet netstruct syntactic)
        (gnu gnunet hashcode struct)
        (gnu gnunet block)
        (gnu gnunet message protocols)
+       (gnu gnunet mq handler)
+       (gnu gnunet mq-impl stream)
        (gnu extractor enum)
        (rnrs exceptions)
        (rnrs conditions)
        (rnrs base)
        (rnrs bytevectors)
        (srfi srfi-26)
-       (srfi srfi-64))
+       (srfi srfi-64)
+       (fibers conditions)
+       (tests utils))
 
 ;; Copied from tests/bv-slice.scm.
 (define-syntax-rule (test-missing-caps test-case what permitted required code)
@@ -107,11 +112,19 @@
 (test-error "way too small" (bound-replication-level (- 
%minimum-replication-level #e1e20)))
 (test-error "non-numeric" (bound-replication-level 'what))
 
+(define (make-slice/read-write* size)
+  "Like @code{make-slice/read-write*}, but fill the slice with random data."
+  (define s (make-slice/read-write size))
+  (let^ ((/o/ loop (i 0))
+        (? (>= i size) s))
+       (slice-u8-set! s i (random 256))
+       (loop (+ i 1))))
+
 (define* (make-a-datum #:key
                       (type 0)
-                      (key (make-slice/read-write (sizeof /hashcode:512 '())))
+                      (key (make-slice/read-write* (sizeof /hashcode:512 '())))
                       (value (make-slice/read-write 0))
-                      (expiration 0))
+                      (expiration (random (expt 2 64))))
   (make-datum type key value #:expiration expiration))
 (test-assert "datum?"
   (datum? (make-a-datum)))
@@ -148,10 +161,10 @@
     (datum-type (make-a-datum #:type type))))
 
 (datum-key-test "datum-key"
-               (make-slice/read-write (sizeof /hashcode:512 '())))
+               (make-slice/read-write* (sizeof /hashcode:512 '())))
 (datum-key-test "datum-key, read-only is sufficient"
                (slice/read-only
-                (make-slice/read-write
+                (make-slice/read-write*
                  (sizeof /hashcode:512 '()))))
 
 (test-missing-caps
@@ -159,14 +172,14 @@
  'key
  CAP_WRITE
  CAP_READ
- (make-a-datum #:key (slice/write-only (make-slice/read-write
+ (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))
+                 (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
@@ -175,7 +188,7 @@
               (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)))))
+      (make-a-datum #:type type #:value (make-slice/read-write* length)))))
 
 (test-datum-overly-large
  "datum-value, too large (1, numeric type)" 19 19
@@ -245,12 +258,10 @@
   ;; A least in Guile 3.0.5, all bytevectors of length 0 are eq?,
   ;; so let the value be non-empty such that datum-independent?
   ;; can return #true.
-  (let* ((old-key (make-slice/read-write (sizeof /hashcode:512 '())))
-        (old-value (make-slice/read-write 70))
-        (old (make-a-datum #:value old-value #:expiration 777)))
-    (slice-u32-set! old-key 9 #xcabba9e (endianness big))
-    (slice-u32-set! old-value 5 #xcabba9e (endianness big))
-    (let ((new (copy-datum old)))
+  (let* ((old-key (make-slice/read-write* (sizeof /hashcode:512 '())))
+        (old-value (make-slice/read-write* 70))
+        (old (make-a-datum #:key old-key #:value old-value #:expiration 777)))
+     (let ((new (copy-datum old)))
       (and (datum=? old new)
           (datum-independent? old new)))))
 
@@ -259,14 +270,10 @@
 
 ;; 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 (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))
-    (slice-u32-set! old-put-path 1 #xcabba9e (endianness big))
+  (let* ((old-key (make-slice/read-write* (sizeof /hashcode:512 '())))
+        (old-value (make-slice/read-write* 70))
+        (old-get-path (make-slice/read-write* (path-length->size 5)))
+        (old-put-path (make-slice/read-write* (path-length->size 9))))
     (let* ((old-datum (make-a-datum #:value old-value #:expiration 555))
           (old (datum->search-result old-datum #:get-path old-get-path
                                      #:put-path old-put-path))
@@ -288,11 +295,11 @@
 ;; These detected a bug: the capabilities were not restricted!
 ;; 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 (path-length->size 7)))
+ "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" (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"
@@ -309,16 +316,16 @@
  CAP_READ
  (datum->search-result
   (make-a-datum) #:get-path
-  (slice/write-only (make-slice/read-write (path-length->size 7)))))
+  (slice/write-only (make-slice/read-write* (path-length->size 7)))))
 
 (test-missing-caps
- "search-result get-path must be readable"
+ "search-result put-path must be readable"
  'put-path
  CAP_WRITE
  CAP_READ
  (datum->search-result
   (make-a-datum) #:put-path
-  (slice/write-only (make-slice/read-write (path-length->size 7)))))
+  (slice/write-only (make-slice/read-write* (path-length->size 7)))))
 
 (define (test-malformed-path test-case what keyword)
   (test-assert test-case
@@ -336,7 +343,7 @@
                                 (malformed-path-size c))))
                  (datum->search-result
                   (make-a-datum) keyword
-                  (make-slice/read-write size)))
+                  (make-slice/read-write* size)))
                (list 'datum->search-result what size)))))))
 
 (test-malformed-path
@@ -347,4 +354,83 @@
  "put-path size must be a multiple of the size of a path element"
  'put-path #:put-path)
 
+
+;;;
+;;; Test client<->service communication.
+;;;
+;;; Currently, the following operations are tested:
+;;;
+;;;  * [x] insertion (@code{put!})
+;;;  * [ ] retrieval (@code{start-get!})
+;;;  * [ ] monitoring
+;;;
+;;; In the following contexts:
+;;;
+;;;  * [x] nothing special
+;;;  * [ ] after a reconnection
+;;;  * [ ] requested before a reconnection, without being processed
+;;;        before the reconnection.
+;;;  * [ ] requested (and started) before a reconnection and continued
+;;;        after the reconnection
+;;;
+;;; Cancelling, closing the connection, parallelism and multiple
+;;; in-progress requests are currently untested (TBD and implemented!).
+
+(define i (datum->insertion (make-a-datum) #:desired-replication-level 7))
+
+(define (no-error-handler . e)
+  (pk 'e e)
+  (error "no error handler"))
+
+;; TODO: options
+(define (client-put->insertion slice)
+  (let^ ((! header (slice-slice slice 0 (sizeof /:msg:dht:client:put '())))
+        (! type (read% /:msg:dht:client:put '(type) header))
+        (! key (select /:msg:dht:client:put '(key) header))
+        (! value (slice-slice slice (sizeof /:msg:dht:client:put '())))
+        (! desired-replication-level
+           (read% /:msg:dht:client:put '(desired-replication-level) header))
+        (! expiration
+           (read% /:msg:dht:client:put '(expiration) header))
+        (! datum (make-datum type key value #:expiration expiration))
+        (! datum (copy-datum datum))
+        (! insertion
+           (datum->insertion datum #:desired-replication-level
+                             desired-replication-level)))
+       insertion))
+
+(test-equal "put! sends one message to service, after connecting"
+  i
+  (let^ ((! connected? #false)
+        (! (connected)
+           (assert (not connected?))
+           (set! connected? #true))
+        (! message #false)
+        (! message-received (make-condition))
+        (! (handle slice)
+           (when message
+             (error "already received"))
+           (set! message slice)
+           (signal-condition! message-received))
+        (! h (message-handlers
+              (message-handler
+               (type (symbol-value message-type msg:dht:client:put))
+               ((interpose foo) foo)
+               ((well-formed? s) #true)
+               ((handle! slice) (handle slice))))))
+       (call-with-services/fibers
+        `(("dht" . ,(lambda (port spawn-fiber)
+                      (define mq
+                        (port->message-queue port h no-error-handler
+                                             #:spawn spawn-fiber))
+                      (values))))
+        (lambda (config spawn-fiber)
+          (define server
+            (connect config #:connected connected #:spawn spawn-fiber))
+          (put! server i)
+          (wait message-received)
+          (assert connected?)
+          (assert message)
+          (client-put->insertion message)))))
+
 (test-end)

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