[gnunet] 07/17: Small bug fixes and add publishing in namespaces for examples/publish.scm * common.scm: add `gnunet-id-ffi` (FFI for libgnunetidentity). * identity.scm: replace `define-gnunet-fs` with `define-gnunet-id`. * fs.scm: corrects a bug in `start-publish` (gave `GNUNET_FS_publish_start` a pointer to the ego in place of a pointer to its private key). * examples/publish.scm: add handling of namespaces and replace simple global variables with parameters.

[Rémi Birot-Delrue]

remibd pushed a commit to branch master
in repository gnunet.

commit ac1479fa17d520282c46238293fc637994baaf3d
Author: RĂ©mi Birot-Delrue <address@hidden>
Date:   Fri Jul 24 21:31:42 2015 +0200

    Small bug fixes and add publishing in namespaces for examples/publish.scm
    * common.scm: add `gnunet-id-ffi` (FFI for libgnunetidentity).
    * identity.scm: replace `define-gnunet-fs` with `define-gnunet-id`.
    * fs.scm: corrects a bug in `start-publish` (gave `GNUNET_FS_publish_start` 
a
              pointer to the ego in place of a pointer to its private key).
    * examples/publish.scm: add handling of namespaces and replace simple global
                            variables with parameters.
---
 examples/publish.scm    |  196 +++++++++++++++++++++++++++++------------------
 gnu/gnunet/common.scm   |    7 +-
 gnu/gnunet/fs.scm       |    8 +-
 gnu/gnunet/identity.scm |   30 +++++---
 4 files changed, 148 insertions(+), 93 deletions(-)

diff --git a/examples/publish.scm b/examples/publish.scm
index 0979f73..1dd2192 100755
--- a/examples/publish.scm
+++ b/examples/publish.scm
@@ -15,7 +15,7 @@
 ;;;; 
 ;;;; You should have received a copy of the GNU General Public License
 ;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
