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