|
|
@@ -1,409 +0,0 @@
|
|
|
-#!/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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
|
|
-;;;
|
|
|
-;;; SPDX-License-Identifier: GPL-2.0-or-later
|
|
|
-
|
|
|
-;;; 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://fs/chk/" *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://fs/chk/" 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://fs/chk/" 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://fs/chk/" 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))))))
|
ng0