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.
This commit is contained in:
Rémi Birot-Delrue
parent
8fce653b32
commit
ff8e19b523
|
|
@ -28,119 +28,139 @@
|
|||
#:use-module (gnu gnunet identity)
|
||||
#:export (main))
|
||||
|
||||
(define config-file "~/.gnunet/gnunet.conf")
|
||||
(define *index?* #t)
|
||||
(define *simulate?* #f)
|
||||
|
||||
(define-syntax-rule (define-parameter name)
|
||||
(define name (make-parameter #f)))
|
||||
(define *config-file* "~/.gnunet/gnunet.conf")
|
||||
(define *config* #f)
|
||||
|
||||
(define *index?* #t)
|
||||
(define *simulate?* #t)
|
||||
(define *binary-name* #f)
|
||||
(define *filename* #f)
|
||||
|
||||
;;+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-parameter kill-task)
|
||||
(define *kill-task* #f)
|
||||
|
||||
(define-parameter binary-name)
|
||||
(define-parameter file-name)
|
||||
(define-parameter namespace-name)
|
||||
(define-parameter namespace-ego)
|
||||
(define-parameter file-identifier)
|
||||
(define *namespace-name* #f)
|
||||
(define *namespace-ego* #f)
|
||||
|
||||
(define *file-identifier* #f)
|
||||
|
||||
(define *fs-handle* #f)
|
||||
(define *identity-handle* #f)
|
||||
(define *publish-handle* #f)
|
||||
(define *dir-scanner* #f)
|
||||
|
||||
(define-parameter config-handle)
|
||||
(define-parameter fs-handle)
|
||||
(define-parameter publish-handle)
|
||||
(define-parameter dir-scanner)
|
||||
|
||||
(define (main args)
|
||||
"Entry point of the program."
|
||||
(config-handle (load-configuration config-file))
|
||||
(call-with-scheduler (config-handle) (first-task args)))
|
||||
(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 call START-PUBLISH-FILE."
|
||||
"The initial task: parse the command line and either find the
|
||||
demanded ego or call IDENTITY-CONTINUATION."
|
||||
(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 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 (* 5 1000 1000))))
|
||||
((binary file-name)
|
||||
(set! *binary-name* binary)
|
||||
(set! *filename* file-name)
|
||||
(identity-continuation))
|
||||
((binary . _)
|
||||
(simple-format #t "Usage: ~a filename [namespace identifier]\n"
|
||||
binary)))))
|
||||
binary)
|
||||
(schedule-shutdown!)))))
|
||||
|
||||
(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 (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."
|
||||
(display "IDENTITY-CALLBACK\n")
|
||||
(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 (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 (identity-continuation)
|
||||
"The second task: open the filesharing service and start a directory
|
||||
scan on *FILENAME*."
|
||||
(display "IDENTITY-CONTINUATION\n")
|
||||
(cond
|
||||
((or (and *namespace-name* *namespace-ego*)
|
||||
(and (not *namespace-name*) (not *namespace-ego*)))
|
||||
(if *namespace-name*
|
||||
(simple-format #t " -> FILENAME ~a\tNAMESPACE ~a\n" *filename* *namespace-name*)
|
||||
(display " -> FILENAME ~a\n"))
|
||||
(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*))
|
||||
#:delay (* 5 1000 1000))))
|
||||
(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 (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."
|
||||
(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."
|
||||
(simple-format #t "DIRSCAN-CALLBACK(~a ~a ~a)\n" filename directory? reason)
|
||||
(case reason
|
||||
((#:finished)
|
||||
(let* ((%share-tree (directory-scanner-result (fs-handle) (dir-scanner)))
|
||||
(file-info (share-tree->file-information (fs-handle) %share-tree
|
||||
(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?*)))
|
||||
|
||||
(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)))))
|
||||
(dirscan-continuation file-info)))
|
||||
((#: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")))))))
|
||||
(display "dirscan-callback: internal error.\n")
|
||||
(schedule-shutdown!))))
|
||||
|
||||
(define (dirscan-continuation file-info)
|
||||
"Start the publication of FILE-INFO."
|
||||
(display "DIRSCAN-CONTINUATION\n")
|
||||
(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 (* 5 1000 1000))))
|
||||
|
||||
(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."
|
||||
(display "PROGRESS-CALLBACK\n")
|
||||
(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)))))
|
||||
(simple-format #t "Publishing `~a'.\n" (pointer->string %filename)))))
|
||||
((#:completed)
|
||||
(display "3\n")
|
||||
(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)
|
||||
|
|
@ -149,7 +169,10 @@ and when it’s complete print the published file’s URI and stop the publicati
|
|||
;; 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)))))
|
||||
(set! *kill-task*
|
||||
(set-next-task! (lambda (_)
|
||||
(display "Stopping publication\n")
|
||||
(stop-publish *publish-handle*)))))
|
||||
((#:stopped)
|
||||
(display "Publication stopped\n")
|
||||
(schedule-shutdown!)))))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,8 @@
|
|||
|
||||
string->pointer*
|
||||
pointer->string*
|
||||
make-c-struct*))
|
||||
make-c-struct*
|
||||
or%))
|
||||
|
||||
(define (getf plist value)
|
||||
(let ((entry (member value plist)))
|
||||
|
|
@ -77,3 +78,18 @@ if STRING is empty (\"\")."
|
|||
|
||||
(define (pointer->string* ptr)
|
||||
(if (eq? %null-pointer ptr) #f (pointer->string ptr)))
|
||||
|
||||
;; a variant of OR for foreign pointers.
|
||||
;; ex: (or% 'a 'b) → A
|
||||
;; (or% %null-pointer 'b) → B
|
||||
;; (or% %null-pointer %null-pointer) → #f
|
||||
(define-syntax or%
|
||||
(syntax-rules ()
|
||||
((_ x) (let ((x* x))
|
||||
(if (eq? %null-pointer x*)
|
||||
#f
|
||||
x*)))
|
||||
((_ x y ...) (let ((x* x))
|
||||
(if (eq? %null-pointer x*)
|
||||
(or% y ...)
|
||||
x*)))))
|
||||
|
|
|
|||
|
|
@ -216,8 +216,10 @@ PROGRESS-CB must be a procedure of three arguments:
|
|||
(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)))
|
||||
(or% (%directory-scan-start %filename %disable-extractor? %null-pointer
|
||||
%callback %null-pointer)
|
||||
(throw 'invalid-result "start-directory-scan" "%directory-scan-start"
|
||||
%null-pointer))))
|
||||
|
||||
(define (stop-directory-scan scanner)
|
||||
"Abort a scan.
|
||||
|
|
@ -238,7 +240,7 @@ callback."
|
|||
;; is variadic and, hence, not currently handlable by Guile’s Dynamic FFI.
|
||||
;;
|
||||
;;+TODO: dynamically allocate the entire structure & client-name, so that we can
|
||||
;; call GNUNET_FS_stop on the returned handle.
|
||||
;; call GNUNET_FS_stop on the returned handle.
|
||||
;;
|
||||
;;+TODO: replace value for avg_block_latency with a call to a function
|
||||
;; akin `(time-relative #:minutes 1)`
|
||||
|
|
@ -273,22 +275,27 @@ GNUNET_FS_ProgressInfo`) that will be called every time something happens in the
|
|||
filesharing service (a search is started, a download is completed, etc.)."
|
||||
(when (null? client-name)
|
||||
(throw 'invalid-arg "open-filesharing-service" client-name))
|
||||
(%fs-start (unwrap-configuration config)
|
||||
(string->pointer client-name)
|
||||
(progress-callback->pointer progress-callback)))
|
||||
(or% (%fs-start (unwrap-configuration config)
|
||||
(string->pointer client-name)
|
||||
(progress-callback->pointer progress-callback))
|
||||
(throw 'invalid-result "open-filesharing-service" "%fs-start"
|
||||
%null-pointer)))
|
||||
|
||||
(define (start-search filesharing-handle uri)
|
||||
(%search-start filesharing-handle
|
||||
(unwrap-uri uri)
|
||||
0 0 %null-pointer))
|
||||
(or% (%search-start filesharing-handle
|
||||
(unwrap-uri uri)
|
||||
0 0 %null-pointer)
|
||||
(throw 'invalid-result "start-search" "%search-start" %null-pointer)))
|
||||
|
||||
(define (stop-search search-handle)
|
||||
(%search-stop search-handle))
|
||||
|
||||
(define (start-download filesharing-handle uri filename)
|
||||
(%download-start filesharing-handle (unwrap-uri uri) %null-pointer
|
||||
(string->pointer filename) %null-pointer 0
|
||||
(uri-file-size uri) 0 0 %null-pointer %null-pointer))
|
||||
(or% (%download-start filesharing-handle (unwrap-uri uri) %null-pointer
|
||||
(string->pointer filename) %null-pointer 0
|
||||
(uri-file-size uri) 0 0 %null-pointer %null-pointer)
|
||||
(throw 'invalid-result "start-download" "%download-start"
|
||||
%null-pointer)))
|
||||
|
||||
(define* (stop-download download-handle #:key delete-incomplete?)
|
||||
(%download-stop download-handle (if delete-incomplete? gnunet-yes gnunet-no)))
|
||||
|
|
@ -315,8 +322,10 @@ identify the publication in place of the extracted keywords)."
|
|||
(%update-id (if update-identifier (string->pointer update-identifier)
|
||||
%null-pointer))
|
||||
(%simulate? (if simulate? gnunet-yes gnunet-no)))
|
||||
(%publish-start filesharing-handle file-information %priv %identifier
|
||||
%update-id %simulate?)))
|
||||
(or% (%publish-start filesharing-handle (unwrap-file-information
|
||||
file-information) %priv %identifier
|
||||
%update-id %simulate?)
|
||||
(throw 'invalid-arg "start-publish" "%publish-start" %null-pointer))))
|
||||
|
||||
(define (stop-publish publish-handle)
|
||||
"Stops a publication.
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@ IDENTITY-CALLBACK will also be called.
|
|||
Returns a handle to the “ego retrieving operation” that can be used to
|
||||
cancel it (see CANCEL-OPERATION!)."
|
||||
(when (string-null? service)
|
||||
(throw 'invalid-arg "open-identity-service" service))
|
||||
(throw 'invalid-arg "get-default-ego" service))
|
||||
(%identity-get identity-handle (string->pointer service)
|
||||
(identity-callback->pointer identity-callback) %null-pointer))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue