[gnunet-scheme] 04/04: dht/client: Cancel unreachable non-lingering search operations.

[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 e0376958cd84a72c2bba2e02c8ecf9318f1ce4ab
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Feb 16 21:12:35 2022 +0000

    dht/client: Cancel unreachable non-lingering search operations.
    
    Untested!
    
    Partially fixes <https://notabug.org/maximed/scheme-gnunet/issues/18>.
    
    * gnu/gnunet/dht/client.scm
      (<server>)[lost-and-found]: New field.
      (<get>): Make it a subtype of <losable>.  Set the lost-and-found
      appropriately.
      (connect): Pass a fresh lost-and-found to' %make-server' and
      'reconnect'.
      (reconnect)[handle-lost,process-stop-search]: New procedure.
      (reconnect)[loop-operation]: New variable.
      (reconnect)[control]<reconnect!>: Pass 'lost-and-found'.
      (reconnect)[control]<stop-search!>: Use new process-stop-search
      procedure.
      (reconnect)[control]<lost>: New case.
---
 gnu/gnunet/dht/client.scm | 59 ++++++++++++++++++++++++++++++++++-------------
 1 file changed, 43 insertions(+), 16 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 23f1d8d..9d37f0f 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -99,6 +99,8 @@
                make-channel put-operation get-operation get-message 
put-message)
          (only (gnu gnunet mq error-reporting)
                report-error)
+         (only (gnu gnunet concurrency lost-and-found)
+               make-lost-and-found collect-lost-and-found-operation)
          (gnu gnunet dht struct)
          (only (gnu gnunet message protocols)
                message-type)
@@ -115,7 +117,7 @@
                quote case else values apply let cond if > eq?
                <= expt assert exact? integer? lambda for-each
                not expt min max div-and-mod positive? define-syntax
-               vector)
+               vector cons)
          (only (rnrs control)
                unless when)
          (only (rnrs records syntactic)
@@ -582,6 +584,7 @@ currently unsupported."
       ;; terminal-condition: a disconnect has been requested
       (fields (immutable terminal-condition server-terminal-condition)
              (immutable control-channel server-control-channel)
+             (immutable lost-and-found server-lost-and-found)
              ;; Atomic box holding an unsigned 64-bit integer.
              (immutable next-unique-id/box server-next-unique-id/box)))
 
@@ -602,13 +605,13 @@ do anything if @var{server} has been permanently 
disconnected."
             (server-control-channel server) message))
 
     (define-record-type (<get> %make-get get?)
+      (parent <losable>)
       (fields (immutable server get:server)
              (immutable found get:iterator) ; procedure accepting 
<search-result>
              (immutable query get:query) ; <query>
              (immutable unique-id get:unique-id)
              (immutable options get:options)
-             ;; TODO: actually cancel (using (gnu gnunet concurrency
-             ;; lost-and-found))
+             ;; TODO: test if non-lingering actually works.
              ;;
              ;; If #false, 'reconnect' does not keep a strong reference to the
              ;; search object and 'reconnect' will automatically cancel the
@@ -616,7 +619,14 @@ do anything if @var{server} has been permanently 
disconnected."
              ;;
              ;; If #true, the search will not be automatically cancelled;
              ;; 'reconnect' keeps a strong reference.
-             (immutable linger? get:linger?))) ; boolean
+             (immutable linger? get:linger?))
+      (protocol (lambda (%make)
+                 (lambda (server found query unique-id options linger?)
+                   ;; When not lingering, add this search object to the lost
+                   ;; and found, such that it will eventually be cancelled.
+                   ((%make (and (not linger?)
+                                (server-lost-and-found server)))
+                    server found query unique-id options linger?)))))
 
     (define-record-type (<put> %make-put put?)
       (fields (immutable server put:server)
@@ -753,12 +763,13 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
       (define terminal-condition (make-condition))
       (define old-id->operation-map (make-hash-table))
       (define control-channel (make-channel))
+      (define lost-and-found (make-lost-and-found))
       (reconnect terminal-condition config
-                old-id->operation-map control-channel
+                old-id->operation-map control-channel lost-and-found
                 #:connected connected
                 #:disconnected disconnected
                 #:spawn spawn)
-      (%make-server terminal-condition control-channel
+      (%make-server terminal-condition control-channel lost-and-found
                    ;; Any ‘small’ exact natural number will do.
                    (make-atomic-box 0)))
 
@@ -774,7 +785,7 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
          reference))
 
     (define* (reconnect terminal-condition config
-                       old-id->operation-map control-channel
+                       old-id->operation-map control-channel lost-and-found
                        #:key (spawn spawn-fiber)
                        connected disconnected
                        #:rest rest)
@@ -901,6 +912,24 @@ operation is cancelled, return @code{#false} instead."
       (define mq (connect/fibers config "dht" handlers error-handler
                                 #:spawn spawn))
       (signal-condition! mq-defined)
+      (define (handle-lost handle)
+       ;; TODO: monitoring operations, put operations ...
+       (match handle
+         ((? get? get) (process-stop-search get))))
+      (define (process-stop-search get)
+       ;; TODO: tests!
+       ;; TODO: cancel outstanding messages to the DHT services for this
+       ;; get operation (including the request to start searching), if
+       ;; any.
+       (hashv-remove! old-id->operation-map (get:unique-id get))
+       (when (hashv-ref id->operation-map (get:unique-id get))
+         (hashv-remove! id->operation-map (get:unique-id get))
+         (send-stop-get! mq get)))
+      (define loop-operation
+       (choice-operation
+        (get-operation control-channel)
+        (wrap-operation (collect-lost-and-found-operation lost-and-found)
+                        (lambda (lost) (cons 'lost lost)))))
       (define (control)
        "The main event loop."
        (match (perform-operation (get-operation control-channel))
@@ -924,7 +953,7 @@ operation is cancelled, return @code{#false} instead."
          (('reconnect!)
           ;; Restart the loop with a new message queue.
           (apply reconnect terminal-condition config id->operation-map
-                 control-channel rest))
+                 control-channel lost-and-found rest))
          (('start-get! get)
           ;; Register the new get operation, such that we remember
           ;; where to send responses to.
@@ -937,14 +966,7 @@ operation is cancelled, return @code{#false} instead."
           ;; Continue!
           (control))
          (('stop-search! get)
-          ;; TODO: tests!
-          ;; TODO: cancel outstanding messages to the DHT services for this
-          ;; get operation (including the request to start searching), if
-          ;; any.
-          (hashv-remove! old-id->operation-map (get:unique-id get))
-          (when (hashv-ref id->operation-map (get:unique-id get))
-            (hashv-remove! id->operation-map (get:unique-id get))
-            (send-stop-get! mq get))
+          (process-stop-search get)
           ;; Continue!
           (control))
          (('put! put)
@@ -980,6 +1002,11 @@ operation is cancelled, return @code{#false} instead."
           ;; Free some memory.
           (hash-clear! old-id->operation-map)
           ;; Continue!
+          (control))
+         ;; Some handles became unreachable and can be cancelled.
+         (('lost lost)
+          (for-each handle-lost lost)
+          ;; Continue!
           (control))))
       ;; Start the main event loop.
       (spawn control))))

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