remibd pushed a commit to branch master
in repository gnunet.
commit 7790951783619a45ca0797e52d8ca2e3db606ab0
Author: Rémi Birot-Delrue <asg...@free.fr>
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 <asg...@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 (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))
