add 'gnunet-guile publish CONFIGURATION FILENAME'

This is not a full re-implementation of gnunet-publish, it doesn't
include support for:

- setting namespace
- using default configuration
- settings anonymity
- publishing directories is not supported

2 files changed, 259 insertions, 21 deletions

diff --git a/gnunet-guile b/gnunet-guile
index 6a05c39..d1566c6 100755
--- a/gnunet-guile
+++ b/gnunet-guile
@@ -25,16 +25,13 @@ exec guile -e '(@ (gnunet-guile) main)' -s "$0" "$@"
 (use-modules ((gnunet subcommand)))
 
 
-;;; download
+;;; download, gnunet-download.c
 
-(define %download-options
-  '((help (single-char #\h) (value #f))))
-
-(define (task/clean-up fs)
+(define (download/task/clean-up fs)
   (lambda ()
     (fs-stop fs)))
 
-(define (progress info)
+(define (download/progress info)
   (let ((status (fs-progress-info-status info)))
     (cond
      ((eq? status %fs-status-download-start)
@@ -48,21 +45,24 @@ exec guile -e '(@ (gnunet-guile) main)' -s "$0" "$@"
       (display "* Download complete!\n")
       (scheduler-shutdown))
      ((eq? status %fs-status-download-stopped)
-      (scheduler-add-now (task/clean-up (fs-progress-info-fs info))))
+      (scheduler-add-now (download/task/clean-up (fs-progress-info-fs info))))
      ((or (eq? status %fs-status-download-active)
           (eq? status %fs-status-download-inactive))
       #t)
      (else (format #t "* Unexpected status (~a)\n" status)))))
 
-(define (task/shutdown download-context)
+(define (download/task/shutdown download-context)
   (lambda ()
     (fs-download-stop download-context #true)))
 
-(define (task/download configuration uri filename)
+(define (download/task configuration uri filename)
   (lambda ()
-    (let ((fs (fs-start configuration "gnunet-guile" progress)))
+    (let ((fs (fs-start configuration "gnunet-guile" download/progress)))
       (let ((download-context (fs-download-start fs uri 0 #:filename filename)))
-        (scheduler-add-shutdown (task/shutdown download-context))))))
+        (scheduler-add-shutdown (download/task/shutdown download-context))))))
+
+(define %download-options
+  '((help (single-char #\h) (value #f))))
 
 (define (download args)
   "gnunet download CONFIGURATION URI FILENAME
@@ -82,12 +82,89 @@ Download the URI to FILENAME using CONFIGURATION.
                (unless (or (uri-chk? uri) (uri-loc? uri))
                  ;; TODO: proper exit
                  (throw 'gnunet-guile "Only CHK or LOC URIs supported"))
-               (scheduler-run (task/download configuration* uri filename)))))))))
+               (scheduler-run (download/task configuration* uri filename)))))))))
+
+;;; publish, gnunet-publish.c
+
+;; XXX: we have to use global, because gnunet doesn't expose it in
+;; directory-scan callback aka. publish/task/directory-scan
+(define %directory-scanner #f)
+
+(define (publish/progress info)
+  (let ((status (fs-progress-info-status info)))
+    (cond
+     ((eq? status %fs-status-publish-start)
+      (format #t "* Publishing started!\n"))
+     ((eq? status %fs-status-publish-progress)
+      (format #t "* Publishing in progress...\n"))
+     ((eq? status %fs-status-publish-error)
+      (format #t "* Error publishing: ~a!\n" (fs-progress-info-publish-error info))
+      (scheduler-shutdown))
+     ((eq? status %fs-status-publish-completed)
+      (format #t "* Publishing '~a' done.\n" (fs-progress-info-publish-filename info))
+      (format #t "* URI is '~a'\n" (fs-progress-info-publish-chk-uri info))
+      (scheduler-shutdown)))))
+
+(define (publish/task/shutdown publish-context)
+  (lambda ()
+    (fs-publish-stop publish-context)))
+
+(define (publish/task/directory-scan fs)
+  (lambda (filename directory? reason)
+    (cond
+     ((eq? reason %fs-directory-scanner-file-start)
+      (format #t "* Scanning ~a.\n" filename))
+     ((eq? reason %fs-directory-scanner-file-ignored)
+      (format #t "* There was trouble processing file ~a, skipping it.\n" filename))
+     ((eq? reason %fs-directory-scanner-all-counted)
+      (format #t "* Preprocessing complete.\n"))
+     ((eq? reason %fs-directory-scanner-extract-finished)
+      (format #t "* Extracting meta data from file `~a' complete.\n" filename))
+     ((eq? reason %fs-directory-scanner-finished)
+      (let ((share-tree (fs-directory-scan-get-result* %directory-scanner)))
+        (let ((fi (fs-file-information-create-from-file
+                   fs
+                   (fs-share-tree-item-filename share-tree)
+                   (fs-share-tree-item-ksk-uri share-tree)
+                   (fs-share-tree-item-meta share-tree)
+                   %gnunet-yes
+                   (fs-block-options))))
+          ;; TODO: call GNUNET_FS_file_information_inspect
+          (let ((publish-context (fs-publish-start fs fi)))
+            (scheduler-add-shutdown (publish/task/shutdown publish-context))))))
+     ((eq? reason %fs-directory-scanner-error)
+      (scheduler-shutdown))
+     (else (error "should not happen")))))
+
+(define (publish/task configuration filename)
+  (lambda ()
+    (let ((fs (fs-start configuration "gnunet-guile" publish/progress)))
+      (set! %directory-scanner
+        (fs-directory-scan-start filename
+                                 #t
+                                 (publish/task/directory-scan fs))))))
+
+(define (publish-exec configuration filename)
+  (let ((configuration* (configuration-create)))
+    (configuration-load! configuration* configuration)
+    (scheduler-run (publish/task configuration* filename))))
+
+(define %publish-options
+  '((help (single-char #\h) (value #f))))
 
-;;; publish
+(define (publish args)
+  "gnunet-guile publish CONFIGURATION FILE
 
-(define (publish . args)
-  (pk 'publish args))
+Publish on gnunet FILE using CONFIGURATION
+"
+  (let ((options (getopt-long (cons "gnunet-guile publish" args)
+                              %download-options
+                              #:stop-at-first-non-option #f)))
+    (if (option-ref options 'help #f)
+        (display (procedure-documentation download))
+        (match args
+          ((configuration file)
+           (publish-exec configuration file))))))
 
 ;;; cli
 
diff --git a/gnunet.scm b/gnunet.scm
index ae9c218..e59e959 100644
--- a/gnunet.scm
+++ b/gnunet.scm
@@ -24,6 +24,7 @@
 (use-modules ((gnunet config)))
 
 
+;; XXX: This is broken, do not re-use, see "workaround dynamic-link*"
 (define* (dynamic-link* #:optional library-name)
   (let ((shared-object (if library-name (dynamic-link library-name) (dynamic-link))))
     (lambda (return-value function-name . arguments)
@@ -45,6 +46,7 @@
   "If value is a %null-pointer throw a 'gnunet-error. Return the value
 otherwise"
   (if (eq? value ffi:%null-pointer)
+      ;; This is not very clean, it should stop the scheduler
       (throw 'gnunet-error message)
       value))
 
@@ -63,6 +65,9 @@ otherwise"
     (let ((bv (ffi:pointer->bytevector pointer size)))
       (make-bytestructure bv 0 desc))))
 
+(define bytestructure->pointer (compose ffi:bytevector->pointer
+                                        bytestructure-bytevector))
+
 ;;; gnunet-util bindings, gnunet_util_lib.h
 
 (define util (dynamic-link* %libgnunet-util))
@@ -266,14 +271,24 @@ Return unique task identifier for the job, valid until THUNK is started."
 
 ;; uri
 
+(define uri-destroy
+  (let ((func (fs ffi:void "GNUNET_FS_uri_destroy" '*)))
+    (ffi:procedure->pointer ffi:void func '(*))))
+
 (define-public string->uri
   (let ((func (fs '* "GNUNET_FS_uri_parse" '* '*)))
     (lambda (string)
       (let ((out (func (ffi:string->pointer string) ffi:%null-pointer)))
         (when (eq? out ffi:%null-pointer)
           (throw 'gnunet-error "Failed to parse URI"))
+        (ffi:set-pointer-finalizer! out uri-destroy)
         out))))
 
+(define-public uri->string
+  (let ((func (fs '* "GNUNET_FS_uri_to_string" '*)))
+    (lambda (uri)
+      (ffi:pointer->string (func uri)))))
+
 (define-public uri-chk?
   (let ((func (fs ffi:int "GNUNET_FS_uri_test_chk" '*)))
     (lambda (uri)
@@ -286,12 +301,6 @@ Return unique task identifier for the job, valid until THUNK is started."
       "Is this a location URI?"
       (integer->boolean (func uri)))))
 
-(define-public uri-destroy
-  (let ((func (fs ffi:void "GNUNET_FS_uri_destroy" '*)))
-    (lambda (uri)
-      "Destroy uri"
-      (func uri))))
-
 (define-public uri-chk-get-file-size
   (let ((func (fs ffi:uint64 "GNUNET_FS_uri_chk_get_file_size" '*)))
     (lambda (uri)
@@ -499,6 +508,21 @@ Return unique task identifier for the job, valid until THUNK is started."
 (define-public (fs-progress-info-download-context info)
   (ffi:make-pointer (bytestructure-ref info 'value 'download 'download-context)))
 
+(define-public (fs-progress-info-publish-error info)
+  (ffi:pointer->string
+   (ffi:make-pointer
+    (bytestructure-ref info 'value 'publish 'specifics 'error 'message))))
+
+(define-public (fs-progress-info-publish-filename info)
+  (ffi:pointer->string
+   (ffi:make-pointer
+    (bytestructure-ref info 'value 'publish 'filename))))
+
+(define-public (fs-progress-info-publish-chk-uri info)
+  (uri->string
+   (ffi:make-pointer
+    (bytestructure-ref info 'value 'publish 'specifics 'completed 'chk-uri))))
+
 (define (progress-callback-wrapper callback)
   (lambda (_ info)
     (callback (pointer->bytestructure %fs-progress-info info))))
@@ -594,6 +618,143 @@ the level of anonymity for the download."
     (lambda (download-context delete-incomplete-files?)
       (func download-context (boolean->integer delete-incomplete-files?)))))
 
+(define-public %fs-publish-option-none 0)
+(define-public %fs-publish-option-simulate-only 1)
+
+(define-public fs-publish-start
+  (let ((func (fs '* "GNUNET_FS_publish_start" '* '* '* '* '* ffi:int)))
+    (lambda* (fs
+              file-information
+              #:key
+              (namespace #f)
+              (nid #f)
+              (nuid #f)
+              (options %fs-publish-option-none))
+      (let ((out (func fs
+                       file-information
+                       (if namespace namespace ffi:%null-pointer)
+                       (if nid (ffi:string->pointer nid) ffi:%null-pointer)
+                       (if nuid (ffi:string->pointer nuid) ffi:%null-pointer)
+                       options)))
+        (check2 out "Could not start publishing.")))))
+
+(define-public fs-publish-stop
+  (let ((func (fs ffi:void "GNUNET_FS_publish_stop" '*)))
+    (lambda (publish-context)
+      "Stop a publication.  Will abort incomplete publications (but not remove
+blocks that have already been published) or simply clean up the state for
+completed publications.  Must NOT be called from within the event callback!"
+      (func publish-context))))
+
+(define-public %fs-directory-scanner-file-start 0)
+(define-public %fs-directory-scanner-file-ignored 1)
+(define-public %fs-directory-scanner-all-counted 2)
+(define-public %fs-directory-scanner-extract-finished 3)
+(define-public %fs-directory-scanner-finished 4)
+(define-public %fs-directory-scanner-error 5)
+
+(define %fs-share-tree-item (bs:struct
+                             `((prev ,(bs:pointer (delay %fs-share-tree-item)))
+                               (next ,(bs:pointer (delay %fs-share-tree-item)))
+                               (parent ,(bs:pointer (delay %fs-share-tree-item)))
+                               (children-head ,(bs:pointer (delay %fs-share-tree-item)))
+                               (children-tail ,(bs:pointer (delay %fs-share-tree-item)))
+                               (meta ,uintptr_t)
+                               (ksk-uri ,uintptr_t)
+                               (filename ,uintptr_t)
+                               (short-filename ,uintptr_t)
+                               (directory? ,int))))
+
+(define (maybe->string pointer)
+  (if (eq? pointer ffi:%null-pointer)
+      #f
+      (ffi:pointer->string pointer)))
+
+(define-public fs-directory-scan-start
+  (let ((func (fs '* "GNUNET_FS_directory_scan_start" '* ffi:int '* '* '*)))
+    (lambda (filename extractor? callback)
+      "Start a directory scanner
+
+Return a directory scanner object"
+      (func (ffi:string->pointer filename)
+            (boolean->integer (not extractor?))
+            ffi:%null-pointer
+            (ffi:procedure->pointer ffi:void
+                                    (lambda (_ filename directory? reason)
+                                      (callback (maybe->string filename)
+                                                (integer->boolean directory?)
+                                                reason))
+                                    (list '* '* ffi:int ffi:int))
+            ffi:%null-pointer))))
+
+(define-public fs-directory-scan-abort
+  (let ((func (fs ffi:void "GNUNET_FS_directory_scan_abort" '*)))
+    (lambda (directory-scanner)
+      "Abort the scan. Must not be called within the callback function of
+fs-directory-scan-start"
+      (func directory-scanner))))
+
+(define-public fs-directory-scan-get-result
+  (let ((func (fs '* "GNUNET_FS_directory_scan_get_result" '*))
+        (free (fs ffi:void "GNUNET_FS_share_tree_free" '*)))
+    (lambda (directory-scanner)
+      (let ((out (func directory-scanner)))
+        ;; XXX: workaround dynamic-link*
+        (ffi:set-pointer-finalizer! out (ffi:procedure->pointer ffi:void free '(*)))
+        out))))
+
+(define-public fs-share-tree-trim!
+  (let ((func (fs '* "GNUNET_FS_share_tree_trim" '*)))
+    (lambda (toplevel)
+      (func toplevel))))
+
+(define-public (fs-directory-scan-get-result* directory-scanner)
+  (let ((out (fs-directory-scan-get-result directory-scanner)))
+    (fs-share-tree-trim! out)
+    (pointer->bytestructure %fs-share-tree-item out)))
+
+(define-public (fs-share-tree-item-filename item)
+  (ffi:pointer->string (ffi:make-pointer (bytestructure-ref item 'filename))))
+
+(define-public (fs-share-tree-item-ksk-uri item)
+  (ffi:make-pointer (bytestructure-ref item 'ksk-uri)))
+
+(define-public (fs-share-tree-item-meta item)
+  (ffi:make-pointer (bytestructure-ref item 'meta)))
+
+(define %fs-block-options
+  (bs:struct `((expiration-time ,%time-relative)
+               (anonymity-level ,uint32)
+               (content-priority ,uint32)
+               (replication-level ,uint32))))
+
+(define-public (fs-block-options)
+  (let ((options (bytestructure %fs-block-options)))
+    (bytestructure-set! options 'expiration-time 'rel-value-us 0)
+    (bytestructure-set! options 'anonymity-level 1)
+    (bytestructure-set! options 'content-priority 365)
+    (bytestructure-set! options 'replication-level 1)
+    options))
+
+(define-public fs-file-information-create-from-file
+  (let ((func (fs '*
+                  "GNUNET_FS_file_information_create_from_file"
+                  '*
+                  '*
+                  '*
+                  '*
+                  '*
+                  ffi:int
+                  '*)))
+    (lambda (fs filename keywords meta do-index options)
+      (func fs
+            ffi:%null-pointer
+            (ffi:string->pointer filename)
+            keywords
+            meta
+            do-index
+            (bytestructure->pointer options)))))
+
 
 ;; gnunet-identity bindings