[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet] 03/17: Bind basic download functionalities * examples/download.
From: |
Rémi Birot-Delrue |
Subject: |
[gnunet] 03/17: Bind basic download functionalities * examples/download.scm: a loose `gnunet-download' clone. * system/foreign/unions.scm: add the possibility to specify #f as a union variant to get a padding of the size of the union. * gnu/gnunet/fs/progress-info.scm: just adapted to the modification to unions.scm. * gnu/gnunet/fs/uri.scm: add a few utility functions: `parse-uri' and `uri-file-size'. * gnu/gnunet/fs/fs.scm: add `start-download` and `stop-download`. |
Date: |
Wed, 12 Aug 2015 18:24:37 +0000 |
remibd pushed a commit to branch master
in repository gnunet.
commit 7790951783619a45ca0797e52d8ca2e3db606ab0
Author: RĂ©mi Birot-Delrue <address@hidden>
Date: Fri Jul 17 12:32:39 2015 +0200
Bind basic download functionalities
* examples/download.scm: a loose `gnunet-download' clone.
* system/foreign/unions.scm: add the possibility to specify #f as a
union variant to get a padding of the
size of the union.
* gnu/gnunet/fs/progress-info.scm: just adapted to the modification to
unions.scm.
* gnu/gnunet/fs/uri.scm: add a few utility functions: `parse-uri' and
`uri-file-size'.
* gnu/gnunet/fs/fs.scm: add `start-download` and `stop-download`.
---
examples/download.scm | 79 +++++++++++++++++++++++++++++++++++++++
gnu/gnunet/fs.scm | 18 +++++++++
gnu/gnunet/fs/progress-info.scm | 29 ++++++++++++--
gnu/gnunet/fs/uri.scm | 34 ++++++++++++++++-
system/foreign/unions.scm | 13 ++++--
tests/system-foreign-unions.scm | 12 ++++-
tests/uri.scm | 5 ++
7 files changed, 177 insertions(+), 13 deletions(-)
diff --git a/examples/download.scm b/examples/download.scm
new file mode 100755
index 0000000..02eee76
--- /dev/null
+++ b/examples/download.scm
@@ -0,0 +1,79 @@
+#!/usr/bin/guile \
+-e (@\ (gnunet-download)\ main) -L . -s
+!#
+;;;; Copyright © 2015 Rémi Delrue <address@hidden>
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnunet-download)
+ #:use-module (ice-9 match)
+ #:use-module (system foreign)
+ #:use-module (gnu gnunet common)
+ #:use-module (gnu gnunet container metadata)
+ #:use-module (gnu gnunet fs)
+ #:use-module (gnu gnunet fs uri)
+ #:use-module (gnu gnunet fs progress-info)
+ #:use-module (gnu gnunet configuration)
+ #:use-module (gnu gnunet scheduler)
+ #:export (main))
+
+(define config-file "~/.gnunet/gnunet.conf")
+
+(define *fs-handle* %null-pointer)
+(define *dl-handle* %null-pointer)
+(define *stderr* (current-error-port))
+(define *count* 1)
+
+
+(define (shutdown-task _)
+ (simple-format *stderr* "scheduler run: timeout\n")
+ (force-output *stderr*)
+ (display "Shutdown\n")
+ (simple-format *stderr* "shutdown-task: stopping dl ~a\n" *dl-handle*)
+ (stop-download *dl-handle*)
+ (simple-format *stderr* "shutdown-task: stopped dl\n"))
+
+(define (progress-cb %info)
+ (simple-format *stderr* "scheduler run: progress-cb ~a ~a\n"
+ *count* (progress-info-status %info))
+ (force-output *stderr*)
+ (set! *count* (1+ *count*))
+ (let ((status (progress-info-status %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)))))
+ ((equal? status '(#:download #:completed))
+ (match (parse-c-progress-info %info)
+ (((%context cctx pctx sctx %uri %filename . _) . _)
+ (simple-format #t "Downloading `~a' done.\n"
+ (pointer->string %filename))))))))
+
+(define (main args)
+ (let ((config (load-configuration config-file)))
+ (define (first-task _)
+ (simple-format *stderr* "scheduler run: first-task\n")
+ (force-output *stderr*)
+ (match args
+ ((binary-name output-filename uri-string)
+ (set! *fs-handle* (open-filesharing-service config binary-name
+ progress-cb))
+ (let ((uri (parse-uri uri-string)))
+ (set! *dl-handle* (start-download *fs-handle* uri output-filename))
+ ;; add a timeout in 5 seconds
+ (simple-format *stderr* "scheduler add: timeout\n")
+ (force-output *stderr*)
+ (add-task! shutdown-task #:delay (* 5 1000 1000))))))
+ (call-with-scheduler config first-task)))
diff --git a/gnu/gnunet/fs.scm b/gnu/gnunet/fs.scm
index 5541b17..2e71386 100644
--- a/gnu/gnunet/fs.scm
+++ b/gnu/gnunet/fs.scm
@@ -26,6 +26,8 @@
#:export (open-filesharing-service
start-search
stop-search
+ start-download
+ stop-download
is-directory?))
@@ -52,6 +54,13 @@
(define-gnunet-fs %search-stop
"GNUNET_FS_search_stop" : (list '*) -> void)
+(define-gnunet-fs %download-start
+ "GNUNET_FS_download_start" :
+ (list '* '* '* '* '* uint64 uint64 uint32 unsigned-int '* '*) -> '*)
+
+(define-gnunet-fs %download-stop
+ "GNUNET_FS_download_stop" : (list '* int) -> void)
+
(define-gnunet-fs %test-for-directory
"GNUNET_FS_meta_data_test_for_directory" : (list '*) -> int)
@@ -112,6 +121,15 @@ filesharing service (a search is started, a download is
completed, etc.)."
(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))
+
+(define* (stop-download download-handle #:key delete-incomplete?)
+ (%download-stop download-handle (if delete-incomplete? 1 0)))
+
+
;;+TODO: should be (is-directory? search-result) or
;; (result-is-directory? result)
(define (is-directory? metadata)
diff --git a/gnu/gnunet/fs/progress-info.scm b/gnu/gnunet/fs/progress-info.scm
index 7ffafec..fdd73af 100644
--- a/gnu/gnunet/fs/progress-info.scm
+++ b/gnu/gnunet/fs/progress-info.scm
@@ -196,6 +196,15 @@
(36 #:unindex #:stopped)
(37 #:publish #:progress-directory)))
+;; An alist of each “sub”-status featuring a non-empty “specifics” field in
+;; `struct GNUNET_FS_ProgressInfo`.
+(define has-specifics-alist
+ '((#:publish #:progress #:progress-directory #:resume #:completed #:error)
+ (#:download #:progress #:start #:resume #:error)
+ (#:search #:result #:resume-result #:update #:result-suspend
+ #:result-stopped #:resume #:error #:ns)
+ (#:unindex #:progress #:resume #:error)))
+
(define %search-result-type
(list '* '* '* '* '* '* '* '* '* '* '* '* hashcode
'* time-absolute time-relative
@@ -210,18 +219,30 @@
(or (rassoc-ref progress-info-status-alist status)
(throw 'invalid-arg "progress-info-status->integer" status)))
-(define (progress-info-status pointer)
+(define (has-specifics? status)
+ "Return #t if STATUS features a non-empty “specifics” field in `struct
+GNUNET_FS_ProgressInfo`."
+ (let ((specifics-list (assq-ref has-specifics-alist (car status))))
+ (when (not specifics-list)
+ (throw 'invalid-arg "has-specifics?" status))
+ (not (not (memq (cadr status) specifics-list)))))
+
+(define* (progress-info-status pointer #:optional replace-absent-specifics)
"Returns the status of a struct GNUNET_FS_ProgressInfo as a list of
two keywords. If status is unknown, raises an error."
(let* ((size (sizeof unsigned-int))
(offset (sizeof* (car %progress-info-type)))
(bv (pointer->bytevector pointer size offset))
- (code (bytevector-uint-ref bv 0 (native-endianness) size)))
- (integer->progress-info-status code)))
+ (code (bytevector-uint-ref bv 0 (native-endianness) size))
+ (status (integer->progress-info-status code)))
+ (if (and replace-absent-specifics
+ (not (has-specifics? status)))
+ (list (car status) #f)
+ status)))
(define (parse-c-progress-info pointer)
(apply parse-c-struct* pointer %progress-info-type
- (progress-info-status pointer)))
+ (progress-info-status pointer #t)))
;;; incomplete mapping of GNUNET_FS_SearchResult
diff --git a/gnu/gnunet/fs/uri.scm b/gnu/gnunet/fs/uri.scm
index 4727d97..9503408 100644
--- a/gnu/gnunet/fs/uri.scm
+++ b/gnu/gnunet/fs/uri.scm
@@ -27,6 +27,7 @@
#:use-module (gnu gnunet binding-utils)
#:export (<uri>
uri?
+ parse-uri
make-ksk-uri
make-ksk-uri-pointer
make-sks-uri
@@ -34,6 +35,7 @@
wrap-uri
unwrap-uri
uri-type
+ uri-file-size
uri->string))
(define-record-type <uri>
@@ -70,12 +72,18 @@
(define-gnunet-fs %uri->string
"GNUNET_FS_uri_to_string" : '(*) -> '*)
+(define-gnunet-fs %uri-parse
+ "GNUNET_FS_uri_parse" : '(* *) -> '*)
+
(define-gnunet-fs %uri-ksk-create
"GNUNET_FS_uri_ksk_create" : '(* *) -> '*)
(define-gnunet-fs %uri-sks-create
"GNUNET_FS_uri_sks_create" : '(* *) -> '*)
+(define-gnunet-fs %uri-chk-get-file-size
+ "GNUNET_FS_uri_chk_get_file_size" : '(*) -> uint64)
+
(define (keyword-list->string keywords)
(string-concatenate/shared (interleave " " keywords)))
@@ -85,6 +93,22 @@
(set-pointer-finalizer! pointer %uri-destroy))
(%wrap-uri pointer (%uri-get-type pointer)))
+(define (parse-uri str)
+ (when (or (null? str) (string-null? str))
+ (throw 'invalid-arg "parse-uri" str))
+ (let* ((%error-message-ptr (%make-blob-pointer))
+ (%uri (%uri-parse (string->pointer str) %error-message-ptr))
+ (%error-message (dereference-pointer %error-message-ptr)))
+ (cond ((and (eq? %null-pointer %uri)
+ (eq? %null-pointer %error-message))
+ (throw 'invalid-result "parse-uri" "%uri-parse"
+ (list str %error-message-pointer)))
+ ((eq? %null-pointer %uri)
+ (%free %error-message) ; we don’t use error-message
+ (throw 'invalid-arg "parse-uri" str))
+ (else
+ (wrap-uri %uri #:finalize #t)))))
+
(define (make-ksk-uri-pointer . keywords)
"Create a foreign pointer to a KSK URI from a list of strings KEYWORDS."
(when (null? keywords)
@@ -100,7 +124,8 @@
((eq? %null-pointer %uri)
(%free %error-msg) ; we don’t use error-msg
(throw 'invalid-arg "make-ksk-uri-pointer" keywords))
- (else %uri))))
+ (else (set-pointer-finalizer! %uri %uri-destroy)))
+ %uri))
(define (make-ksk-uri . keywords)
"Create an <uri> of type #:ksk from the list of strings KEYWORDS."
@@ -129,6 +154,13 @@
((2) #:ksk)
((3) #:loc))))
+(define (uri-file-size uri)
+ "Return the size of the file pointed by URI. Raises an invalid-arg error if
+URI is not a chk uri."
+ (when (not (eq? #:chk (uri-type uri)))
+ (throw 'invalid-arg "uri-file-size" uri))
+ (%uri-chk-get-file-size (unwrap-uri uri)))
+
(define (uri->string uri)
(let ((%str (%uri->string (unwrap-uri uri))))
(if (eq? %null-pointer %str)
diff --git a/system/foreign/unions.scm b/system/foreign/unions.scm
index 480cf26..146f9d5 100644
--- a/system/foreign/unions.scm
+++ b/system/foreign/unions.scm
@@ -128,11 +128,14 @@ assoc. list that was given to `union` without its keys)."
(else (sizeof type))))
(define (union-ref-padded union key)
- (let* ((type (union-ref union key))
- (offset (- (sizeof* union) (sizeof* type))))
- (append type (if (> offset 0)
- (list (pad offset))
- '()))))
+ (cond (key
+ (let* ((type (union-ref union key))
+ (offset (- (sizeof* union) (sizeof* type))))
+ (append type (if (> offset 0)
+ (list (pad offset))
+ '()))))
+ (else
+ (list (pad (sizeof* union))))))
(define (replace-unions types union-refs)
(let* ((stack (list-copy union-refs)))
diff --git a/tests/system-foreign-unions.scm b/tests/system-foreign-unions.scm
index 513e359..906812d 100644
--- a/tests/system-foreign-unions.scm
+++ b/tests/system-foreign-unions.scm
@@ -67,8 +67,10 @@
(union-ref-padded simple-case #:foo))
;; test for structures trailing padding
(test-equal (list uint8 (pad (+ 3 2 2)))
- (union-ref-padded complex-case #:bar)))
-
+ (union-ref-padded complex-case #:bar))
+ ;; test for unused union
+ (test-equal (list (pad 2))
+ (union-ref-padded simple-case #f)))
;; replace-unions
;;+TODO: replace ad-hoc alignment values with (sizeof* _) and
@@ -88,12 +90,16 @@
(replace-unions simple-case '(#:foo)))
(test-equal (list int16 (list int8 (pad (+ 1 1 1))) int16)
(replace-unions simple-case '(#:bar)))
+ (test-equal (list int16 (list (pad 4)) int16)
+ (replace-unions simple-case (list #f)))
(test-equal (list int16 (list int32 (list int16 int16) int8) int16)
(replace-unions nested-case '(#:foo #:alice)))
(test-equal (list int16 (list int32 (list int8 (pad (+ 1 2))) int8) int16)
(replace-unions nested-case '(#:foo #:bob)))
(test-equal (list int16 (list int8 (pad (+ 3 (+ 2 2) 1 3))) int16)
- (replace-unions nested-case '(#:bar))))
+ (replace-unions nested-case '(#:bar)))
+ (test-equal (list int16 (list int32 (list (pad (+ 2 2))) int8) int16)
+ (replace-unions nested-case '(#:foo #f))))
;;+TODO: write-c-struct*
;;+TODO: read-c-struct*
diff --git a/tests/uri.scm b/tests/uri.scm
index 81f263c..ba3660b 100644
--- a/tests/uri.scm
+++ b/tests/uri.scm
@@ -22,6 +22,11 @@
(test-begin "test-fs-uri")
+;; parse-uri
+(test-error 'invalid-arg (parse-uri ""))
+(let ((uri (parse-uri "gnunet://fs/ksk/trek")))
+ (test-equal #:ksk (uri-type uri)))
+
;; make-ksk-uri
(test-error 'invalid-arg (make-ksk-uri-pointer))
- [gnunet] branch master updated (c40fcac -> 2304d66), Rémi Birot-Delrue, 2015/08/12
- [gnunet] 01/17: Corrects a small bug., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 04/17: Add a few utility functions. * binding-utils.scm: add `pointer->string*`. * common.scm: add `bool->int` and `int->bool`, two functions to easily convert `gnunet-ok`, `gnunet-no`, `gnunet-syserror` values to booleans. * fs/uri.scm: export `keyword-list->string`. * tests/uri.scm: test `keyword-list->string`. * scheduler.scm: add `cancel-task!`., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 02/17: API cleanup: separates search and URI, adds sks URIs. * examples/search.scm: echo changes in the API; * gnu/gnunet/common.scm: add ecdsa-public-key? and string->data-pointer; * gnu/gnunet/fs.scm: replace search-service-open with open-filesharing-service, replace start-ksk-search with start-search; * gnu/gnunet/fs/uri.scm: add make-sks-uri-pointer and make-sks-uri; * tests/uri.scm: add tests for make-sks-uri-pointer and make-sks-uri., Rémi Birot-Delrue, 2015/08/12
- [gnunet] 03/17: Bind basic download functionalities * examples/download.scm: a loose `gnunet-download' clone. * system/foreign/unions.scm: add the possibility to specify #f as a union variant to get a padding of the size of the union. * gnu/gnunet/fs/progress-info.scm: just adapted to the modification to unions.scm. * gnu/gnunet/fs/uri.scm: add a few utility functions: `parse-uri' and `uri-file-size'. * gnu/gnunet/fs/fs.scm: add `start-download` and `stop-download`.,
Rémi Birot-Delrue <=
- [gnunet] 06/17: Bind GNUNET_FS_IDENTITY_* functions and add support for publishing in namespaces. * identity.scm: complete bindings of GNUNET_FS_IDENTITY * fs.scm: add support for egos/namespaces to `start-publish` * binding-utils: remove the useless import of `assert`, Rémi Birot-Delrue, 2015/08/12
- [gnunet] 05/17: Add draft support for indexing/publication. * fs.scm: - add a `<file-information>` type and associated functions (`wrap-file-information`, `unwrap-file-information`, and `make-file-information`); - add incomplete bindings to `GNUNET_FS_directory_scan_*` functions (`start-directory-scan`, `stop-directory-scan`, `directory-scanner-result`) - add `share-tree->file-information` - add `start-publish` and `stop-publish` * examples/publish.scm: a very simple and ugly `gnunet-publish` clone., Rémi Birot-Delrue, 2015/08/12
- [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