[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]

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