diff options
Diffstat (limited to 'src/fs/gnunet-download-manager.scm')
| -rwxr-xr-x | src/fs/gnunet-download-manager.scm | 407 |
1 files changed, 407 insertions, 0 deletions
diff --git a/src/fs/gnunet-download-manager.scm b/src/fs/gnunet-download-manager.scm new file mode 100755 index 0000000..80d04fa --- /dev/null +++ b/src/fs/gnunet-download-manager.scm @@ -0,0 +1,407 @@ +#!/bin/sh +exec guile -e main -s "$0" "$@" +!# + +;;; gnunet-download-manager -- Manage GNUnet downloads. +;;; Copyright (C) 2004 Ludovic Courtès +;;; +;;; 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 2 +;;; 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, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Remember ongoing GNUnet downloads so as to be able to resume them +;;; later. Typical usage is to define the following alias in your +;;; favorite shell: +;;; +;;; alias gnunet-download='gnunet-download-manager.scm download' +;;; +;;; You may have a ~/.gnunet-download-manager.scm Scheme configuration +;;; file. In particular, if you would like to be notified of +;;; completed downloads, you may want to add the following line to +;;; your configuration file: +;;; +;;; (add-hook! *completed-download-hook* +;;; completed-download-notification-hook) +;;; +;;; This script works fine with GNU Guile 1.6.4, and doesn't run with +;;; Guile 1.4.x. +;;; +;;; Enjoy! +;;; Ludovic Courtès <ludo@chbouib.org> + +(use-modules (ice-9 format) + (ice-9 optargs) + (ice-9 regex) + (ice-9 and-let-star) + (ice-9 pretty-print) + (ice-9 documentation)) + +;; Overall user settings +(define *debug?* #f) +(define *rc-file* (string-append (getenv "HOME") + "/.gnunet-download-manager.scm")) +(define *status-directory* (string-append (getenv "HOME") "/" + ".gnunet-download-manager")) +(define *gnunet-download* "gnunet-download") + +;; Helper macros +(define-macro (gnunet-info fmt . args) + `(format #t (string-append *program-name* ": " ,fmt "~%") + ,@args)) + +(define-macro (gnunet-debug fmt . args) + (if *debug?* + (cons 'gnunet-info (cons fmt args)) + #t)) + +(define-macro (gnunet-error fmt . args) + `(and ,(cons 'gnunet-info (cons fmt args)) + (exit 1))) + +(define (exception-string key args) + "Describe an error, using the format from @var{args}, if available." + (if (< (length args) 4) + (format #f "Scheme exception: ~S" key) + (string-append + (if (string? (car args)) + (string-append "In " (car args)) + "Scheme exception") + ": " + (apply format `(#f ,(cadr args) ,@(caddr args)))))) + + +;; Regexps matching GNUnet URIs +(define *uri-base* + "([[:alnum:]]+)\.([[:alnum:]]+)\.([[:alnum:]]+)\.([0-9]+)") +(define *uri-re* + (make-regexp (string-append "^gnunet://afs/" *uri-base* "$") + regexp/extended)) +(define *uri-status-file-re* + (make-regexp (string-append "^" *uri-base* "$") + regexp/extended)) + + +(define (uri-status-file-name directory uri) + "Return the name of the status file for URI @var{uri}." + (let ((match (regexp-exec *uri-re* uri))) + (if (not match) + (and (gnunet-info "~a: Invalid URI" uri) #f) + (let ((start (match:start match 1)) + (end (match:end match 4))) + (string-append directory "/" + (substring uri start end)))))) + +(define (uri-status directory uri) + "Load the current status alist for URI @var{uri} from @var{directory}." + (gnunet-debug "uri-status") + (let ((filename (uri-status-file-name directory uri))) + (catch 'system-error + (lambda () + (let* ((file (open-input-file filename)) + (status (read file))) + (begin + (close-port file) + status))) + (lambda (key . args) + (and (gnunet-debug (exception-string key args)) + '()))))) + +(define (process-exists? pid) + (false-if-exception (begin (kill pid 0) #t))) + +(define (fork-and-exec directory program . args) + "Launch @var{program} and return its PID." + (gnunet-debug "fork-and-exec: ~a ~a" program args) + (let ((pid (primitive-fork))) + (if (= 0 pid) + (begin + (if directory (chdir directory)) + (apply execlp (cons program (cons program args)))) + pid))) + +(define* (start-downloader downloader uri options + #:key (directory #f)) + "Start the GNUnet downloader for URI @var{uri} with options +@var{options}. Return an alist describing the download status." + (catch 'system-error + (lambda () + (let* ((pid (apply fork-and-exec + `(,(if directory directory (getcwd)) + ,downloader + ,@options)))) + (gnunet-info "Launched process ~a" pid) + `((uri . ,uri) + (working-directory . ,(if directory directory (getcwd))) + (options . ,options) + (pid . ,(getpid)) + (downloader-pid . ,pid)))) + (lambda (key . args) + (gnunet-error (exception-string key args))))) + +(define (download-process-alive? uri-status) + "Return true if the download whose status is that described by +@var{uri-status} is still alive." + (let ((pid (assoc-ref uri-status 'pid)) + (downloader-pid (assoc-ref uri-status 'downloader-pid))) + (and (process-exists? pid) + (process-exists? downloader-pid)))) + +(define (start-file-download downloader status-dir uri options) + "Dowload the file located at @var{uri}, with options @var{options} +and return an updated status alist." + (gnunet-debug "start-file-download") + (let ((uri-status (uri-status status-dir uri))) + (if (null? uri-status) + (acons 'start-date (current-time) + (start-downloader downloader uri options)) + (if (download-process-alive? uri-status) + (and (gnunet-info "~a already being downloaded by process ~a" + uri (assoc-ref uri-status 'pid)) + #f) + (and (gnunet-info "Resuming download") + (let ((start-date (assoc-ref uri-status 'start-date)) + (dir (assoc-ref uri-status 'working-directory)) + (options (assoc-ref uri-status 'options))) + (acons 'start-date start-date + (start-downloader downloader uri options + #:directory dir)))))))) + +(define *completed-download-hook* (make-hook 1)) + +(define (download-file downloader status-dir uri options) + "Start downloading file located at URI @var{uri}, with options +@var{options}, resuming it if it's already started." + (catch 'system-error + (lambda () + (and-let* ((status (start-file-download downloader + status-dir + uri options)) + (pid (assoc-ref status 'downloader-pid)) + (filename (uri-status-file-name status-dir + uri)) + (file (open-file filename "w"))) + + ;; Write down the status + (pretty-print status file) + (close-port file) + + ;; Wait for `gnunet-download' + (gnunet-info "Waiting for process ~a" pid) + (let* ((process-status (waitpid pid)) + (exit-val (status:exit-val (cdr process-status))) + (term-sig (status:term-sig (cdr process-status)))) + + ;; Terminate + (delete-file filename) + (gnunet-info + "Download completed (PID ~a, exit code ~a)" + pid exit-val) + (let ((ret `((end-date . ,(current-time)) + (exit-code . ,exit-val) + (terminating-signal . ,term-sig) + ,@status))) + (run-hook *completed-download-hook* ret) + ret)))) + (lambda (key . args) + (gnunet-error (exception-string key args))))) + +(define (uri-status-files directory) + "Return the list of URI status files in @var{directory}." + (catch 'system-error + (lambda () + (let ((dir (opendir directory))) + (let loop ((filename (readdir dir)) + (file-list '())) + (if (eof-object? filename) + file-list + (if (regexp-exec *uri-status-file-re* filename) + (loop (readdir dir) + (cons filename file-list)) + (loop (readdir dir) file-list)))))) + (lambda (key . args) + (gnunet-error (exception-string key args))))) + +(define (output-file-option option-list) + "Return the output file specified in @var{option-list}, false if +anavailable." + (if (null? option-list) + #f + (let ((rest (cdr option-list)) + (opt (car option-list))) + (if (null? rest) + #f + (if (or (string=? opt "-o") + (string=? opt "--output")) + (car rest) + (output-file-option rest)))))) + +(define (download-command . args) + "Start downloading a file using the given `gnunet-download' +arguments." + (gnunet-debug "download-command") + (let* ((argc (length args)) + ;; FIXME: We're assuming the URI is the last argument + (uri (car (list-tail args (- argc 1)))) + (options args)) + (download-file *gnunet-download* *status-directory* uri options))) + +(define (status-command . args) + "Print status info about files being downloaded." + (for-each (lambda (status) + (format #t "~a: ~a~% ~a~% ~a~% ~a~%" + (assoc-ref status 'uri) + (if (download-process-alive? status) + (string-append "running (PID " + (number->string (assoc-ref status + 'pid)) + ")") + "not running") + (string-append "Started on " + (strftime "%c" + (localtime (assoc-ref + status + 'start-date)))) + (string-append "Directory: " + (assoc-ref status + 'working-directory)) + (string-append "Output file: " + (or (output-file-option (assoc-ref + status + 'options)) + "<unknown>")))) + (map (lambda (file) + (uri-status *status-directory* + (string-append "gnunet://afs/" file))) + (uri-status-files *status-directory*)))) + +(define (resume-command . args) + "Resume stopped downloads." + (for-each (lambda (status) + (if (not (download-process-alive? status)) + (if (= 0 (primitive-fork)) + (let* ((ret (download-file *gnunet-download* + *status-directory* + (assoc-ref status 'uri) + (assoc-ref status 'options))) + (code (assoc-ref ret 'exit-code))) + (exit code))))) + (map (lambda (file) + (uri-status *status-directory* + (string-append "gnunet://afs/" file))) + (uri-status-files *status-directory*)))) + +(define (killall-command . args) + "Stop all running downloads." + (for-each (lambda (status) + (if (download-process-alive? status) + (let ((pid (assoc-ref status 'pid)) + (dl-pid (assoc-ref status 'downloader-pid))) + (and (gnunet-info "Stopping processes ~a and ~a" + pid dl-pid) + (kill pid 15) + (kill dl-pid 15))))) + (map (lambda (file) + (uri-status *status-directory* + (string-append "gnunet://afs/" file))) + (uri-status-files *status-directory*)))) + + +(define (help-command . args) + "Show this help message." + (format #t "Usage: ~a <command> [options]~%" *program-name*) + (format #t "Where <command> may be one of the following:~%~%") + (for-each (lambda (command) + (if (not (eq? (cdr command) help-command)) + (format #t (string-append " " (car command) ": " + (object-documentation + (cdr command)) + "~%")))) + *commands*) + (format #t "~%")) + +(define (settings-command . args) + "Dump the current settings." + (format #t "Current settings:~%~%") + (module-for-each (lambda (symbol variable) + (if (string-match "^\\*.*\\*$" (symbol->string symbol)) + (format #t " ~a: ~a~%" + symbol (variable-ref variable)))) + (current-module)) + (format #t "~%")) + +(define (version-command . args) + "Show version information." + (format #t "~a ~a.~a (~a)~%" + *program-name* *version-major* *version-minor* *version-date*)) + +;; This hook may be added to *completed-download-hook*. +(define (completed-download-notification-hook status) + "Notifies of the completion of a file download." + (let ((msg (string-append "GNUnet download of " + (output-file-option + (assoc-ref status 'options)) + " in " + (assoc-ref status + 'working-directory) + " complete!"))) + (if (getenv "DISPLAY") + (waitpid (fork-and-exec #f "xmessage" msg)) + (waitpid (fork-and-exec #f "write" + (cuserid) msg))))) + +;; Available user commands +(define *commands* + `(("download" . ,download-command) + ("status" . ,status-command) + ("resume" . ,resume-command) + ("killall" . ,killall-command) + ("settings" . ,settings-command) + ("version" . ,version-command) + ("help" . ,help-command) + ("--help" . ,help-command) + ("-h" . ,help-command))) + +(define *program-name* "gnunet-download-manager") +(define *version-major* 0) +(define *version-minor* 1) +(define *version-date* "april 2004") + +(define (main args) + (set! *program-name* (basename (car args))) + + ;; Load the user's configuration file + (if (file-exists? *rc-file*) + (load *rc-file*)) + + ;; Check whether the status directory already exists + (if (not (file-exists? *status-directory*)) + (begin + (gnunet-info "Creating status directory ~a..." *status-directory*) + (catch 'system-error + (lambda () + (mkdir *status-directory*)) + (lambda (key . args) + (and (gnunet-error (exception-string key args)) + (exit 1)))))) + + ;; Go ahead + (if (< (length args) 2) + (and (format #t "Usage: ~a <command> [options]~%" + *program-name*) + (exit 1)) + (let* ((command-name (cadr args)) + (command (assoc-ref *commands* command-name))) + (if command + (apply command (cddr args)) + (and (gnunet-info "~a command not found" command-name) + (exit 1))))))
\ No newline at end of file |