gnunet/examples/publish.scm

#!/usr/bin/guile \
-e (@\ (gnunet-publish)\ main) -L . -s
!#
;;;; Copyright © 2015 Rémi Delrue <asgeir@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-publish)
  #:use-module (ice-9 match)
  #:use-module (system foreign)
  #:use-module (gnu gnunet common)
  #: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)
  #:use-module (gnu gnunet identity)
  #:export     (main))

(define config-file "~/.gnunet/gnunet.conf")

(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 (main args)
  "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)))))