guix
/
gnunet
mirror of git://git.savannah.gnu.org/guix/gnunet.git
2
0
Fork 0
Code Issues Releases Wiki Activity

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`.
This commit is contained in:
Rémi Birot-Delrue 2015-08-12 19:31:27 +02:00
parent 5581107a9d
commit cd20d8d6d0
9 changed files with 524 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
examples/download.scm
View File

@ -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*)))))))

2
examples/identity.scm
View File

@ -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))

287
examples/publish.scm
View File

@ -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))
(define *index?* #t)
(define *simulate?* #f)
;;; 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)))
;;; 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 (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 (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 (meta-printer name type format mime-type data)
"Print metadata entries (except binary metadata and the filename).
(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))))
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!))))
"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 (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 (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 (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 (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 (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*)))))))
(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))

50
examples/search-ns.scm
View File

@ -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*)))))

82
examples/search.scm
View File

@ -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 *fs-handle* #f)
(define *search-handle* #f)
(define *search-uri* #f)
(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 (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*)))))

85
gnu/gnunet/fs.scm
View File

@ -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

175
gnu/gnunet/fs/progress-info.scm
View File

@ -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)
@ -210,6 +263,59 @@
'* time-absolute time-relative
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)
@ -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

39
tests/fs.scm Normal file
View File

@ -0,0 +1,39 @@
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
;;;;
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
;;;;
;;;; 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)

33
tests/progress-info.scm
View File

@ -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)))