[gnunet] 05/17: Add draft support for indexing/publication. * fs.scm: - add a `<file-information>` type and associated functions (`wrap-file-information`, `unwrap-file-information`, and `make-file-information`); - add incomplete bindings to `GNUNET_FS_directory_scan_*` functions (`start-directory-scan`, `stop-directory-scan`, `directory-scanner-result`) - add `share-tree->file-information` - add `start-publish` and `stop-publish` * examples/publish.scm: a very simple and ugly `gnunet-publish` clone.

[Rémi Birot-Delrue]

remibd pushed a commit to branch master
in repository gnunet.

commit 8f48b792a2fea597b9def1c9e429d15902b33057
Author: RĂ©mi Birot-Delrue <address@hidden>
Date:   Tue Jul 21 13:03:07 2015 +0200

    Add draft support for indexing/publication.
    * fs.scm:
      - add a `<file-information>` type and associated functions
        (`wrap-file-information`, `unwrap-file-information`, and
        `make-file-information`);
      - add incomplete bindings to `GNUNET_FS_directory_scan_*` functions
        (`start-directory-scan`, `stop-directory-scan`, 
`directory-scanner-result`)
      - add `share-tree->file-information`
      - add `start-publish` and `stop-publish`
    * examples/publish.scm: a very simple and ugly `gnunet-publish` clone.
---
 examples/publish.scm |  111 ++++++++++++++++++++++++++++
 gnu/gnunet/fs.scm    |  196 ++++++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 300 insertions(+), 7 deletions(-)

