[gnunet-scheme] branch master updated: dht/client: Extract network message manipulation code.

[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.

The following commit(s) were added to refs/heads/master by this push:
     new 92e4389  dht/client: Extract network message manipulation code.
92e4389 is described below

commit 92e43898341d0ace08d8d717dd96928693396aa3
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Feb 2 16:45:13 2022 +0000

    dht/client: Extract network message manipulation code.
    
    * gnu/gnunet/dht/network.scm: New module.
    * doc/scheme-gnunet.tm (Constructing and analysing network messages):
      Document new procedures.
    * gnu/gnunet/dht/client.scm
      (copy-insertion): New procedure.
      (construct-client-get): Extract from ...
      (send-get!): ... here.
      (construct-client-put): Extract from ...
      (put!): ... here.
      (analyse-client-result): Extract from ...
      (reconnect)[process-client-result]: ... here, and adjust ...
      (reconnect)[handlers]<msg:dht:client:result>{handle}: ... this
      procedure appropriately.
      (analyse-client-get): Extract from ...
    * tests/distributed-hash-table.scm
      (simulate-dht-service)[handle-table]<handle/start-get!>: ... here.
    * gnu/gnunet/dht/client.scm (analyse-client-put): Extract from ...
    * tests/distributed-hash-table.scm
      (simulate-dht-service)[handle-table]<handle/put!>: ... here.
    * gnu/gnunet/dht/client.scm (construct-client-result): Extract from ...
    * tests/distributed-hash-table.scm
      (simulate-dht-service)[handle-table]<handle/start-get!>: ... here.
---
 Makefile.am                      |   1 +
 doc/scheme-gnunet.tm             |  68 ++++++++++
 gnu/gnunet/dht/client.scm        | 275 ++++++++++++++++++++++++++++-----------
 gnu/gnunet/dht/network.scm       |  27 ++++
 tests/distributed-hash-table.scm |  85 ++++--------
 5 files changed, 316 insertions(+), 140 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index a400c10..b9bc3db 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -69,6 +69,7 @@ modules = \
   gnu/gnunet/crypto/struct.scm \
   \
   gnu/gnunet/dht/client.scm \
+  gnu/gnunet/dht/network.scm \
   gnu/gnunet/dht/struct.scm \
   \
   gnu/gnunet/util/cmsg.scm \
diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index f73a2e2..ae413c2 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -1189,8 +1189,76 @@
   modification to the slices in <var|old> do not impact the new search
   result.>
 
+  <todo|copy insertion>
+
   <todo|cancellation>
 
+  <section|Constructing and analysing network messages>
+
+  The DHT client and service communicate by sending <em|messages>. Usually,
+  only the implementation of the client and service need to construct and
+  analyse these messages, but nothing prevents other uses of the procedures
+  in <scm|(gnu gnunet dht network)>, e.g. for learning, in a tool like
+  Wireshark or for tests.
+
+  The <em|analysis> procedures assume that the message is well-formed and
+  avoid constructing new bytevector slices by taking subslices. The
+  <em|construction> procedures create fresh well-formed read-write bytevector
+  slices.
+
+  <\warning>
+    Possibly the type of <var|options> will change and possibly the options
+    will be moved into the query object and insertion object.
+  </warning>
+
+  <\explain>
+    <scm|(construct-client-get <var|query> <var|unique-id> #:optional
+    (<var|options> 0))>
+  <|explain>
+    Create a new <scm|/:msg:dht:client:get> message for the query object
+    <var|query>, with <var|unique-id> as \<#2018\>unique id\<#2019\> and
+    <var|options> as options.
+  </explain>
+
+  <\explain>
+    <scm|(construct-client-put <var|insertion> #:optional (options 0))>
+  <|explain>
+    Create a new <scm|/:msg:dht:client:put> message for the insertion object
+    <var|insertion> with <var|options> as options.
+  </explain>
+
+  <\explain>
+    <scm|(construct-client-result <var|search-result> <var|unique-id>)>
+  <|explain>
+    Create a new <scm|/:msg:dht:client:result> message for the search result
+    object <var|search-result>, with <var|unique-id> as \<#2018\>unique
+    id\<#2019\> .
+  </explain>
+
+  <\explain>
+    <scm|(analyse-client-get <var|message>)>
+  <|explain>
+    Return the query object, the unique id and the options corresponding to
+    the <scm|/:msg:dht:client:result> message <var|message>. Xqueries are
+    currently unsupported.
+  </explain>
+
+  <\explain>
+    <scm|(analyse-client-put <var|message>)>
+  <|explain>
+    Return the insertion object and options corresponding to the
+    <scm|/:msg:dht:client:put> message <var|message>.
+  </explain>
+
+  <\explain>
+    <scm|(analyse-client-result <var|message>)>
+  <|explain>
+    Return search result object and unique id for the
+    <scm|/:msg:dht:client:result> message <var|message>.
+  </explain>
+
+  <todo|monitoring messages>
+
   <section|How to handle invalid data>
 
   <todo|todo!>
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 49c4340..9ca6834 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -46,7 +46,16 @@
          datum->search-result search-result? search-result->datum
          search-result-get-path search-result-put-path
 
-         copy-datum copy-search-result
+         copy-datum copy-search-result copy-insertion
+
+         ;; Network message manipulation procedures
+         ;; (these belong to (gnu gnunet dht network)).
+         (rename (construct-client-get #{ construct-client-get}#)
+                 (construct-client-put #{ construct-client-put}#)
+                 (construct-client-result #{ construct-client-result}#)
+                 (analyse-client-get #{ analyse-client-get}#)
+                 (analyse-client-put #{ analyse-client-put}#)
+                 (analyse-client-result #{ analyse-client-result}#))
 
          connect
          disconnect!
@@ -92,7 +101,7 @@
                slice-slice verify-slice-readable)
          (gnu gnunet utils hat-let)
          (only (rnrs base)
-               and >= = quote * + - define begin ... let*
+               and >= = quote * / + - define begin ... let*
                quote case else values apply let cond if >
                <= expt assert exact? integer? lambda for-each
                not expt min max div-and-mod positive?)
@@ -256,6 +265,14 @@ be tested if an object is an insertion object with the 
predicate
           (%make (validate-datum datum)
                  (bound-replication-level desired-replication-level))))))
 
+    ;; TODO: test and document
+    (define (copy-insertion old)
+      "Make a copy of the insertion @var{old}, such that modifications to the
+slices in @var{old} do not impact the new insertion."
+      (datum->insertion (copy-datum (insertion->datum old))
+                       #:desired-replication-level
+                       (insertion-desired-replication-level old)))
+
     (define-record-type (<query> make-query query?)
       (fields (immutable type query-type)
              (immutable key query-key)
@@ -363,6 +380,165 @@ slices in @var{old} do not impact the new search result."
 
     
 
+    ;;;
+    ;;; Constructing and analysing network messages.
+    ;;;
+    ;;; These procedures are defined here instead of in (gnu gnunet dht 
network),
+    ;;; but only to prevent cycles.
+    ;;;
+
+    (define* (construct-client-get query unique-id #:optional (options 0))
+      "Create a new @code{/:msg:dht:client:get} message for the query object
+ @var{query}, with @var{unique-id} as ‘unique id’ and @var{options} as 
options."
+      (define s (make-slice/read-write (sizeof /:msg:dht:client:get '())))
+      (set%! /:msg:dht:client:get '(header size) s (slice-length s))
+      (set%! /:msg:dht:client:get '(header type) s
+            (value->index (symbol-value message-type msg:dht:client:get)))
+      (set%! /:msg:dht:client:get '(options) s options)
+      (set%! /:msg:dht:client:get '(desired-replication-level) s
+            (query-desired-replication-level query))
+      (set%! /:msg:dht:client:get '(type) s (query-type query))
+      (slice-copy! (query-key query) (select /:msg:dht:client:get '(key) s))
+      (set%! /:msg:dht:client:get '(unique-id) s unique-id)
+      s)
+
+    (define* (construct-client-put insertion #:optional (options 0))
+      "Create a new @code{/:msg:dht:client:put} message for the insertion
+object insertion with @var{options} as options."
+      (define datum (insertion->datum insertion))
+      (define size/header (sizeof /:msg:dht:client:put '()))
+      (define size (+ size/header (slice-length (datum-value datum))))
+      (define message
+       (make-slice/read-write
+        (+ size/header (slice-length (datum-value datum)))))
+      (define header (slice-slice message 0 size/header))
+      (define rest (slice-slice message size/header))
+      (set%! /:msg:dht:client:put '(header type) header
+            (value->index (symbol-value message-type msg:dht:client:put)))
+      (set%! /:msg:dht:client:put '(header size) header size)
+      (set%! /:msg:dht:client:put '(type) header (datum-type datum))
+      (set%! /:msg:dht:client:put '(option) header options)
+      (set%! /:msg:dht:client:put '(desired-replication-level) header
+            (insertion-desired-replication-level insertion))
+      (set%! /:msg:dht:client:put '(expiration) header (datum-expiration 
datum))
+      ;; Copy key-data pair to insert into the DHT.
+      (slice-copy! (datum-key datum)
+                  (select /:msg:dht:client:put '(key) header))
+      (slice-copy! (datum-value datum) rest)
+      message)
+
+    (define (construct-client-result search-result unique-id)
+      "Create a new @code{/:msg:dht:client:result} message for the search
+result object @var{search-result}, with @var{unique-id} as ‘unique id’"
+      (let^ ((! datum (search-result->datum search-result))
+            (! get-path (search-result-get-path search-result))
+            (! put-path (search-result-put-path search-result))
+            (! type (datum-type datum))
+            (! key (datum-key datum))
+            (! value (datum-value datum))
+            (! expiration (datum-expiration datum))
+            (! size/header (sizeof /:msg:dht:client:result '()))
+            (! (path-length path)
+               (if path
+                   (/ (slice-length path) (sizeof /dht:path-element '()))
+                   0))
+            (! get-path-length (path-length get-path))
+            (! put-path-length (path-length put-path))
+            (! size (+ size/header
+                       (slice-length value)
+                       get-path-length
+                       put-path-length))
+            (! message (make-slice/read-write size))
+            (! header (slice-slice message 0 size/header))
+            (! rest (slice-slice message size/header)))
+           (set%! /:msg:dht:client:result '(header type)
+                  header
+                  (value->index
+                   (symbol-value message-type msg:dht:client:result)))
+           (set%! /:msg:dht:client:result '(header size)
+                  header
+                  size)
+           (set%! /:msg:dht:client:result '(type) header type)
+           (set%! /:msg:dht:client:result '(get-path-length)
+                  header get-path-length)
+           (set%! /:msg:dht:client:result '(put-path-length)
+                  header put-path-length)
+           (set%! /:msg:dht:client:result '(unique-id) header unique-id)
+           (set%! /:msg:dht:client:result '(expiration) header expiration)
+           (slice-copy! key (select /:msg:dht:client:result '(key) header))
+           ;; TODO: get-path and put path!
+           (slice-copy! value rest)
+           message))
+
+    (define (analyse-client-get message)
+      "Return the query object, the unique id and the options corresponding to
+the @code{/:msg:dht:client:result} message @var{message}.  Xqueries are
+currently unsupported."
+      (let^ ((! type (read% /:msg:dht:client:get '(type) message))
+            (! key (select /:msg:dht:client:get '(key) message))
+            (! desired-replication-level
+               (read% /:msg:dht:client:get '(desired-replication-level) 
message))
+            (! unique-id (read% /:msg:dht:client:get '(unique-id) message))
+            (! options (read% /:msg:dht:client:get '(options) message))
+            (! query
+               (make-query type key #:desired-replication-level
+                           desired-replication-level)))
+           (values query unique-id options)))
+
+    (define (analyse-client-put message)
+      "Return the insertion object and options corresponding to the
+@code{/:msg:dht:client:put} message @var{message}."
+      (let^ ((! header (slice-slice message 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 message (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))
+            (! options
+               (read% /:msg:dht:client:put '(option) header))
+            (! datum (make-datum type key value #:expiration expiration))
+            (! insertion
+               (datum->insertion datum #:desired-replication-level
+                                 desired-replication-level)))
+           (values insertion options)))
+
+    (define (analyse-client-result message)
+      "Return search result object and unique id for the
+@code{/:msg:dht:client:result} message @var{message}."
+      (let^ ((! message (slice/read-only message))
+            (! size/header (sizeof /:msg:dht:client:result '()))
+            (! header (slice-slice message 0 size/header))
+            (! rest (slice/read-only message size/header))
+            (! put-path-length
+               (read% /:msg:dht:client:result '(put-path-length) header))
+            (! get-path-length
+               (read% /:msg:dht:client:result '(get-path-length) header))
+            (! size/path-element (sizeof /dht:path-element '()))
+            (! put-path
+               (slice-slice rest 0 (* size/path-element put-path-length)))
+            (! get-path
+               (slice-slice rest (* size/path-element put-path-length)
+                            (* size/path-element get-path-length)))
+            (! value
+               (slice-slice rest (* (sizeof /dht:path-element '())
+                                    (+ put-path-length get-path-length))))
+            (! datum
+               (make-datum
+                (read% /:msg:dht:client:result '(type) header)
+                (select /:msg:dht:client:result '(key) header)
+                value
+                #:expiration
+                (read% /:msg:dht:client:result '(expiration) header)))
+            (! search-result
+               (datum->search-result
+                datum #:get-path get-path #:put-path put-path))
+            (! unique-id (read% /:msg:dht:client:result '(unique-id) header)))
+           (values search-result unique-id)))
+
+    
+
     ;; New get or put operations are initially in new-get-operations or
     ;; new-put-operation, and not in id->operation-map.  They are moved
     ;; in the background by 'process-new-get-operations' and
@@ -412,19 +588,9 @@ slices in @var{old} do not impact the new search result."
 
     (define (send-get! mq get)
       "Send a GET message for @var{get}."
-      (pk 'new get)
-      (define s (make-slice/read-write (sizeof /:msg:dht:client:get '())))
-      (set%! /:msg:dht:client:get '(header size) s (slice-length s))
-      (set%! /:msg:dht:client:get '(header type) s
-            (value->index (symbol-value message-type msg:dht:client:get)))
-      (set%! /:msg:dht:client:get '(options) s (get:options get))
-      (set%! /:msg:dht:client:get '(desired-replication-level) s
-            (query-desired-replication-level (get:query get)))
-      (set%! /:msg:dht:client:get '(type) s (query-type (get:query get)))
-      (slice-copy! (query-key (get:query get))
-                  (select /:msg:dht:client:get '(key) s))
-      (set%! /:msg:dht:client:get '(unique-id) s (get:unique-id get))
-      (send-message! mq s))
+      (send-message! mq (construct-client-get (get:query get)
+                                             (get:unique-id get)
+                                             (get:options get))))
 
     (define (fresh-id server)
       "Generate a fresh numeric ID to use for communication with @var{server}."
@@ -487,26 +653,9 @@ the thunk @var{confirmed} is called. A @emph{put object} 
is returned which can
 be used to stop the insertion.
 
 TODO actually call @var{confirmed}"
-      ;; Prepare the message to send.
-      (define datum (insertion->datum insertion))
-      (define put-message
-       (make-slice/read-write (+ (sizeof /:msg:dht:client:put '())
-                                 (slice-length (datum-value datum)))))
-      (define meta (slice-slice put-message 0
-                               (sizeof /:msg:dht:client:put '())))
-      (set%! /:msg:dht:client:put '(header type) meta
-            (value->index (symbol-value message-type msg:dht:client:put)))
-      (set%! /:msg:dht:client:put '(header size) meta (slice-length 
put-message))
-      (set%! /:msg:dht:client:put '(type) meta (datum-type datum))
-      (set%! /:msg:dht:client:put '(option) meta 0) ; TODO
-      (set%! /:msg:dht:client:put '(desired-replication-level) meta
-            (insertion-desired-replication-level insertion))
-      (set%! /:msg:dht:client:put '(expiration) meta (datum-expiration datum))
-      ;; Copy key-data pair to insert into the DHT.
-      (slice-copy! (datum-key datum) (select /:msg:dht:client:put '(key) meta))
-      (slice-copy! (datum-value datum)
-                  (slice-slice put-message (sizeof /:msg:dht:client:put '())))
-      (define handle (%make-put server confirmed put-message))
+      ;; Prepare the message to send.  TODO: options
+      (define message (construct-client-put insertion))
+      (define handle (%make-put server confirmed message))
       (hashq-set! (server-new-put-operations server) handle #t)
       (trigger-condition! (server-new-put-operation-trigger server))
       handle)
@@ -567,36 +716,6 @@ even if not connected.  This is an idempotent operation."
                        #:key (spawn spawn-fiber)
                        connected
                        #:rest rest)
-      (define (process-client-result handle slice)
-       "Process a reply @var{slice} (a @code{/:msg:dht:client:result}
-structure) to the get request @var{handle}."
-       (define header (slice/read-only slice 0
-                                       (sizeof /:msg:dht:client:result '())))
-       (define rest (slice/read-only slice
-                                     (sizeof /:msg:dht:client:result '())))
-       (define put-path-length
-         (read% /:msg:dht:client:result '(put-path-length) header))
-       (define get-path-length
-         (read% /:msg:dht:client:result '(get-path-length) header))
-       (define put-path
-         (slice-slice rest 0 (* (sizeof /dht:path-element '())
-                                put-path-length)))
-       (define get-path
-         (slice-slice rest (* (sizeof /dht:path-element '()) put-path-length)
-                      (* (sizeof /dht:path-element '()) get-path-length)))
-       (define data
-         (slice-slice rest (* (sizeof /dht:path-element '())
-                              (+ put-path-length get-path-length))))
-       ;; TODO: maybe validate 'key' and 'type'
-       ((get:iterator handle)
-        (datum->search-result
-         (make-datum
-          (read% /:msg:dht:client:result '(type) header)
-          (select /:msg:dht:client:result '(key) header)
-          data
-          #:expiration
-          (read% /:msg:dht:client:result '(expiration) header))
-         #:get-path get-path #:put-path put-path)))
       (define handlers
        (message-handlers
         (message-handler
@@ -636,18 +755,20 @@ structure) to the get request @var{handle}."
                                     (get-path-length put-path-length) >=))
          ((handle! slice)
           ;; The DHT service found some data we were looking for.
-          (let* ((header (slice-slice slice 0
-                                      (sizeof /:msg:dht:client:result '())))
-                 (id (read% /:msg:dht:client:result '(unique-id) header))
-                 (handle (hashv-ref id->operation-map id)))
-            (cond ((not handle)
-                   (pk 'id id)
-                   TODO-error-reporting/1)
-                  ((get? handle)
-                   ;; TODO might not be true once monitoring operations
-                   ;; are supported.
-                   (process-client-result handle slice))
-                  (#true TODO-error-reporting/2)))))))
+          (let^ ((<-- (search-result unique-id)
+                      ;; TODO: maybe verify the type and key?
+                      (analyse-client-result slice))
+                 (! handle (hashv-ref id->operation-map unique-id))
+                 (? (not handle)
+                    ;; Where did this unique id come from?
+                    (pk 'unique-id unique-id)
+                    TODO-error-reporting/1)
+                 (? (get? handle)
+                    ;; TODO might not be true once monitoring operations
+                    ;; are supported.
+                    ((get:iterator handle) search-result)))
+                ;; TODO: wrong type (maybe a put handle?).
+                TODO-error-reporting/2)))))
       ;; TODO: abstract duplication in (gnu gnunet nse client)
       (define mq-closed (make-condition))
       (define (error-handler error . arguments)
diff --git a/gnu/gnunet/dht/network.scm b/gnu/gnunet/dht/network.scm
new file mode 100644
index 0000000..6dd4129
--- /dev/null
+++ b/gnu/gnunet/dht/network.scm
@@ -0,0 +1,27 @@
+;; This file is part of Scheme-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-library (gnu gnunet dht network)
+  (export construct-client-get construct-client-put construct-client-result
+         analyse-client-get analyse-client-put analyse-client-result)
+  (import (rename (gnu gnunet dht client)
+                 (#{ construct-client-get}# construct-client-get)
+                 (#{ construct-client-put}# construct-client-put)
+                 (#{ construct-client-result}# construct-client-result)
+                 (#{ analyse-client-get}# analyse-client-get)
+                 (#{ analyse-client-put}# analyse-client-put)
+                 (#{ analyse-client-result}# analyse-client-result))))
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 28de506..1909b21 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -22,6 +22,7 @@
        (quickcheck generator)
        (quickcheck property)
        (gnu gnunet dht client)
+       (gnu gnunet dht network)
        (gnu gnunet dht struct)
        (gnu gnunet utils bv-slice)
        (gnu gnunet utils hat-let)
@@ -385,58 +386,6 @@
   (pk 'e e)
   (error "no error handler"))
 
-;; TODO: options, (gnu gnunet dht network)?
-(define (client-get->query message)
-  (let^ ((! type (read% /:msg:dht:client:get '(type) message))
-        (! key (select /:msg:dht:client:get '(key) message))
-        (! desired-replication-level
-           (read% /:msg:dht:client:get '(desired-replication-level) message))
-        (! unique-id (read% /:msg:dht:client:get '(unique-id) message))
-        (! query
-           (make-query type key #:desired-replication-level
-                       desired-replication-level)))
-       (values query unique-id)))
-
-(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))
-
-(define (insertion->result insertion unique-id)
-  (let^ ((! datum (insertion->datum insertion))
-        (! value (datum-value datum))
-        (! size (+ (sizeof /:msg:dht:client:result '())
-                   (slice-length value)))
-        (! slice (make-slice/read-write size))
-        (! header (slice-slice slice 0 (sizeof /:msg:dht:client:result '())))
-        (! rest (slice-slice slice (sizeof /:msg:dht:client:result '()))))
-       (set%! /:msg:dht:client:result '(header type)
-              header
-              (value->index (symbol-value message-type msg:dht:client:result)))
-       (set%! /:msg:dht:client:result '(header size) header size)
-       (set%! /:msg:dht:client:result '(type) header (datum-type datum))
-       ;; TODO: get and put paths, options
-       (set%! /:msg:dht:client:result '(put-path-length) header 0)
-       (set%! /:msg:dht:client:result '(get-path-length) header 0)
-       (set%! /:msg:dht:client:result '(unique-id) header unique-id)
-       (set%! /:msg:dht:client:result '(expiration) header
-              (datum-expiration datum))
-       (slice-copy! (datum-key datum)
-                    (select /:msg:dht:client:result '(key) header))
-       (slice-copy! (datum-value datum) rest)
-       slice))
-
 ;; TODO: would be nice to turn this in a real service
 ;; (gnu gnunet dht service).
 (define (simulate-dht-service)
@@ -500,22 +449,28 @@ supported."
               ((interpose foo) foo)
               ((well-formed? s) #true)
               ((handle! slice) (handle!* slice))))
-          (! (handle/put! message)
-             ""
-             (put-message table-channel
-                          `(put! ,(client-put->insertion message))))
+          (!^ (handle/put! message)
+              "Respond to a @code{/:msg:dht:client:put} message."
+              ((<-- (insertion _) (analyse-client-put message))
+               (! insertion (copy-insertion insertion)))
+              (put-message table-channel `(put! ,insertion)))
           (!^ (handle/start-get! message)
               ""
               ((! channel (make-channel))
-               (<-- (query unique-id) (client-get->query message)))
+               (<-- (query unique-id _) (analyse-client-get message)))
               (put-message table-channel `(start-get! ,query ,channel))
               (spawn-fiber
                (lambda ()
-                 (let loop ()
-                   (define insertion (get-message channel))
-                   (wait mq-defined)
-                   (send-message! mq (insertion->result insertion unique-id))
-                   (loop))))
+                 (let^ ((/o/ loop)
+                        (! insertion (get-message channel))
+                        ;; The tests don't require get-path/put-path.
+                        (! search-result (datum->search-result
+                                          (insertion->datum insertion)))
+                        (! message (construct-client-result search-result
+                                                            unique-id)))
+                       (wait mq-defined)
+                       (send-message! mq message)
+                       (loop))))
               (values))
           (! h (message-handlers
                 (simple-message-handler
@@ -561,7 +516,11 @@ supported."
           (wait message-received)
           (assert connected?)
           (assert message)
-          (client-put->insertion message)))))
+          (let^ ((<-- (insertion _)
+                      (analyse-client-put message)))
+                ;; TODO: copy to make equal? work
+                ;; (TODO: define equal? for slices)
+                (copy-insertion insertion))))))
 
 ;; Squat two message types for tests below.
 (define type:ping 7)

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