-
+
 (define-module (gnunet-publish)
   #:use-module (ice-9 match)
   #:use-module (system foreign)
@@ -25,87 +25,131 @@
   #:use-module (gnu gnunet fs progress-info)
   #:use-module (gnu gnunet configuration)
   #:use-module (gnu gnunet scheduler)
+  #:use-module (gnu gnunet identity)
   #:export     (main))
 
 (define config-file "~/.gnunet/gnunet.conf")
 
-(define *fs-handle* #f)
-(define *publish-handle* #f)
-(define *dir-scanner* #f)
-(define *kill-task* #f)
+(define-syntax-rule (define-parameter name)
+  (define name (make-parameter #f)))
 
-
-(define (progress-cb %info)
-  (let ((status (progress-info-status %info)))
-    (cond ((equal? status '(#:publish #:start))
-          (match (parse-c-progress-info %info)
-            (((%context %file-info cctx pctx %filename . _) _ _)
-             (simple-format #t "Indexing `~a'.\n"
-                            (pointer->string %filename)))))
-         ((equal? status '(#:publish #:completed))
-          (match (parse-c-progress-info %info)
-            (((%context %file-info cctx pctx %filename _ _ _ _ _
-                        (chk-uri)) _ _)
-             (simple-format #t "Indexed `~a'.\n~a"
-                            (pointer->string %filename)
-                            (uri->string (wrap-uri chk-uri)))))
-          (when *kill-task* (cancel-task! *kill-task*))
-          (set! *kill-task*
-            (set-next-task! (lambda (_)
-                              (stop-publish *publish-handle*)))))
-         (else
-          (simple-format #t "Got status ~a\n" status)))))
+(define *index?* #t)
+(define *simulate?* #t)
 
-(define* (start-publish-file filesharing-handle filename
-                             #:key simulate? (index? #t))
-  (define (scan-progress-cb filename directory? reason)
-    (case reason
-      ((#:finished)
-       (let* ((%share-tree #f)
-             (file-info #f))
-        (set! %share-tree (directory-scanner-result filesharing-handle
-                                                    *dir-scanner*))
-        (set! *dir-scanner* #f)
-        (set! file-info (share-tree->file-information filesharing-handle
-                                                      %share-tree index?))
-        (set! %share-tree #f)
-        (set! *publish-handle*
-          (start-publish filesharing-handle (unwrap-file-information file-info)
-                         #:simulate? simulate?))
-        (when *kill-task* (cancel-task! *kill-task*))
-        (set! *kill-task*
-          (add-task! (lambda (_)
-                       (stop-publish *publish-handle*)
-                       (simple-format #t
-                                      "Stopped publication.\n"))
-                     #:delay (* 5 1000 1000)))))
+;; The kill task is the task that will end the program, either because it has
+;; reached a timeout or because it has come to a normal or abnormal ending.
+(define-parameter kill-task)
 
-      ((#:internal-error)
-       (simple-format #t "scan-progress-cb: internal error.\n")
-       (when *kill-task* (cancel-task! *kill-task*))
-       (set! *kill-task*
-        (set-next-task! (lambda (_)
-                          (stop-directory-scan *dir-scanner*)
-                          (simple-format #t
-                                         "Stopped directory scanner.\n")))))))
-  (set! *dir-scanner* (start-directory-scan filename scan-progress-cb))
-  (when *kill-task* (cancel-task! *kill-task*))
-  (set! *kill-task*
-    (add-task! (lambda (_)
-                (simple-format #t "stopping directory scanner (2) ~a\n"
-                               *dir-scanner*)
-                (stop-directory-scan *dir-scanner*)
-                (simple-format #t
-                               "Stopped directory scanner.\n"))
-              #:delay (* 5 1000 1000))))
-    
+(define-parameter binary-name)
+(define-parameter file-name)
+(define-parameter namespace-name)
+(define-parameter namespace-ego)
+(define-parameter file-identifier)
 
+(define-parameter config-handle)
+(define-parameter fs-handle)
+(define-parameter publish-handle)
+(define-parameter dir-scanner)
+
 (define (main args)
-  (let ((config (load-configuration config-file)))
-    (define (first-task _)
-      (match args
-       ((binary-name filename)
-        (set! *fs-handle* (open-filesharing-service config binary-name
-                                                    progress-cb))
-        (start-publish-file *fs-handle* filename))))
-    (call-with-scheduler config first-task)))
+  "Entry point of the program."
+  (config-handle (load-configuration config-file))
+  (call-with-scheduler (config-handle) (first-task args)))
+
+(define (first-task args)
+  "The initial task: parse the command line and call START-PUBLISH-FILE."
+  (lambda (_)
+    (match args
+      ((binary file namespace identifier)
+       (binary-name binary)
+       (file-name file)
+       (namespace-name namespace)
+       (file-identifier identifier)
+       (start-ego-lookup (config-handle) (namespace-name) ego-lookup-callback))
+      ((binary file)
+       (binary-name binary)
+       (file-name file)
+       (set-next-task! start-publish-file))
+      ((binary . _)
+       (simple-format #t "Usage: ~a filename [namespace identifier]\n"
+                     binary)))))
+
+(define (ego-lookup-callback ego)
+  "The first callback, called once by the ego lookup tasks. Set NAMESPACE-EGO 
to
+the right ego, then continue with START-PUBLISH-FILE."
+  (cond (ego (namespace-ego ego)
+            (set-next-task! start-publish-file))
+       (else (simple-format #t "Error: no ego named ~a has been found!\n"
+                            (namespace-name)))))
+
+(define (start-publish-file _)
+  "The second task: open the filesharing service and start a directory scan on
+FILENAME."
+  (fs-handle   (open-filesharing-service (config-handle) (binary-name)
+                                        progress-callback))
+  (dir-scanner (start-directory-scan (file-name) scan-progress-callback))
+  ;; We started a directory scan, need to add a timeout just in case.
+  (kill-task   (add-task! (lambda (_)
+                         (stop-directory-scan (dir-scanner))
+                         (simple-format #t "Stopped directory scanner.\n"))
+                       #:delay (* 5 1000 1000))))
+
+(define (scan-progress-callback filename directory? reason)
+  "The second callback, called repeatedly by the directory scanning tasks: wait
+until the scan is finished, interpret its results and start the publication."
+  (case reason
+    ((#:finished)
+     (let* ((%share-tree (directory-scanner-result (fs-handle) (dir-scanner)))
+           (file-info   (share-tree->file-information (fs-handle) %share-tree
+                                                      *index?*)))
+
+       (publish-handle
+       (if (and (namespace-name) (namespace-ego))
+           (start-publish (fs-handle)
+                          (unwrap-file-information file-info)
+                          #:simulate?  *simulate?*
+                          #:namespace  (namespace-ego)
+                          #:identifier (file-identifier))
+           (start-publish (fs-handle)
+                          (unwrap-file-information file-info)
+                          #:simulate? *simulate?*)))
+
+       ;; now that the scan is finished, we can cancel the previous timeout and
+       ;; set a new one that will end the publication
+       (cancel-task! (kill-task))
+       (kill-task (add-task! (lambda (_)
+                              (stop-publish (publish-handle))
+                              (display "Stopped publication.\n"))
+                            #:delay (* 5 1000 1000)))))
+    ((#:internal-error)
+     (display "scan-progress-callback: internal error.\n")
+     ;; there’s an error, we must execute the killing task right now
+     (cancel-task! (kill-task))
+     (kill-task (set-next-task! (lambda (_)
+                                 (stop-directory-scan (dir-scanner))
+                                 (display "Stopped directory scanner.\n")))))))
+
+(define (progress-callback %info)
+  "The third callback, called repeteadly by the publishing tasks once the
+publication is engaged: when the publication starts, print a little something,
+and when it’s complete print the published file’s URI and stop the 
publication."
+  (let ((status (progress-info-status %info)))
+    (case (cadr status) ; status is of the form (#:publish <something>)
+      ((#:start)
+       (match (parse-c-progress-info %info)
+        (((%context %file-info cctx pctx %filename . _) _ _)
+         (simple-format #t "Publishing `~a'.\n"
+                        (pointer->string %filename)))))
+      ((#:completed)
+       (match (parse-c-progress-info %info)
+        (((%context %file-info cctx pctx %filename _ _ _ _ _ (%chk-uri)) _ _)
+         (simple-format #t "Published `~a'.\n~a\n" (pointer->string %filename)
+                        (uri->string (wrap-uri %chk-uri)))))
+       ;; We must avoid calling `stop-publish` inside the progress-callback, as
+       ;; it frees the publish-handle that might still be used just after this
+       ;; call to progress-callback ends. Therefore, we continue with a new 
kill
+       ;; task.
+       (cancel-task! (kill-task))
+       (kill-task (set-next-task! (lambda (_) (stop-publish 
(publish-handle))))))
+      (else
+       (simple-format #t "Got status ~a\n" status)))))
diff --git a/gnu/gnunet/common.scm b/gnu/gnunet/common.scm
index d5a56b6..7557d4a 100644
--- a/gnu/gnunet/common.scm
+++ b/gnu/gnunet/common.scm
@@ -41,6 +41,7 @@
             gnunet-fs-ffi
             define-gnunet
             define-gnunet-fs
+            define-gnunet-id
 
             %make-blob-pointer
             %malloc
@@ -73,8 +74,9 @@
 (define gnunet-yes           1)
 (define gnunet-no            0)
 
-(define gnunet-util-ffi (dynamic-link "libgnunetutil"))
-(define gnunet-fs-ffi   (dynamic-link "libgnunetfs"))
+(define gnunet-util-ffi     (dynamic-link "libgnunetutil"))
+(define gnunet-fs-ffi       (dynamic-link "libgnunetfs"))
+(define gnunet-identity-ffi (dynamic-link "libgnunetidentity"))
 
 
 (define-syntax define-foreign-definer
@@ -88,6 +90,7 @@
 
 (define-foreign-definer define-gnunet    gnunet-util-ffi)
 (define-foreign-definer define-gnunet-fs gnunet-fs-ffi)
+(define-foreign-definer define-gnunet-id gnunet-identity-ffi)
 
 (define-gnunet %xfree   "GNUNET_xfree_"   : (list '* '* int)     -> void)
 (define-gnunet %xmalloc "GNUNET_xmalloc_" : (list size_t '* int) -> '*)
diff --git a/gnu/gnunet/fs.scm b/gnu/gnunet/fs.scm
index 010d166..517b554 100644
--- a/gnu/gnunet/fs.scm
+++ b/gnu/gnunet/fs.scm
@@ -310,13 +310,13 @@ identify the publication in place of the extracted 
keywords)."
   ;; update-identifier has no sense if namespace is #f
   (when (and update-identifier (not namespace))
     (throw 'invalid-arg "start-publish" namespace update-identifier))
-  (let ((%namespace  (if namespace  (unwrap-ego namespace) %null-pointer))
+  (let ((%priv       (if namespace  (ego-private-key namespace)  
%null-pointer))
         (%identifier (if identifier (string->pointer identifier) 
%null-pointer))
         (%update-id  (if update-identifier (string->pointer update-identifier)
                          %null-pointer))
-        (%option     (if simulate?  gnunet-yes gnunet-no)))
-    (%publish-start filesharing-handle file-information
-                    %namespace %namespace-id %update-id %option)))
+        (%simulate?  (if simulate?  gnunet-yes gnunet-no)))
+    (%publish-start filesharing-handle file-information %priv %identifier
+                    %update-id %simulate?)))
 
 (define (stop-publish publish-handle)
   "Stops a publication.
diff --git a/gnu/gnunet/identity.scm b/gnu/gnunet/identity.scm
index aa80106..d05dd01 100644
--- a/gnu/gnunet/identity.scm
+++ b/gnu/gnunet/identity.scm
@@ -17,6 +17,7 @@
 
 (define-module (gnu gnunet identity)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (gnu gnunet common)
@@ -39,31 +40,37 @@
 
 
 (define-record-type <ego>
-  ego?
   (wrap-ego pointer)
+  ego?
   (pointer unwrap-ego))
 
+(set-record-type-printer! <ego>
+  (lambda (ego port)
+    (write-char #\< port)
+    (display "ego")
+    (display (unwrap-ego ego) port)
+    (write-char #\> port)))
 
-(define-gnunet %get-private-key
+(define-gnunet-id %get-private-key
   "GNUNET_IDENTITY_ego_get_private_key" : '(*)   -> '*)
-(define-gnunet %get-public-key
+(define-gnunet-id %get-public-key
   "GNUNET_IDENTITY_ego_get_public_key"  : '(* *) -> void)
 
-(define-gnunet %identity-connect
+(define-gnunet-id %identity-connect
   "GNUNET_IDENTITY_connect"    : '(* * *) -> '*)
-(define-gnunet %identity-disconnect
+(define-gnunet-id %identity-disconnect
   "GNUNET_IDENTITY_disconnect" : '(*)     -> void)
 
-(define-gnunet %identity-get
+(define-gnunet-id %identity-get
   "GNUNET_IDENTITY_get"      : '(* * * *)   -> '*)
-(define-gnunet %identity-set!
+(define-gnunet-id %identity-set!
   "GNUNET_IDENTITY_set"      : '(* * * * *) -> '*)
 
-(define-gnunet %cancel! "GNUNET_IDENTITY_cancel" : '(*) -> void)
+(define-gnunet-id %cancel! "GNUNET_IDENTITY_cancel" : '(*) -> void)
 
-(define-gnunet %ego-lookup
+(define-gnunet-id %ego-lookup
   "GNUNET_IDENTITY_ego_lookup"        : '(* * * *) -> '*)
-(define-gnunet %ego-lookup-cancel!
+(define-gnunet-id %ego-lookup-cancel!
   "GNUNET_IDENTITY_ego_lookup_cancel" : '(*)       -> void)
 
 (define (ego-private-key ego)
@@ -151,7 +158,8 @@ already transmitted to the service."
   "Lookup an ego by NAME.
 
 Return a handle to the lookup that can be cancelled with CANCEL-EGO-LOOKUP!"
-  (when (string-null? name)
+  (when (or (not (string? name))
+            (string-null? name))
     (throw 'invalid-arg "lookup-ego" name))
   (%ego-lookup (unwrap-configuration config) (string->pointer name)
               (ego-callback->pointer ego-callback) %null-pointer))