diff --git a/examples/publish.scm b/examples/publish.scm
new file mode 100755
index 0000000..0979f73
--- /dev/null
+++ b/examples/publish.scm
@@ -0,0 +1,111 @@
+#!/usr/bin/guile \
+-e (@\ (gnunet-publish)\ main) -L . -s
+!#
+;;;; Copyright © 2015 Rémi Delrue <address@hidden>
+;;;; 
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;; 
+;;;; This program 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 General Public License for more details.
+;;;; 
+;;;; 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)
+  #:use-module (gnu gnunet common)
+  #:use-module (gnu gnunet fs)
+  #:use-module (gnu gnunet fs uri)
+  #:use-module (gnu gnunet fs progress-info)
+  #:use-module (gnu gnunet configuration)
+  #:use-module (gnu gnunet scheduler)
+  #: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 (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* (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)))))
+
+      ((#: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 (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)))
diff --git a/gnu/gnunet/fs.scm b/gnu/gnunet/fs.scm
index 2e71386..f297663 100644
--- a/gnu/gnunet/fs.scm
+++ b/gnu/gnunet/fs.scm
@@ -15,7 +15,10 @@
 ;;;; You should have received a copy of the GNU General Public License
 ;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
+;;+TODO: export <file-information>
 (define-module (gnu gnunet fs)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
   #:use-module (system foreign)
   #:use-module (gnu gnunet binding-utils)
   #:use-module (gnu gnunet common)
@@ -23,12 +26,23 @@
   #:use-module (gnu gnunet container metadata)
   #:use-module (gnu gnunet fs uri)
   #:use-module (gnu gnunet fs progress-info)
-  #:export (open-filesharing-service
+  #:use-module (gnu gnunet scheduler)
+  #:export (<file-information>
+            wrap-file-information
+            unwrap-file-information
+
+            open-filesharing-service
             start-search
             stop-search
             start-download
             stop-download
-            is-directory?))
+            start-publish
+            stop-publish
+            is-directory?
+            start-directory-scan
+            stop-directory-scan
+            directory-scanner-result
+            share-tree->file-information))
 
 
 (define struct-fs-handle
@@ -48,6 +62,34 @@
 (define default-max-parallel-requests (* 1024 10))
 
 
+(define-gnunet-fs %file-information-create-from-file
+  "GNUNET_FS_file_information_create_from_file" :
+    (list '* '* '* '* '* int '*) -> '*)
+
+(define-gnunet-fs %file-information-get-filename
+  "GNUNET_FS_file_information_get_filename" : '(*) -> '*)
+
+(define-gnunet-fs %file-information-is-directory
+  "GNUNET_FS_file_information_is_directory" : '(*) -> int)
+
+(define-gnunet-fs %file-information-destroy
+  "GNUNET_FS_file_information_destroy"      : '(* * *) -> void)
+
+(define-gnunet-fs %directory-scan-start
+  "GNUNET_FS_directory_scan_start"      : (list '* int '* '* '*) -> '*)
+
+(define-gnunet-fs %directory-scan-abort
+  "GNUNET_FS_directory_scan_abort"      : '(*) -> void)
+
+(define-gnunet-fs %directory-scan-get-result
+  "GNUNET_FS_directory_scan_get_result" : '(*) -> '*)
+
+(define-gnunet-fs %share-tree-trim!
+  "GNUNET_FS_share_tree_trim" : '(*) -> void)
+
+(define-gnunet-fs %share-tree-free
+  "GNUNET_FS_share_tree_free" : '(*) -> void)
+
 (define-gnunet-fs %search-start
   "GNUNET_FS_search_start" : (list '* '* uint32 unsigned-int '*) -> '*)
 
@@ -61,14 +103,135 @@
 (define-gnunet-fs %download-stop
   "GNUNET_FS_download_stop"  : (list '* int) -> void)
 
+(define-gnunet-fs %publish-start
+  "GNUNET_FS_publish_start"  : (list '* '* '* '* '* unsigned-int) -> '*)
+
+(define-gnunet-fs %publish-stop
+  "GNUNET_FS_publish_stop"   : (list '*) -> void)
+
 (define-gnunet-fs %test-for-directory
   "GNUNET_FS_meta_data_test_for_directory" : (list '*) -> int)
 
+(define-record-type <file-information>
+  (wrap-file-information pointer)
+  file-information?
+  (pointer unwrap-file-information))
+
+(define* (make-file-information filesharing-handle filename
+                                #:key keywords metadata (index? #t))
+  (when (string-null? filename)
+    (throw 'invalid-arg "make-file-information" filename))
+  (let ((%filename     (string->pointer* filename))
+        (%keywords-str (string->pointer* (keyword-list->string keywords)))
+        (%metadata     (if metadata (unwrap-metadata metadata) %null-pointer))
+        (%index?       (if index? gnunet-yes gnunet-no)))
+    (wrap-file-information (%file-information-create-from-file
+                             filesharing-handle %null-pointer %filename
+                             %keywords-str %metadata %index? %null-pointer))))
+
+(define (file-information-filename file-info)
+  (%file-information-get-filename (unwrap-file-information file-info)))
+
+(define (file-information-directory? file-info)
+  (%file-information-is-directory (unwrap-file-information file-info)))
+
+(define (file-information-destroy %file-info)
+  "Free a file-information structure.
+
+WARNING: must NEVER be called on a file-info that has been given to
+START-PUBLISH. In fact, you should probably not be using this function."
+  (%file-information-destroy %file-info %null-pointer %null-pointer))
+
+
+(define (directory-scanner-result filesharing-handle scanner)
+  "Returns the result of the scan as a pointer to a “share tree”.
+
+WARNING: the scanner is unusable after a call to DIRECTORY-SCANNER-RESULT (the
+associated memory is freed)."
+  (let ((res (%directory-scan-get-result scanner)))
+    (%share-tree-trim! res)
+    res))
+
+;; block options
+;; 
+;; this value must remain accessible for the C functions as long as
+;; the file-information that refers it are alive.
+(define *block-options*
+  (make-c-struct (list uint64 uint32 uint32 uint32) '(0 0 365 1)))
+
+(define (share-tree->file-information filesharing-handle share-tree index?)
+  "Transform a pointer to a “share-tree” to an instance of <file-information>.
+
+WARNING: the share-tree is unusable after a call to
+SHARE-TREE->FILE-INFORMATION (the associated memory is freed)."
+  (match (parse-c-struct share-tree
+                         (list '* '* '* '* '* '* '* '* '* int))
+    ((_ _ _ _ _ %metadata %ksk-uri %filename _ %is-directory)
+     (when (= gnunet-ok %is-directory)
+       (throw 'unimplemented "share-tree->file-information"
+              %directory-scan-get-result (list (pointer->string* %filename))))
+     (let ((%fi (%file-information-create-from-file
+                 filesharing-handle %null-pointer %filename %ksk-uri %metadata
+                 (bool->int index?) *block-options*)))
+       (when (eq? %null-pointer %fi)
+         (throw 'invalid-result "share-tree->file-information"
+                "%file-information-create-from-file"
+                (list filesharing-handle %filename %ksk-uri
+                      %metadata (bool->int index?))))
+       (%share-tree-free share-tree)
+       (wrap-file-information %fi)))))
+
+(define directory-scanner-progress-update-reason-alist
+  '((0 . #:file-start)
+    (1 . #:file-ignored)
+    (2 . #:all-counted)
+    (3 . #:extract-finished)
+    (4 . #:finished)
+    (5 . #:internal-error)))
+
+(define (number->reason n)
+  (assoc-ref directory-scanner-progress-update-reason-alist n)) 
+
+(define (scan-progress-callback->pointer thunk)
+  (procedure->pointer void (lambda (_ %filename %is-directory %reason)
+                             (thunk (pointer->string* %filename)
+                                    (int->bool        %is-directory)
+                                    (number->reason   %reason)))
+                      (list '* '* int unsigned-int)))
+
+(define* (start-directory-scan filename progress-cb
+                               #:key disable-extractor?)
+  "Start a directory scan on FILENAME, extracting metadata (unless
+DISABLE-EXTRACTOR? is #t) and calling PROGRESS-CB each time there’s an update.
+
+PROGRESS-CB must be a procedure of three arguments:
+ – the filename of the file currently being scanned;
+ – a boolean, true if the current file is in fact a directory;
+ – the reason of the update, a keyword from the set:
+     #:file-start #:file-ignored #:all-counted
+     #:extract-finished #:finished #:internal-error"
+  (when (string-null? filename)
+    (throw 'invalid-arg "start-directory-scan" filename))
+  (let ((%filename           (string->pointer filename))
+        (%disable-extractor? (if disable-extractor? gnunet-yes gnunet-no))
+        (%callback           (scan-progress-callback->pointer progress-cb)))
+    (%directory-scan-start %filename %disable-extractor? %null-pointer
+                           %callback %null-pointer)))
+
+(define (stop-directory-scan scanner)
+  "Abort a scan.
+
+WARNING: must NEVER be called inside the “progress callback” of the scanner;
+instead, use ADD-TASK! or SET-NEXT-TASK! to schedule its call outside the
+callback."
+  (%directory-scan-abort scanner))
+
+
 (define (progress-callback->pointer thunk)
-    (procedure->pointer '* (lambda (cls info)
-                            (thunk info)
-                            %null-pointer)
-                       (list '* '*)))
+  (procedure->pointer '* (lambda (cls info)
+                           (thunk info)
+                           %null-pointer)
+                      (list '* '*)))
 
 ;; This is a temporary replacement for the actual GNUNET_FS_start function that
 ;; is variadic and, hence, not currently handlable by Guile’s Dynamic FFI.
@@ -127,8 +290,27 @@ filesharing service (a search is started, a download is 
completed, etc.)."
                    (uri-file-size uri) 0 0 %null-pointer %null-pointer))
 
 (define* (stop-download download-handle #:key delete-incomplete?)
-  (%download-stop download-handle (if delete-incomplete? 1 0)))
+  (%download-stop download-handle (if delete-incomplete? gnunet-yes 
gnunet-no)))
+
+(define* (start-publish filesharing-handle file-information
+                        #:key namespace namespace-identifier
+                        update-identifier simulate?)
+  "Publish a file or a directory. If SIMULATE? is #t, no data will be stored in
+the datastore."
+  (let ((%namespace    (or namespace %null-pointer))
+        (%namespace-id (or namespace-identifier %null-pointer))
+        (%update-id    (or update-identifier %null-pointer))
+        (%option       (if simulate? gnunet-yes gnunet-no)))
+    (%publish-start filesharing-handle file-information
+                    %namespace %namespace-id %update-id %option)))
+
+(define (stop-publish publish-handle)
+  "Stops a publication.
 
+WARNING: must NEVER be called inside the “progress callback” of the Filesharing
+system; instead, use ADD-TASK! or SET-NEXT-TASK! to schedule its call outside
+the callback."
+  (%publish-stop publish-handle))
 
 ;;+TODO: should be (is-directory? search-result) or
 ;;       (result-is-directory? result)