[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet] 16/17: Add a record type for GNUNET_FS_ProgressInfo and a few t
|
From: |
Rémi Birot-Delrue |
|
Subject: |
[gnunet] 16/17: Add a record type for GNUNET_FS_ProgressInfo and a few tests. * progress-info.scm: add a record type for `GNUNET_FS_ProgressInfo` and alter `parse-c-progress-info` to handle it. * fs.scm: - correct `make-file-information`; - deprecate directory-scan (too many bugs to fix, `make-file-information will` do for now); - replace `*block-options*` with `make-block-options`; - update `procedure->*` functions to use `parse-c-progress-info`. * examples/*.scm: follow modifications on fs.scm. * tests/progress-info.scm: add a fake progress-info to test `parse-c-progress-info`. * tests/fs.scm: add a small test for `make-file-information`. |
|
Date: |
Wed, 12 Aug 2015 18:24:42 +0000 |
remibd pushed a commit to branch master
in repository gnunet.
commit cd20d8d6d06043d8dff49d8b421e1c9cf1c85c2e
Author: RĂ©mi Birot-Delrue <address@hidden>
Date: Wed Aug 12 19:31:27 2015 +0200
Add a record type for GNUNET_FS_ProgressInfo and a few tests.
* progress-info.scm: add a record type for `GNUNET_FS_ProgressInfo` and
alter
`parse-c-progress-info` to handle it.
* fs.scm: - correct `make-file-information`;
- deprecate directory-scan (too many bugs to fix,
`make-file-information will` do for now);
- replace `*block-options*` with `make-block-options`;
- update `procedure->*` functions to use `parse-c-progress-info`.
* examples/*.scm: follow modifications on fs.scm.
* tests/progress-info.scm: add a fake progress-info to test
`parse-c-progress-info`.
* tests/fs.scm: add a small test for `make-file-information`.
---
examples/download.scm | 18 +--
examples/identity.scm | 2 +-
examples/publish.scm | 297 +++++++++++++++++++++------------------
examples/search-ns.scm | 50 +++----
examples/search.scm | 82 ++++++------
gnu/gnunet/fs.scm | 85 ++++++++----
gnu/gnunet/fs/progress-info.scm | 175 ++++++++++++++++++++++-
tests/fs.scm | 39 +++++
tests/progress-info.scm | 33 ++++-
9 files changed, 529 insertions(+), 252 deletions(-)
diff --git a/examples/download.scm b/examples/download.scm
index 6c7a283..93c3681 100755
--- a/examples/download.scm
+++ b/examples/download.scm
@@ -56,20 +56,14 @@ the download."
(stop-download *dl-handle*))
#:delay (time-rel #:seconds 5))))))))
-(define (progress-cb %info)
- (let ((status (progress-info-status %info)))
+(define (progress-cb info status)
+ (let ((filename (pinfo-download-filename info)))
(cond ((equal? status '(#:download #:start))
- (match (parse-c-progress-info %info)
- (((%context cctx pctx sctx %uri %filename . _) . _)
- (simple-format #t "Starting download `~a'.\n"
- (pointer->string %filename)))))
+ (simple-format #t "Starting download `~a'.\n" filename))
((equal? status '(#:download #:completed))
- (match (parse-c-progress-info %info)
- (((%context cctx pctx sctx %uri %filename . _) . _)
- (simple-format #t "Downloaded `~a'.\n"
- (pointer->string %filename))))
+ (simple-format #t "Downloaded `~a'.\n" filename)
;; the download is complete, we want to execute the kill-task now
(schedule-shutdown!))
((equal? status '(#:download #:stopped))
- (set-next-task! (lambda (_)
- (close-filesharing-service! *fs-handle*)))))))
+ (add-task! (lambda (_)
+ (close-filesharing-service! *fs-handle*)))))))
diff --git a/examples/identity.scm b/examples/identity.scm
index 7b7298f..4231543 100755
--- a/examples/identity.scm
+++ b/examples/identity.scm
@@ -38,7 +38,7 @@
(simple-format #t "~a - ~a\n" name (ecdsa-public-key->string key))))
((not ego)
(cancel-task! *kill-task*)
- (set-next-task! shutdown-task))))
+ (add-task! shutdown-task))))
(define (first-task _)
(set! *handle* (open-identity-service *config* print-ego))
diff --git a/examples/publish.scm b/examples/publish.scm
index cea056e..25b0aa4 100755
--- a/examples/publish.scm
+++ b/examples/publish.scm
@@ -18,154 +18,181 @@
(define-module (gnunet-publish)
#:use-module (ice-9 match)
+ #:use-module (ice-9 getopt-long)
+ #:use-module (rnrs bytevectors)
#:use-module (system foreign)
+ #:use-module (gnu gnunet binding-utils)
#: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)
#:use-module (gnu gnunet identity)
- #:export (main))
+ #:use-module (gnu gnunet container metadata)
+ #:use-module (gnu gnunet fs)
+ #:use-module (gnu gnunet fs uri)
+ #:use-module (gnu gnunet fs progress-info)
+ #:export (main))
+
+;;; foreign utilities
+
+(define-gnunet %relative-time-to-string
+ "GNUNET_STRINGS_relative_time_to_string" : (list time-relative int) -> '*)
+
+(define* (time-relative->string t #:optional (round? #t))
+ (let ((s (%relative-time-to-string t (bool->int round?))))
+ (when (eq? %null-pointer s)
+ (throw 'invalid-result "time-relative->string" "%relative-time-to-string"
+ s (list t (bool->int round?))))
+ (pointer->string s)))
-(define *index?* #t)
-(define *simulate?* #f)
+;;; parameters
+
+(define %options
+ '((simulate (single-char #\s) (value #f))
+ (pseudonym (single-char #\P) (value #t))
+ (this-id (single-char #\t) (value #t))
+ (update-id (single-char #\N) (value #t))))
+
+(define %block-options
+ (make-block-options (time-relative->absolute (time-rel #:days 365)) 0))
(define *config-file* "~/.gnunet/gnunet.conf")
-(define *config* #f)
+(define *simulate?* #f)
+(define *index?* #t)
+(define *pseudonym* #f) ; a string
+(define *ego* #f) ; an instance of <ego>
+(define *path* #f)
+(define *id* #f) ; file identifier
+(define *update-id* #f) ; update file identifier
+(define *args* #f) ; ordinary arguments to the command line
-(define *binary-name* #f)
-(define *filename* #f)
+;;; handles
-;;+TODO: add kill tasks everywhere!
-;;+TODO: each continuation shalt check its indirect arguments.
-;; 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 *kill-task* #f)
+(define *config* #f)
+(define *identity* #f)
+(define *fs* #f)
+(define *publish* #f)
-(define *namespace-name* #f)
-(define *namespace-ego* #f)
+;;; cleaning
-(define *file-identifier* #f)
+(define (do-stop-task _)
+ "We are finished with the publishing operation, clean up all FS state."
+ (when *identity*
+ (close-identity-service *identity*)
+ (set! *identity* #f))
+ (cond (*publish*
+ (stop-publish *publish*)
+ (set! *publish* #f))
+ (*fs*
+ (close-filesharing-service! *fs*)
+ (set! *fs* #f))))
-(define *fs-handle* #f)
-(define *identity-handle* #f)
-(define *publish-handle* #f)
-(define *dir-scanner* #f)
+;;; callbacks
-
-(define (main args)
- "Entry point of the program."
- (set! *config* (load-configuration *config-file*))
- (call-with-scheduler *config* (first-task args)))
-
-(define (first-task args)
- "The initial task: parse the command line and either find the
-demanded ego or call IDENTITY-CONTINUATION."
- (lambda (_)
- (match args
- ((binary filename namespace identifier)
- (set! *binary-name* binary)
- (set! *filename* filename)
- (set! *namespace-name* namespace)
- (set! *file-identifier* identifier)
- (set! *identity-handle*
- (open-identity-service *config* identity-callback))
- (set! *kill-task*
- (add-task! (lambda (_)
- (close-identity-service *identity-handle*))
- #:delay (time-rel #:seconds 5))))
- ((binary file-name)
- (set! *binary-name* binary)
- (set! *filename* file-name)
- (identity-continuation))
- ((binary . _)
- (simple-format #t "Usage: ~a filename [namespace identifier]\n"
- binary)
- (schedule-shutdown!)))))
-
-(define (identity-callback ego name)
- "The first callback, called repeatedly by the identity service. Set
-NAMESPACE-EGO to the right ego, then continue with
-IDENTITY-CONTINUATION."
- (cond ((and ego name (string= *namespace-name* name))
- (set! *namespace-ego* ego))
- ((and (not ego) (not name)) ; last call
- (cancel-task! *kill-task*)
- (identity-continuation))))
+(define (progress-cb info status)
+ "Called by FS client to give information about the progress of an operation."
+ (match status
+ ((#:publish #:start) *unspecified*)
+ ((#:publish (or #:progress #:progress-directory))
+ (simple-format #t "Publishing `~a' at ~a/~a (~a remaining)\n"
+ (pinfo-publish-filename info)
+ (pinfo-publish-completed info)
+ (pinfo-publish-size info)
+ (time-relative->string (pinfo-publish-eta info))))
+ ((#:publish #:error)
+ (simple-format #t "Error publishing: ~a\n" (pinfo-publish-message info))
+ (schedule-shutdown!))
+ ((#:publish #:completed)
+ (simple-format #t "Publishing `~a' done.\nURI is `~a'.\n"
+ (pinfo-publish-filename info)
+ (uri->string (pinfo-publish-chk-uri info)))
+ (when (pinfo-publish-sks-uri info)
+ (simple-format #t "Namespace URI is `~a'.\n"
+ (uri->string (pinfo-publish-sks-uri info))))
+ (schedule-shutdown!))
+ ((#:publish #:stopped)
+ (add-task! do-stop-task))))
+
+(define (meta-printer name type format mime-type data)
+ "Print metadata entries (except binary metadata and the filename).
+
+NAME: name of the plugin that generated the meta data;
+TYPE: type of the meta data;
+FORMAT: format of data;
+MIME-TYPE: mime type of data;
+DATA: bytevector containing the value of the metadata."
+ (define (textual? fmt) (or (eq? #:utf8 fmt)
+ (eq? #:c-string fmt)))
+ (when (and (textual? format)
+ (not (eq? #:original-filename type)))
+ (simple-format #t "\t~a - ~a\n" type (utf8->string data))))
(define (identity-continuation)
- "The second task: open the filesharing service and start a directory
-scan on *FILENAME*."
- (cond
- ((or (and *namespace-name* *namespace-ego*)
- (and (not *namespace-name*) (not *namespace-ego*)))
- (set! *fs-handle* (open-filesharing-service *config* *binary-name*
- progress-callback))
- (set! *dir-scanner* (start-directory-scan *filename* dirscan-callback))
- (set! *kill-task* (add-task! (lambda (_)
- (display "Stopping directory scan
(unexpected)\n")
- (stop-directory-scan *dir-scanner*)
- (close-filesharing-service! *fs-handle*))
- #:delay (time-rel #:seconds 5))))
- (else
- (simple-format #t "Error: no ego named ~a has been found!\n"
- *namespace-name*)
- ;; there’s an error, we must execute the killing task right now
- (schedule-shutdown!))))
-
-(define (dirscan-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 by calling DIRSCAN-CONTINUATION."
- (case reason
- ((#:finished)
- (cancel-task! *kill-task*)
- (let* ((%share-tree (directory-scanner-result *fs-handle* *dir-scanner*))
- (file-info (share-tree->file-information *fs-handle* %share-tree
- *index?*)))
- (dirscan-continuation file-info)))
- ((#:internal-error)
- (display "dirscan-callback: internal error.\n")
- (schedule-shutdown!))))
-
-(define (dirscan-continuation file-info)
- "Start the publication of FILE-INFO."
- (set! *publish-handle*
- (start-publish *fs-handle* file-info
- #:namespace *namespace-ego*
- #:identifier *file-identifier*
- #:simulate? *simulate?*))
- (set! *kill-task* (add-task! (lambda (_)
- (display "Stopping publication (unexpected)\n")
- (stop-publish *publish-handle*))
- #:delay (time-rel #:seconds 5))))
-
-(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)
- (cancel-task! *kill-task*)
- (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.
- (set! *kill-task*
- (set-next-task! (lambda (_)
- (display "Stopping publication\n")
- (stop-publish *publish-handle*)))))
- ((#:stopped)
- (display "Publication stopped\n")
- (set-next-task! (lambda (_)
- (close-filesharing-service! *fs-handle*)))))))
+ "Continuation proceeding with initialization after identity
+subsystem has been initialized."
+ (cond ((and *pseudonym* (not *ego*))
+ (simple-format (current-error-port)
+ "Selected pseudonym `~a' unknown.\n" *pseudonym*)
+ (schedule-shutdown!))
+ (else
+ (let ((info (make-file-information *fs* *path* %block-options
+ #:index? *index?*)))
+ (cond ((not info)
+ (simple-format (current-error-port)
+ "Failed to access `~a'.\n" *path*)
+ (schedule-shutdown!))
+ (else
+ (catch 'invalid-result
+ (lambda ()
+ (set! *publish*
+ (start-publish *fs* info #:namespace *ego*
+ #:identifier *id*
+ #:update-identifier *update-id*
+ #:simulate? *simulate?*)))
+ (lambda ()
+ (display "Could not start publishing.\n"
+ (current-error-port))
+ (schedule-shutdown!)))))))))
+
+(define (identity-cb ego name)
+ "Function called by identity service with known pseudonyms."
+ (cond ((not ego) (identity-continuation))
+ ((and name (string=? *pseudonym* name))
+ (set! *ego* ego))))
+
+(define (first-task _)
+ "Main function that will be run by the scheduler."
+ (let ((err (current-error-port)))
+ (cond
+ ((or (not *args*) (null? *args*) (> (length *args*) 1))
+ (display "Usage: examples/gnunet-publish.scm [options] filename\n" err))
+ ((and *pseudonym* (not *id*))
+ (display "Option `-t' is required when using option `-P'.\n" err))
+ ((and (not *pseudonym*) *id*)
+ (display "Option `-t' makes no sense without option `-P'.\n" err))
+ ((and (not *id*) *update-id*)
+ (display "Option `-N' makes no sense without option `-P'.\n" err))
+ (else
+ (set! *path* (car *args*))
+ (set! *fs* (open-filesharing-service *config* "gnunet-publish"
+ progress-cb))
+ (add-task! do-stop-task #:delay (time-rel #:seconds 5))
+ (if *pseudonym*
+ (catch 'invalid-result
+ (lambda ()
+ (set! *identity* (open-identity-service *config* identity-cb)))
+ (lambda ()
+ (display "Could not connect to the identity service.\n"
+ (current-error-port))))
+ (identity-continuation))))))
+
+(define (main args)
+ "The main function to publish content to GNUnet."
+ (setup-log "publish.scm" #:debug)
+ (set! *config* (load-configuration "~/.gnunet/gnunet.conf"))
+ (let* ((options (getopt-long args %options)))
+ (set! *simulate?* (option-ref options 'simulate #f))
+ (set! *pseudonym* (option-ref options 'pseudonym #f))
+ (set! *id* (option-ref options 'this-id #f))
+ (set! *update-id* (option-ref options 'update-id #f))
+ (set! *args* (option-ref options '() #f)))
+ (call-with-scheduler *config* first-task))
diff --git a/examples/search-ns.scm b/examples/search-ns.scm
index 60efc83..e90f1bb 100755
--- a/examples/search-ns.scm
+++ b/examples/search-ns.scm
@@ -78,30 +78,26 @@
#:delay (time-rel #:seconds 5)))
(simple-format #t "Searching ~a\n" (uri->string *uri*)))))
-(define (progress-callback %info)
- (let ((status (progress-info-status %info)))
- (when (equal? '(#:search #:result) status)
- (match (parse-c-progress-info %info)
- (((context cctx pctx %query duration anonymity
- (%metadata %uri %result applicability-rank)) _ _)
- (let* ((result-uri (uri->string (wrap-uri %uri)))
- (metadata (wrap-metadata %metadata))
- (result-directory? (is-directory? metadata))
- (result-filename (metadata-ref metadata #:original-filename)))
- (cond ((and result-directory?
- (string-null? result-filename))
- (simple-format
- #t "gnunet-download -o \"collection.gnd\" -R ~a\n"
- result-uri))
- (result-directory?
- (simple-format #t
- "gnunet-download -o \"~a.gnd\" -R ~a\n"
- result-filename result-uri))
- ((string-null? result-filename)
- (simple-format #t "gnunet-download ~a\n" result-uri))
- (else
- (simple-format #t "gnunet-download -o \"~a\" ~a\n"
- result-filename result-uri)))))))
- (when (equal? '(#:search #:stopped) status)
- (set-next-task!
- (lambda (_) (close-filesharing-service! *fs-handle*))))))
+(define (progress-callback info status)
+ (when (equal? '(#:search #:result) status)
+ (let* ((result-uri (uri->string (pinfo-search-uri info)))
+ (metadata (pinfo-search-metadata info))
+ (result-directory? (is-directory? metadata))
+ (result-filename (metadata-ref metadata #:original-filename)))
+ (cond ((and result-directory?
+ (string-null? result-filename))
+ (simple-format
+ #t "gnunet-download -o \"collection.gnd\" -R ~a\n"
+ result-uri))
+ (result-directory?
+ (simple-format #t
+ "gnunet-download -o \"~a.gnd\" -R ~a\n"
+ result-filename result-uri))
+ ((string-null? result-filename)
+ (simple-format #t "gnunet-download ~a\n" result-uri))
+ (else
+ (simple-format #t "gnunet-download -o \"~a\" ~a\n"
+ result-filename result-uri)))))
+ (when (equal? '(#:search #:stopped) status)
+ (add-task!
+ (lambda (_) (close-filesharing-service! *fs-handle*)))))
diff --git a/examples/search.scm b/examples/search.scm
index ed3cbec..4e07b0b 100755
--- a/examples/search.scm
+++ b/examples/search.scm
@@ -28,47 +28,47 @@
#:use-module (gnu gnunet scheduler)
#:export (main))
-(define config-file "~/.gnunet/gnunet.conf")
+(define *config-file* "~/.gnunet/gnunet.conf")
+(define *config* (load-configuration *config-file*))
-
-(define (progress-cb %info)
- (let ((status (progress-info-status %info)))
- (when (equal? '(#:search #:result) status)
- (match (parse-c-progress-info %info)
- (((context _ _ query duration anonymity
- (%metadata %uri %result applicability-rank)) _ _)
- (let* ((uri (uri->string (wrap-uri %uri)))
- (meta (wrap-metadata %metadata))
- (result-directory? (is-directory? meta))
- (result-filename (metadata-ref meta #:original-filename)))
- (cond ((and result-directory?
- (string-null? result-filename))
- (simple-format
- #t "gnunet-download -o \"collection.gnd\" -R ~a\n" uri))
- (result-directory?
- (simple-format #t
- "gnunet-download -o \"~a.gnd\" -R ~a\n"
- result-filename uri))
- ((string-null? result-filename)
- (simple-format #t "gnunet-download ~a\n"
- uri))
- (else
- (simple-format #t "gnunet-download -o \"~a\" ~a\n"
- result-filename uri)))))))
- (when (equal? '(#:search #:stopped) status)
- (match (parse-c-progress-info %info)
- ((_ _ %handle)
- (set-next-task! (lambda (_)
- (close-filesharing-service! %handle))))))))
+(define *fs-handle* #f)
+(define *search-handle* #f)
+(define *search-uri* #f)
+
(define (main args)
- (let ((config (load-configuration config-file)))
- (define (first-task _)
- (let* ((fs-service (open-filesharing-service config (car args)
- progress-cb))
- (uri (apply make-ksk-uri (cdr args)))
- (search (start-search fs-service uri)))
- ;; adds a timeout in 5 seconds
- (add-task! (lambda (_) (stop-search search))
- #:delay (time-rel #:seconds 5))))
- (call-with-scheduler config first-task)))
+ (call-with-scheduler *config* (first-task args)))
+
+(define (first-task args)
+ (lambda (_)
+ (set! *fs-handle* (open-filesharing-service *config* (car args)
+ progress-cb))
+ (set! *search-uri* (apply make-ksk-uri (cdr args)))
+ (set! *search-handle* (start-search *fs-handle* *search-uri*))
+ ;; add a timeout in 5 seconds
+ (add-task! (lambda (_) (stop-search *search-handle*))
+ #:delay (time-rel #:seconds 5))))
+
+(define (progress-cb info status)
+ (when (equal? '(#:search #:result) status)
+ (let* ((meta (pinfo-search-metadata info))
+ (uri (uri->string (pinfo-search-uri info)))
+ (result-directory? (is-directory? meta))
+ (result-filename (metadata-ref meta #:original-filename)))
+ (cond ((and result-directory?
+ (string-null? result-filename))
+ (simple-format
+ #t "gnunet-download -o \"collection.gnd\" -R ~a\n" uri))
+ (result-directory?
+ (simple-format #t
+ "gnunet-download -o \"~a.gnd\" -R ~a\n"
+ result-filename uri))
+ ((string-null? result-filename)
+ (simple-format #t "gnunet-download ~a\n"
+ uri))
+ (else
+ (simple-format #t "gnunet-download -o \"~a\" ~a\n"
+ result-filename uri)))))
+ (when (equal? '(#:search #:stopped) status)
+ (add-task! (lambda (_)
+ (close-filesharing-service! *fs-handle*)))))
diff --git a/gnu/gnunet/fs.scm b/gnu/gnunet/fs.scm
index 2715157..048d1ee 100644
--- a/gnu/gnunet/fs.scm
+++ b/gnu/gnunet/fs.scm
@@ -15,7 +15,6 @@
;;;; 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)
@@ -31,7 +30,10 @@
#:export (<file-information>
wrap-file-information
unwrap-file-information
+ file-information-filename
+ file-information-directory?
+ make-block-options
open-filesharing-service
close-filesharing-service!
start-search
@@ -41,10 +43,14 @@
start-publish
stop-publish
is-directory?
- start-directory-scan
- stop-directory-scan
- directory-scanner-result
- share-tree->file-information))
+ ;; to publish a single file
+ make-file-information))
+ ;; to publish a directory
+ ;; buggy/unfinished
+; start-directory-scan
+; stop-directory-scan
+; directory-scanner-result
+; share-tree->file-information))
(define struct-fs-handle
@@ -117,28 +123,54 @@
(define-gnunet-fs %test-for-directory
"GNUNET_FS_meta_data_test_for_directory" : (list '*) -> int)
+(define* (make-block-options expiration-time anonymity-level
+ #:key (content-priority 365)
+ (replication-level 1))
+ "For the filesharing service at the lower level, everything on the network is
+exchanged as blocks. Block options allow you to specify how to publish such
+blocks."
+ (make-c-struct (list time-absolute uint32 uint32 uint32)
+ (list expiration-time anonymity-level
+ content-priority replication-level)))
+
(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))
+(define* (make-file-information filesharing-handle filename block-options
+ #:key (keywords '()) metadata (index? #t))
+ "Builds a <file-information> object from FILENAME to be published under
+BLOCK-OPTIONS.
+
+KEYWORDS is a list of additional keywords (as strings) under which the file
will
+be published, METADATA is some initial metadata, and INDEX? specifies if the
+file should be indexed or not (#t by default)."
(when (string-null? filename)
(throw 'invalid-arg "make-file-information" filename))
+ (when (or (null? block-options) (not (pointer? block-options)))
+ (throw 'invalid-arg "make-file-information" block-options))
(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))))
+ (let ((%info (%file-information-create-from-file
+ filesharing-handle %null-pointer %filename
+ %keywords-str %metadata %index? block-options)))
+ (if (eq? %null-pointer %info)
+ #f
+ (wrap-file-information %info)))))
(define (file-information-filename file-info)
- (%file-information-get-filename (unwrap-file-information file-info)))
+ (let ((%s (%file-information-get-filename
+ (unwrap-file-information file-info))))
+ (if (eq? %null-pointer %s)
+ #f
+ (pointer->string %s))))
(define (file-information-directory? file-info)
- (%file-information-is-directory (unwrap-file-information file-info)))
+ (int->bool (%file-information-is-directory
+ (unwrap-file-information file-info))))
(define (file-information-destroy %file-info)
"Free a file-information structure.
@@ -157,14 +189,8 @@ associated memory is freed)."
(%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?)
+(define (share-tree->file-information filesharing-handle share-tree index?
+ block-options)
"Transform a pointer to a “share-tree” to an instance of <file-information>.
WARNING: the share-tree is unusable after a call to
@@ -177,7 +203,7 @@ SHARE-TREE->FILE-INFORMATION (the associated memory is
freed)."
%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*)))
+ (bool->int index?) block-options)))
(when (eq? %null-pointer %fi)
(throw 'invalid-result "share-tree->file-information"
"%file-information-create-from-file"
@@ -207,7 +233,9 @@ SHARE-TREE->FILE-INFORMATION (the associated memory is
freed)."
(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.
+DISABLE-EXTRACTOR? is #t) and calling PROGRESS-CB each time there’s an
+update. The scanning is done asynchronously in a separate process (an instance
+of `gnunet-helper-fs-publish`).
PROGRESS-CB must be a procedure of three arguments:
– the filename of the file currently being scanned;
@@ -229,14 +257,14 @@ PROGRESS-CB must be a procedure of three arguments:
"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."
+instead, use ADD-TASK! to schedule its call outside the callback."
(%directory-scan-abort scanner))
(define (progress-callback->pointer thunk)
- (procedure->pointer '* (lambda (cls info)
- (thunk info)
+ (procedure->pointer '* (lambda (_ %info)
+ (thunk (parse-c-progress-info %info)
+ (progress-info-status %info))
%null-pointer)
(list '* '*)))
@@ -341,14 +369,13 @@ identify the publication in place of the extracted
keywords)."
(or% (%publish-start filesharing-handle (unwrap-file-information
file-information) %priv
%identifier
%update-id %simulate?)
- (throw 'invalid-arg "start-publish" "%publish-start" %null-pointer))))
+ (throw 'invalid-result "start-publish" "%publish-start"
%null-pointer))))
(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."
+system; instead, use ADD-TASK! to schedule its call outside the callback."
(%publish-stop publish-handle))
;;+TODO: should be (is-directory? search-result) or
diff --git a/gnu/gnunet/fs/progress-info.scm b/gnu/gnunet/fs/progress-info.scm
index fdd73af..25cb6ee 100644
--- a/gnu/gnunet/fs/progress-info.scm
+++ b/gnu/gnunet/fs/progress-info.scm
@@ -26,7 +26,57 @@
#:use-module (gnu gnunet container metadata)
#:use-module (gnu gnunet fs uri)
#:export (progress-info-status
- parse-c-progress-info))
+ parse-c-progress-info
+
+ <pinfo-publish>
+ pinfo-publish?
+ wrap-pinfo-publish
+ unwrap-pinfo-publish
+ pinfo-publish-status
+ pinfo-publish-filename
+ pinfo-publish-size
+ pinfo-publish-eta
+ pinfo-publish-duration
+ pinfo-publish-completed
+ pinfo-publish-anonymity
+ pinfo-publish-chk-uri
+ pinfo-publish-sks-uri
+ pinfo-publish-message
+
+ <pinfo-download>
+ pinfo-download?
+ wrap-pinfo-download
+ unwrap-pinfo-download
+ pinfo-download-status
+ pinfo-download-uri
+ pinfo-download-filename
+ pinfo-download-size
+ pinfo-download-eta
+ pinfo-download-duration
+ pinfo-download-completed
+ pinfo-download-anonymity
+ pinfo-download-active?
+ pinfo-download-message
+
+ <pinfo-search>
+ pinfo-search?
+ wrap-pinfo-search
+ unwrap-pinfo-search
+ pinfo-search-status
+ pinfo-search-query
+ pinfo-search-duration
+ pinfo-search-anonymity
+ pinfo-search-metadata
+ pinfo-search-uri
+ pinfo-search-result
+ pinfo-search-message
+
+ <pinfo-unindex>
+ pinfo-unindex?
+ wrap-pinfo-unindex
+ unwrap-pinfo-unindex
+ pinfo-unindex-status))
+
(define %progress-info-type
@@ -55,9 +105,11 @@
time-relative) ; GNUNET_TIME_Relative eta;
(list #:resume ; struct {…} resume
'* ; char *message;
- '*) ; GNUNET_FS_URI *chk_uri;
+ '* ; GNUNET_FS_URI *chk_uri;
+ '*) ; GNUNET_FS_URI *sks_uri;
(list #:completed ; struct {…} completed
- '*) ; GNUNET_FS_URI *chk_uri;
+ '* ; GNUNET_FS_URI *chk_uri;
+ '*) ; GNUNET_FS_URI *sks_uri;
(list #:error ; struct {…} error
'*))) ; char *message;
(list #:download ; struct {…} download
@@ -156,6 +208,7 @@
unsigned-int ; enum GNUNET_FS_Status status;
'*)) ; GNUNET_FS_Handle *fsh;
+
(define progress-info-status-alist
`((0 #:publish #:start)
(1 #:publish #:resume)
@@ -211,6 +264,59 @@
uint32 uint32 uint32 uint32 uint32))
+(define-record-type <pinfo-publish>
+ (wrap-pinfo-publish pointer status filename size eta duration completed
+ anonymity chk-uri sks-uri message)
+ pinfo-publish?
+ (pointer unwrap-pinfo-publish)
+ (status pinfo-publish-status)
+ (filename pinfo-publish-filename)
+ (size pinfo-publish-size)
+ (eta pinfo-publish-eta)
+ (duration pinfo-publish-duration)
+ (completed pinfo-publish-completed)
+ (anonymity pinfo-publish-anonymity)
+ (chk-uri pinfo-publish-chk-uri)
+ (sks-uri pinfo-publish-sks-uri)
+ (message pinfo-publish-message))
+
+(define-record-type <pinfo-download>
+ (wrap-pinfo-download pointer status uri filename size eta duration completed
+ anonymity active? message)
+ pinfo-download?
+ (pointer unwrap-pinfo-download)
+ (status pinfo-download-status)
+ (uri pinfo-download-uri)
+ (filename pinfo-download-filename)
+ (size pinfo-download-size)
+ (eta pinfo-download-eta)
+ (duration pinfo-download-duration)
+ (completed pinfo-download-completed)
+ (anonymity pinfo-download-anonymity)
+ (active? pinfo-download-active?)
+ (message pinfo-download-message))
+
+(define-record-type <pinfo-search>
+ (wrap-pinfo-search pointer status query duration anonymity metadata
+ uri result message)
+ pinfo-search?
+ (pointer unwrap-pinfo-search)
+ (status pinfo-search-status)
+ (query pinfo-search-query)
+ (duration pinfo-search-duration)
+ (anonymity pinfo-search-anonymity)
+ (metadata pinfo-search-metadata)
+ (uri pinfo-search-uri)
+ (result pinfo-search-result)
+ (message pinfo-search-message))
+
+(define-record-type <pinfo-unindex>
+ (wrap-pinfo-unindex pointer status)
+ pinfo-unindex?
+ (pointer unwrap-pinfo-unindex)
+ (status pinfo-unindex-status))
+
+
(define (integer->progress-info-status n)
(or (assq-ref progress-info-status-alist n)
(throw 'invalid-arg "integer->progress-info-status" n)))
@@ -240,10 +346,67 @@ two keywords. If status is unknown, raises an error."
(list (car status) #f)
status)))
-(define (parse-c-progress-info pointer)
- (apply parse-c-struct* pointer %progress-info-type
- (progress-info-status pointer #t)))
+;;; incomplete mappings of ProgressInfo structures, to be completed on demand.
+
+(define (make-pinfo-publish status pointer vals)
+ (destructuring-bind ((_ _ _ _ %filename size eta duration
+ completed anonymity specs) _ _)
+ vals
+ (apply wrap-pinfo-publish pointer status
+ (pointer->string* %filename)
+ size eta duration completed anonymity
+ (case (cadr status)
+ ((#:completed)
+ (destructuring-bind (%chk-uri %sks-uri) specs
+ (list (wrap-uri %chk-uri)
+ (wrap-uri %sks-uri)
+ #f)))
+ ((#:error)
+ (list #f #f (pointer->string* (car specs))))
+ (else '(#f #f #f))))))
+(define (make-pinfo-download status pointer vals)
+ (destructuring-bind ((_ _ _ _ %uri %filename size eta duration
+ completed anonymity %active? specs) _ _)
+ vals
+ (apply wrap-pinfo-download pointer status
+ (wrap-uri %uri)
+ (pointer->string %filename)
+ size eta duration completed anonymity
+ (int->bool %active?)
+ (if (eq? #:error (cadr status))
+ (list (pointer->string* (car specs)))
+ '(#f)))))
+
+(define (make-pinfo-search status pointer vals)
+ (destructuring-bind ((_ _ _ %query duration anonymity specs) _ _)
+ vals
+ (apply wrap-pinfo-search pointer status
+ %query duration anonymity
+ (case (cadr status)
+ ((#:result #:resume-result)
+ (destructuring-bind (%meta %uri %result . rest) specs
+ (list (wrap-metadata %meta) (wrap-uri %uri) %result #f)))
+ ((#:update #:result-suspend #:result-stopped)
+ (destructuring-bind (_ %meta %uri . rest) specs
+ (list (wrap-metadata %meta) (wrap-uri %uri) #f #f)))
+ ((#:resume #:error)
+ (list #f #f #f (pointer->string* (car specs))))
+ (else '(#f #f #f #f))))))
+
+;;+TODO: write this mapping
+(define (make-pinfo-unindex status pointer vals)
+ (wrap-pinfo-unindex pointer status))
+
+(define (parse-c-progress-info pointer)
+ (let* ((status (progress-info-status pointer #t))
+ (vals (apply parse-c-struct* pointer %progress-info-type status))
+ (maker (case (car status)
+ ((#:publish) make-pinfo-publish)
+ ((#:download) make-pinfo-download)
+ ((#:search) make-pinfo-search)
+ ((#:unindex) make-pinfo-unindex))))
+ (maker status pointer vals)))
;;; incomplete mapping of GNUNET_FS_SearchResult
;;;+TODO: complete mapping of GNUNET_FS_SearchResult
diff --git a/tests/fs.scm b/tests/fs.scm
new file mode 100644
index 0000000..0baa9f5
--- /dev/null
+++ b/tests/fs.scm
@@ -0,0 +1,39 @@
+;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
+;;;;
+;;;; 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 (test-fs)
+ #:use-module (srfi srfi-64)
+ #:use-module (system foreign)
+ #:use-module (gnu gnunet common)
+ #:use-module (gnu gnunet fs))
+
+(test-begin "test-fs")
+
+(define %block-options (make-block-options 0 1))
+
+;;; <file-information>
+
+(define readme (make-file-information %null-pointer ; no fs for this test
+ "README"
+ %block-options
+ #:keywords '("manual" "important")
+ #:index? #t))
+
+(test-equal "README" (file-information-filename readme))
+(test-equal #f (file-information-directory? readme))
+
+(test-end)
diff --git a/tests/progress-info.scm b/tests/progress-info.scm
index f001baa..2781c52 100644
--- a/tests/progress-info.scm
+++ b/tests/progress-info.scm
@@ -20,8 +20,10 @@
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
+ #:use-module (system foreign unions)
#:use-module (gnu gnunet common)
#:use-module (gnu gnunet container metadata)
+ #:use-module (gnu gnunet fs uri)
#:use-module (gnu gnunet fs progress-info))
@@ -32,7 +34,29 @@
(pi-import integer->progress-info-status
progress-info-status->integer
bytevector-u8-fold
- u8-bitmap->list)
+ u8-bitmap->list
+ %progress-info-type)
+
+(define *test-uri*
+ (parse-uri
"gnunet://fs/chk/AH11VENCEPEH119B1TQQ06CT170TA400J653E9G2D7JPV57HRN528KK71270D81PAV23GBNNPS6KKQM48C1H7FG41JT1ETPK551MRH8.74DJF0M1T999MC6K65NV1MC0RG11S81127JS9SV1M79QE2S6GMSQE0K87110D95J9HV0VDCGFG11BK97C2E5BD2T5F6TQTAFF6KP3F0.50"))
+
+(define *test-pinfo-ptr*
+ (make-c-struct* %progress-info-type
+ (list (list %null-pointer ; context
+ %null-pointer ; cctx
+ %null-pointer ; pctx
+ %null-pointer ; sctx
+ (unwrap-uri *test-uri*) ; download uri
+ (string->pointer "trek.txt") ; filename
+ 50 ; size
+ (time-rel #:milli 2) ; eta
+ (time-rel #:seconds 1.3) ; duration
+ 50 ; completed
+ 0 ; anonymity
+ 0) ; is_active
+ 12 ; GNUNET_FS_STATUS_DOWNLOAD_COMPLETED
+ %null-pointer) ; filesharing handle
+ #:download #f))
(test-begin "test-fs-progress-info")
@@ -45,6 +69,13 @@
(test-error 'invalid-arg (progress-info-status->integer
'(#:beam-me-up #:scotty)))
+;; parse-c-progress-info
+(define *test-pinfo* (parse-c-progress-info *test-pinfo-ptr*))
+
+(test-equal "trek.txt" (pinfo-download-filename *test-pinfo*))
+(test-equal 50 (pinfo-download-size *test-pinfo*))
+(test-equal #f (pinfo-download-active? *test-pinfo*))
+
;; bytevector-u8-fold
(let ((bv (make-bytevector 1)))
- [gnunet] 12/17: Complete the container/metadata bindings., (continued)
- [gnunet] 12/17: Complete the container/metadata bindings., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 13/17: Remove `set-next-task!`, as the corresponding functions have been removed from GNUnet., Rémi Birot-Delrue, 2015/08/12
- [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, 2015/08/12
- [gnunet] 08/17: Add `examples/identity.scm`, `examples/identity-bis.scm`, `examples/search-ns.scm`, and a few minor modifications. * examples/search-ns.scm: a basic tool to search namespaces. * examples/identity.scm: a basic tool to list egos. * examples/identity-bis.scm: idem, but using `start-identity-lookup`. * fs/uri.scm: `wrap-uri` throws an `invalid-arg` exception when given a null pointer. * tests/uri.scm: c.f. ↑ * configuration.scm: add `configuration-value-set?`. * identity.scm: add `ecdsa-public-key->string`., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 09/17: Rewrite of examples/publish.scm, small bug fixes and typos. * examples/publish.scm: rewritten to correctly handle namespaces. * gnu/gnunet/binding-utils.scm: add `or%`. * gnu/gnunet/fs.scm: bug fix: `start-*` function throw an error instead of returning %null-pointer. * gnu/gnunet/identity.scm: typo., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 14/17: Code cleaning: various improvements and bug fixes. * identity.scm: `open-identity-service` now throws an exception on failure. * binding-utils.scm: just add `destructuring-bind`. * common.scm: `time-rel` now throws an exception instead of returning a meaningless negative result; add `setup-log`. * container/metadata.scm: `metadata-set!` now throws an exception on error. * tests/container-metadata.scm: add tests for `metadata-copy`, `metadata-clear`, `metadata-equal?` and `add-publication-date!`, Rémi Birot-Delrue, 2015/08/12
- [gnunet] 11/17: Add `close-filesharing-service` and dynamic allocation in `open-filesharing-handle`., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 10/17: Add `time-rel` to replace all ad-hoc time calculations., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 17/17: Minor modifications to get all examples working. * binding-utils.scm: add `and=>%` (`and=>` for foreign pointers). * fs/progress-info.scm: bug fix: on '(#:publish #:complete) do not assert any more there’s a SKS URI (we don’t always publish in a namespace). * examples/search.scm: add a one-line help message. * examples/search-ns.scm, examples/publish.scm: typos., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 15/17: Small typo and improvements (add a few time management functions). * common.scm: - add `bool->int` and `int->bool`; - add `time-rel`, `current-time`, `time-absolute->string`, and `time-relative->absolute`. * uri.scm: minor typo and add LOC URIs to `uri-file-size`., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 16/17: Add a record type for GNUNET_FS_ProgressInfo and a few tests. * progress-info.scm: add a record type for `GNUNET_FS_ProgressInfo` and alter `parse-c-progress-info` to handle it. * fs.scm: - correct `make-file-information`; - deprecate directory-scan (too many bugs to fix, `make-file-information will` do for now); - replace `*block-options*` with `make-block-options`; - update `procedure->*` functions to use `parse-c-progress-info`. * examples/*.scm: follow modifications on fs.scm. * tests/progress-info.scm: add a fake progress-info to test `parse-c-progress-info`. * tests/fs.scm: add a small test for `make-file-information`.,
Rémi Birot-Delrue <=