c3b2: use background thread to pull new messages (broken)

The program crash when trying to publish a message

3 files changed, 48 insertions, 26 deletions

diff --git a/gnunet/sync.scm b/gnunet/sync.scm
index 93c7b88..71173ab 100644
--- a/gnunet/sync.scm
+++ b/gnunet/sync.scm
@@ -44,7 +44,7 @@
                  fs
                  filename
                   ;; TODO: doesn't work, see publish-keywords
-                 (fs-uri-ksk-create "c3b2://topic")
+                 (fs-uri-ksk-create "c3b2://v1/message")
                  (container-meta-data-create)
                  %gnunet-yes
                  (fs-block-options))))
@@ -82,8 +82,11 @@ code is non-zero; otherwise return #t."
 
 (define-public (publish configuration filename keywords)
   "Publish FILENAME tagged with keywords"
+  (pk 1 configuration filename keywords)
   (let ((uri (publish-file configuration filename)))
+    (pk 2)
     (publish-keywords configuration uri keywords)
+    (pk 3)
     uri))
 
 ;;; search
@@ -102,13 +105,13 @@ code is non-zero; otherwise return #t."
 (define (search/timeout)
   (scheduler-shutdown))
 
-(define %ten-seconds (* 10 (expt 10 6)))
+(define %five-seconds (* 5 (expt 10 6)))
 
 (define (search/task configuration uri callback)
   (lambda ()
     (let ((fs (fs-start configuration "c3b2" (search/progress callback))))
       (let ((search-context (fs-search-start fs uri 1 %fs-search-option-none)))
-        (scheduler-add-delayed %ten-seconds search/timeout)
+        (scheduler-add-delayed %five-seconds search/timeout)
         (scheduler-add-shutdown (search/task/shutdown search-context))))))
 
 (define (search-exec configuration keywords callback)
@@ -152,7 +155,7 @@ code is non-zero; otherwise return #t."
 (define (download/timeout)
   (scheduler-shutdown))
 
-(define %one-second (* 3 (expt 10 6)))
+(define %one-second (* 1 (expt 10 6)))
 
 (define (download/task configuration uri callback)
   (lambda ()
diff --git a/guix.scm b/guix.scm
index ab52ef8..b9b4cb9 100644
--- a/guix.scm
+++ b/guix.scm
@@ -141,7 +141,8 @@
       (outputs '("out" "debug"))
       (arguments
        `(#:configure-flags
-         (list (string-append "--with-nssdir=" %output "/lib"))
+         (list (string-append "--with-nssdir=" %output "/lib")
+               "CFLAGS=-ggdb -O0")
                ;; AFAIK not necessary, will also regulary lead to broken
                ;; GNUnet builds (experimental is what it says)
                ;; "--enable-experimental")
diff --git a/prototypes/c3b2/web.scm b/prototypes/c3b2/web.scm
index 20e53f1..5ced5d3 100755
--- a/prototypes/c3b2/web.scm
+++ b/prototypes/c3b2/web.scm
@@ -22,15 +22,15 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
 ;; stdlib
 (use-modules ((ice-9 binary-ports)))
 (use-modules ((ice-9 match)))
+(use-modules ((ice-9 threads)))
 (use-modules ((rnrs bytevectors)))
 (use-modules ((web request)))
 (use-modules ((web uri)))
 
 ;; third party
-(use-modules ((fibers web server)))
+(use-modules ((web server)))
 (use-modules ((wiredtiger extra)))
 (use-modules ((wiredtiger feature-space)))
-(use-modules ((wiredtiger grf3)))
 (use-modules ((wiredtiger wiredtiger)))
 
 ;; local
@@ -61,27 +61,45 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
 
 ;;;
 
+(define (maybe-message-add! body uri)
+  (when (null? (fs:find 'uri uri))
+    (fs:add! `((kind . message) (body . ,body)))))
+
+(define (discover configuration)
+  (let loop ((uris (search configuration '("c3b2://v1/message"))))
+    (unless (null? uris)
+      (let ((body (download configuration (car uris))))
+        (when body
+          (pk 'add (car uris))
+          (maybe-message-add! (utf8->string body) (car uris)))
+        (loop (cdr uris))))))
+
+(define (run-discovery configuration)
+  "Run a background thread to look for new messages"
+  (call-with-new-thread
+   (lambda ()
+     (with-context*
+      (let loop ()
+        (discover configuration)
+        (loop)
+        (sleep 1))))))
+
+;;;
+
 (define (c3b2/topics)
-  "Return vertices of topics ie. messages without parent"
-  (map utf8->string
-       (filter values
-               (map (lambda (uri) (download %configuration uri))
-                    (search %configuration '("c3b2://v1/topic"))))))
+  (map (lambda (x) (assoc-ref x 'body))
+       (map fs:ref*
+            (fs:find 'kind 'message))))
 
 (define (c3b2/topic-add! body)
-  (let ((new-topic `((kind . message)
-                     (body . ,body)
-                     (parent . #f))))
-    (let ((topic (save (create-vertex new-topic))))
-      (let* ((payload (vertex-ref topic 'body))
-             (payload (string->utf8 payload))
-             (hash (make-hash payload))
-             (filepath (string-append %home "/" hash)))
-        (call-with-output-file filepath
-          (lambda (port)
-            (put-bytevector port payload))
-          #:binary #t)
-        (publish %configuration filepath '("c3b2://v1/topic"))))))
+  (let* ((payload (string->utf8 body))
+         (hash (make-hash payload))
+         (filepath (string-append %home "/" hash)))
+    (call-with-output-file filepath
+      (lambda (port)
+        (put-bytevector port payload))
+      #:binary #t)
+    (publish %configuration (pk filepath) '("c3b2://v1/message"))))
 
 ;;; web
 
@@ -129,7 +147,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
 (define-public (main args)
   (set! %configuration (cadr args))
   (set! %home (caddr args))
-  (pk %configuration %home)
   (format #t "Server running @ http://localhost:8080\n")
   (with-env (env-open* "wt" (list *feature-space*) "create,log=(enabled=true)")
+    (run-discovery %configuration)
     (run-server router)))