diff options
author | Christian Grothoff <christian@grothoff.org> | 2012-01-15 23:40:19 +0000 |
---|---|---|
committer | Christian Grothoff <christian@grothoff.org> | 2012-01-15 23:40:19 +0000 |
commit | b0c7119fa2f43fe1b5978651152974359de5a5d2 (patch) | |
tree | c7fb23eb78862397eed148e5cd9f1e93dd407227 | |
parent | 51bf4834f8eb50ce01231c6b2599000d65dd5202 (diff) | |
download | gnunet-b0c7119fa2f43fe1b5978651152974359de5a5d2.tar.gz gnunet-b0c7119fa2f43fe1b5978651152974359de5a5d2.zip |
adding Ludo's gnunet-download-manager.scm back to SVN HEAD
-rw-r--r-- | doc/man/Makefile.am | 1 | ||||
-rw-r--r-- | doc/man/gnunet-download-manager.1 | 24 | ||||
-rw-r--r-- | src/fs/Makefile.am | 3 | ||||
-rwxr-xr-x | src/fs/gnunet-download-manager.scm | 407 |
4 files changed, 435 insertions, 0 deletions
diff --git a/doc/man/Makefile.am b/doc/man/Makefile.am index 72611a2a3..6d98ffa5b 100644 --- a/doc/man/Makefile.am +++ b/doc/man/Makefile.am | |||
@@ -2,6 +2,7 @@ man_MANS = \ | |||
2 | gnunet-arm.1 \ | 2 | gnunet-arm.1 \ |
3 | gnunet-directory.1 \ | 3 | gnunet-directory.1 \ |
4 | gnunet-download.1 \ | 4 | gnunet-download.1 \ |
5 | gnunet-download-manager.1 \ | ||
5 | gnunet-fs.1 \ | 6 | gnunet-fs.1 \ |
6 | gnunet-nat-server.1 \ | 7 | gnunet-nat-server.1 \ |
7 | gnunet-peerinfo.1 \ | 8 | gnunet-peerinfo.1 \ |
diff --git a/doc/man/gnunet-download-manager.1 b/doc/man/gnunet-download-manager.1 new file mode 100644 index 000000000..844f81084 --- /dev/null +++ b/doc/man/gnunet-download-manager.1 | |||
@@ -0,0 +1,24 @@ | |||
1 | .TH GNUNET-DOWNLOAD-MANAGER 1 "15 Jan, 2011" "GNUnet" | ||
2 | |||
3 | .SH NAME | ||
4 | gnunet-download-manager \- manage downloads across sessions | ||
5 | |||
6 | .SH SYNOPSIS | ||
7 | .B gnunet\-download\-manager | ||
8 | .RI [ options ] | ||
9 | .br | ||
10 | |||
11 | .SH DESCRIPTION | ||
12 | \fBgnunet\-download\-manager\fP is a script that can be used to track download sessions. It makes the process of resuming downloads after a system reboot easier. A typical use is to define an alias (depending on your shell) of the form | ||
13 | |||
14 | $ alias gnunet\-download='gnunet\-download\-manager.scm download' | ||
15 | |||
16 | Other commands for the download manager include resume (resumes all downloads), status (show status of pending downloads), killall (abort all downloads), settings (for configuration) and help (print help text). | ||
17 | |||
18 | gnunet\-download\-manager is a scheme script and will only work if guile is available. | ||
19 | |||
20 | .SH BUGS | ||
21 | Report bugs by using mantis <https://gnunet.org/bugs/> or by sending electronic mail to <gnunet-developers@gnu.org> | ||
22 | |||
23 | .SH SEE ALSO | ||
24 | gnunet\-download(1) | ||
diff --git a/src/fs/Makefile.am b/src/fs/Makefile.am index 2a8a8c896..8e3013eb0 100644 --- a/src/fs/Makefile.am +++ b/src/fs/Makefile.am | |||
@@ -67,6 +67,9 @@ bin_PROGRAMS = \ | |||
67 | gnunet-fs \ | 67 | gnunet-fs \ |
68 | gnunet-unindex | 68 | gnunet-unindex |
69 | 69 | ||
70 | bin_SCRIPTS = \ | ||
71 | gnunet-download-manager.scm | ||
72 | |||
70 | gnunet_directory_SOURCES = \ | 73 | gnunet_directory_SOURCES = \ |
71 | gnunet-directory.c | 74 | gnunet-directory.c |
72 | gnunet_directory_LDADD = \ | 75 | gnunet_directory_LDADD = \ |
diff --git a/src/fs/gnunet-download-manager.scm b/src/fs/gnunet-download-manager.scm new file mode 100755 index 000000000..80d04fa12 --- /dev/null +++ b/src/fs/gnunet-download-manager.scm | |||
@@ -0,0 +1,407 @@ | |||
1 | #!/bin/sh | ||
2 | exec guile -e main -s "$0" "$@" | ||
3 | !# | ||
4 | |||
5 | ;;; gnunet-download-manager -- Manage GNUnet downloads. | ||
6 | ;;; Copyright (C) 2004 Ludovic Courtès | ||
7 | ;;; | ||
8 | ;;; This program is free software; you can redistribute it and/or | ||
9 | ;;; modify it under the terms of the GNU General Public License | ||
10 | ;;; as published by the Free Software Foundation; either version 2 | ||
11 | ;;; of the License, or (at your option) any later version. | ||
12 | ;;; | ||
13 | ;;; This program is distributed in the hope that it will be useful, | ||
14 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
16 | ;;; GNU General Public License for more details. | ||
17 | ;;; | ||
18 | ;;; You should have received a copy of the GNU General Public License | ||
19 | ;;; along with this program; if not, write to the Free Software | ||
20 | ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. | ||
21 | |||
22 | ;;; Remember ongoing GNUnet downloads so as to be able to resume them | ||
23 | ;;; later. Typical usage is to define the following alias in your | ||
24 | ;;; favorite shell: | ||
25 | ;;; | ||
26 | ;;; alias gnunet-download='gnunet-download-manager.scm download' | ||
27 | ;;; | ||
28 | ;;; You may have a ~/.gnunet-download-manager.scm Scheme configuration | ||
29 | ;;; file. In particular, if you would like to be notified of | ||
30 | ;;; completed downloads, you may want to add the following line to | ||
31 | ;;; your configuration file: | ||
32 | ;;; | ||
33 | ;;; (add-hook! *completed-download-hook* | ||
34 | ;;; completed-download-notification-hook) | ||
35 | ;;; | ||
36 | ;;; This script works fine with GNU Guile 1.6.4, and doesn't run with | ||
37 | ;;; Guile 1.4.x. | ||
38 | ;;; | ||
39 | ;;; Enjoy! | ||
40 | ;;; Ludovic Courtès <ludo@chbouib.org> | ||
41 | |||
42 | (use-modules (ice-9 format) | ||
43 | (ice-9 optargs) | ||
44 | (ice-9 regex) | ||
45 | (ice-9 and-let-star) | ||
46 | (ice-9 pretty-print) | ||
47 | (ice-9 documentation)) | ||
48 | |||
49 | ;; Overall user settings | ||
50 | (define *debug?* #f) | ||
51 | (define *rc-file* (string-append (getenv "HOME") | ||
52 | "/.gnunet-download-manager.scm")) | ||
53 | (define *status-directory* (string-append (getenv "HOME") "/" | ||
54 | ".gnunet-download-manager")) | ||
55 | (define *gnunet-download* "gnunet-download") | ||
56 | |||
57 | ;; Helper macros | ||
58 | (define-macro (gnunet-info fmt . args) | ||
59 | `(format #t (string-append *program-name* ": " ,fmt "~%") | ||
60 | ,@args)) | ||
61 | |||
62 | (define-macro (gnunet-debug fmt . args) | ||
63 | (if *debug?* | ||
64 | (cons 'gnunet-info (cons fmt args)) | ||
65 | #t)) | ||
66 | |||
67 | (define-macro (gnunet-error fmt . args) | ||
68 | `(and ,(cons 'gnunet-info (cons fmt args)) | ||
69 | (exit 1))) | ||
70 | |||
71 | (define (exception-string key args) | ||
72 | "Describe an error, using the format from @var{args}, if available." | ||
73 | (if (< (length args) 4) | ||
74 | (format #f "Scheme exception: ~S" key) | ||
75 | (string-append | ||
76 | (if (string? (car args)) | ||
77 | (string-append "In " (car args)) | ||
78 | "Scheme exception") | ||
79 | ": " | ||
80 | (apply format `(#f ,(cadr args) ,@(caddr args)))))) | ||
81 | |||
82 | |||
83 | ;; Regexps matching GNUnet URIs | ||
84 | (define *uri-base* | ||
85 | "([[:alnum:]]+)\.([[:alnum:]]+)\.([[:alnum:]]+)\.([0-9]+)") | ||
86 | (define *uri-re* | ||
87 | (make-regexp (string-append "^gnunet://afs/" *uri-base* "$") | ||
88 | regexp/extended)) | ||
89 | (define *uri-status-file-re* | ||
90 | (make-regexp (string-append "^" *uri-base* "$") | ||
91 | regexp/extended)) | ||
92 | |||
93 | |||
94 | (define (uri-status-file-name directory uri) | ||
95 | "Return the name of the status file for URI @var{uri}." | ||
96 | (let ((match (regexp-exec *uri-re* uri))) | ||
97 | (if (not match) | ||
98 | (and (gnunet-info "~a: Invalid URI" uri) #f) | ||
99 | (let ((start (match:start match 1)) | ||
100 | (end (match:end match 4))) | ||
101 | (string-append directory "/" | ||
102 | (substring uri start end)))))) | ||
103 | |||
104 | (define (uri-status directory uri) | ||
105 | "Load the current status alist for URI @var{uri} from @var{directory}." | ||
106 | (gnunet-debug "uri-status") | ||
107 | (let ((filename (uri-status-file-name directory uri))) | ||
108 | (catch 'system-error | ||
109 | (lambda () | ||
110 | (let* ((file (open-input-file filename)) | ||
111 | (status (read file))) | ||
112 | (begin | ||
113 | (close-port file) | ||
114 | status))) | ||
115 | (lambda (key . args) | ||
116 | (and (gnunet-debug (exception-string key args)) | ||
117 | '()))))) | ||
118 | |||
119 | (define (process-exists? pid) | ||
120 | (false-if-exception (begin (kill pid 0) #t))) | ||
121 | |||
122 | (define (fork-and-exec directory program . args) | ||
123 | "Launch @var{program} and return its PID." | ||
124 | (gnunet-debug "fork-and-exec: ~a ~a" program args) | ||
125 | (let ((pid (primitive-fork))) | ||
126 | (if (= 0 pid) | ||
127 | (begin | ||
128 | (if directory (chdir directory)) | ||
129 | (apply execlp (cons program (cons program args)))) | ||
130 | pid))) | ||
131 | |||
132 | (define* (start-downloader downloader uri options | ||
133 | #:key (directory #f)) | ||
134 | "Start the GNUnet downloader for URI @var{uri} with options | ||
135 | @var{options}. Return an alist describing the download status." | ||
136 | (catch 'system-error | ||
137 | (lambda () | ||
138 | (let* ((pid (apply fork-and-exec | ||
139 | `(,(if directory directory (getcwd)) | ||
140 | ,downloader | ||
141 | ,@options)))) | ||
142 | (gnunet-info "Launched process ~a" pid) | ||
143 | `((uri . ,uri) | ||
144 | (working-directory . ,(if directory directory (getcwd))) | ||
145 | (options . ,options) | ||
146 | (pid . ,(getpid)) | ||
147 | (downloader-pid . ,pid)))) | ||
148 | (lambda (key . args) | ||
149 | (gnunet-error (exception-string key args))))) | ||
150 | |||
151 | (define (download-process-alive? uri-status) | ||
152 | "Return true if the download whose status is that described by | ||
153 | @var{uri-status} is still alive." | ||
154 | (let ((pid (assoc-ref uri-status 'pid)) | ||
155 | (downloader-pid (assoc-ref uri-status 'downloader-pid))) | ||
156 | (and (process-exists? pid) | ||
157 | (process-exists? downloader-pid)))) | ||
158 | |||
159 | (define (start-file-download downloader status-dir uri options) | ||
160 | "Dowload the file located at @var{uri}, with options @var{options} | ||
161 | and return an updated status alist." | ||
162 | (gnunet-debug "start-file-download") | ||
163 | (let ((uri-status (uri-status status-dir uri))) | ||
164 | (if (null? uri-status) | ||
165 | (acons 'start-date (current-time) | ||
166 | (start-downloader downloader uri options)) | ||
167 | (if (download-process-alive? uri-status) | ||
168 | (and (gnunet-info "~a already being downloaded by process ~a" | ||
169 | uri (assoc-ref uri-status 'pid)) | ||
170 | #f) | ||
171 | (and (gnunet-info "Resuming download") | ||
172 | (let ((start-date (assoc-ref uri-status 'start-date)) | ||
173 | (dir (assoc-ref uri-status 'working-directory)) | ||
174 | (options (assoc-ref uri-status 'options))) | ||
175 | (acons 'start-date start-date | ||
176 | (start-downloader downloader uri options | ||
177 | #:directory dir)))))))) | ||
178 | |||
179 | (define *completed-download-hook* (make-hook 1)) | ||
180 | |||
181 | (define (download-file downloader status-dir uri options) | ||
182 | "Start downloading file located at URI @var{uri}, with options | ||
183 | @var{options}, resuming it if it's already started." | ||
184 | (catch 'system-error | ||
185 | (lambda () | ||
186 | (and-let* ((status (start-file-download downloader | ||
187 | status-dir | ||
188 | uri options)) | ||
189 | (pid (assoc-ref status 'downloader-pid)) | ||
190 | (filename (uri-status-file-name status-dir | ||
191 | uri)) | ||
192 | (file (open-file filename "w"))) | ||
193 | |||
194 | ;; Write down the status | ||
195 | (pretty-print status file) | ||
196 | (close-port file) | ||
197 | |||
198 | ;; Wait for `gnunet-download' | ||
199 | (gnunet-info "Waiting for process ~a" pid) | ||
200 | (let* ((process-status (waitpid pid)) | ||
201 | (exit-val (status:exit-val (cdr process-status))) | ||
202 | (term-sig (status:term-sig (cdr process-status)))) | ||
203 | |||
204 | ;; Terminate | ||
205 | (delete-file filename) | ||
206 | (gnunet-info | ||
207 | "Download completed (PID ~a, exit code ~a)" | ||
208 | pid exit-val) | ||
209 | (let ((ret `((end-date . ,(current-time)) | ||
210 | (exit-code . ,exit-val) | ||
211 | (terminating-signal . ,term-sig) | ||
212 | ,@status))) | ||
213 | (run-hook *completed-download-hook* ret) | ||
214 | ret)))) | ||
215 | (lambda (key . args) | ||
216 | (gnunet-error (exception-string key args))))) | ||
217 | |||
218 | (define (uri-status-files directory) | ||
219 | "Return the list of URI status files in @var{directory}." | ||
220 | (catch 'system-error | ||
221 | (lambda () | ||
222 | (let ((dir (opendir directory))) | ||
223 | (let loop ((filename (readdir dir)) | ||
224 | (file-list '())) | ||
225 | (if (eof-object? filename) | ||
226 | file-list | ||
227 | (if (regexp-exec *uri-status-file-re* filename) | ||
228 | (loop (readdir dir) | ||
229 | (cons filename file-list)) | ||
230 | (loop (readdir dir) file-list)))))) | ||
231 | (lambda (key . args) | ||
232 | (gnunet-error (exception-string key args))))) | ||
233 | |||
234 | (define (output-file-option option-list) | ||
235 | "Return the output file specified in @var{option-list}, false if | ||
236 | anavailable." | ||
237 | (if (null? option-list) | ||
238 | #f | ||
239 | (let ((rest (cdr option-list)) | ||
240 | (opt (car option-list))) | ||
241 | (if (null? rest) | ||
242 | #f | ||
243 | (if (or (string=? opt "-o") | ||
244 | (string=? opt "--output")) | ||
245 | (car rest) | ||
246 | (output-file-option rest)))))) | ||
247 | |||
248 | (define (download-command . args) | ||
249 | "Start downloading a file using the given `gnunet-download' | ||
250 | arguments." | ||
251 | (gnunet-debug "download-command") | ||
252 | (let* ((argc (length args)) | ||
253 | ;; FIXME: We're assuming the URI is the last argument | ||
254 | (uri (car (list-tail args (- argc 1)))) | ||
255 | (options args)) | ||
256 | (download-file *gnunet-download* *status-directory* uri options))) | ||
257 | |||
258 | (define (status-command . args) | ||
259 | "Print status info about files being downloaded." | ||
260 | (for-each (lambda (status) | ||
261 | (format #t "~a: ~a~% ~a~% ~a~% ~a~%" | ||
262 | (assoc-ref status 'uri) | ||
263 | (if (download-process-alive? status) | ||
264 | (string-append "running (PID " | ||
265 | (number->string (assoc-ref status | ||
266 | 'pid)) | ||
267 | ")") | ||
268 | "not running") | ||
269 | (string-append "Started on " | ||
270 | (strftime "%c" | ||
271 | (localtime (assoc-ref | ||
272 | status | ||
273 | 'start-date)))) | ||
274 | (string-append "Directory: " | ||
275 | (assoc-ref status | ||
276 | 'working-directory)) | ||
277 | (string-append "Output file: " | ||
278 | (or (output-file-option (assoc-ref | ||
279 | status | ||
280 | 'options)) | ||
281 | "<unknown>")))) | ||
282 | (map (lambda (file) | ||
283 | (uri-status *status-directory* | ||
284 | (string-append "gnunet://afs/" file))) | ||
285 | (uri-status-files *status-directory*)))) | ||
286 | |||
287 | (define (resume-command . args) | ||
288 | "Resume stopped downloads." | ||
289 | (for-each (lambda (status) | ||
290 | (if (not (download-process-alive? status)) | ||
291 | (if (= 0 (primitive-fork)) | ||
292 | (let* ((ret (download-file *gnunet-download* | ||
293 | *status-directory* | ||
294 | (assoc-ref status 'uri) | ||
295 | (assoc-ref status 'options))) | ||
296 | (code (assoc-ref ret 'exit-code))) | ||
297 | (exit code))))) | ||
298 | (map (lambda (file) | ||
299 | (uri-status *status-directory* | ||
300 | (string-append "gnunet://afs/" file))) | ||
301 | (uri-status-files *status-directory*)))) | ||
302 | |||
303 | (define (killall-command . args) | ||
304 | "Stop all running downloads." | ||
305 | (for-each (lambda (status) | ||
306 | (if (download-process-alive? status) | ||
307 | (let ((pid (assoc-ref status 'pid)) | ||
308 | (dl-pid (assoc-ref status 'downloader-pid))) | ||
309 | (and (gnunet-info "Stopping processes ~a and ~a" | ||
310 | pid dl-pid) | ||
311 | (kill pid 15) | ||
312 | (kill dl-pid 15))))) | ||
313 | (map (lambda (file) | ||
314 | (uri-status *status-directory* | ||
315 | (string-append "gnunet://afs/" file))) | ||
316 | (uri-status-files *status-directory*)))) | ||
317 | |||
318 | |||
319 | (define (help-command . args) | ||
320 | "Show this help message." | ||
321 | (format #t "Usage: ~a <command> [options]~%" *program-name*) | ||
322 | (format #t "Where <command> may be one of the following:~%~%") | ||
323 | (for-each (lambda (command) | ||
324 | (if (not (eq? (cdr command) help-command)) | ||
325 | (format #t (string-append " " (car command) ": " | ||
326 | (object-documentation | ||
327 | (cdr command)) | ||
328 | "~%")))) | ||
329 | *commands*) | ||
330 | (format #t "~%")) | ||
331 | |||
332 | (define (settings-command . args) | ||
333 | "Dump the current settings." | ||
334 | (format #t "Current settings:~%~%") | ||
335 | (module-for-each (lambda (symbol variable) | ||
336 | (if (string-match "^\\*.*\\*$" (symbol->string symbol)) | ||
337 | (format #t " ~a: ~a~%" | ||
338 | symbol (variable-ref variable)))) | ||
339 | (current-module)) | ||
340 | (format #t "~%")) | ||
341 | |||
342 | (define (version-command . args) | ||
343 | "Show version information." | ||
344 | (format #t "~a ~a.~a (~a)~%" | ||
345 | *program-name* *version-major* *version-minor* *version-date*)) | ||
346 | |||
347 | ;; This hook may be added to *completed-download-hook*. | ||
348 | (define (completed-download-notification-hook status) | ||
349 | "Notifies of the completion of a file download." | ||
350 | (let ((msg (string-append "GNUnet download of " | ||
351 | (output-file-option | ||
352 | (assoc-ref status 'options)) | ||
353 | " in " | ||
354 | (assoc-ref status | ||
355 | 'working-directory) | ||
356 | " complete!"))) | ||
357 | (if (getenv "DISPLAY") | ||
358 | (waitpid (fork-and-exec #f "xmessage" msg)) | ||
359 | (waitpid (fork-and-exec #f "write" | ||
360 | (cuserid) msg))))) | ||
361 | |||
362 | ;; Available user commands | ||
363 | (define *commands* | ||
364 | `(("download" . ,download-command) | ||
365 | ("status" . ,status-command) | ||
366 | ("resume" . ,resume-command) | ||
367 | ("killall" . ,killall-command) | ||
368 | ("settings" . ,settings-command) | ||
369 | ("version" . ,version-command) | ||
370 | ("help" . ,help-command) | ||
371 | ("--help" . ,help-command) | ||
372 | ("-h" . ,help-command))) | ||
373 | |||
374 | (define *program-name* "gnunet-download-manager") | ||
375 | (define *version-major* 0) | ||
376 | (define *version-minor* 1) | ||
377 | (define *version-date* "april 2004") | ||
378 | |||
379 | (define (main args) | ||
380 | (set! *program-name* (basename (car args))) | ||
381 | |||
382 | ;; Load the user's configuration file | ||
383 | (if (file-exists? *rc-file*) | ||
384 | (load *rc-file*)) | ||
385 | |||
386 | ;; Check whether the status directory already exists | ||
387 | (if (not (file-exists? *status-directory*)) | ||
388 | (begin | ||
389 | (gnunet-info "Creating status directory ~a..." *status-directory*) | ||
390 | (catch 'system-error | ||
391 | (lambda () | ||
392 | (mkdir *status-directory*)) | ||
393 | (lambda (key . args) | ||
394 | (and (gnunet-error (exception-string key args)) | ||
395 | (exit 1)))))) | ||
396 | |||
397 | ;; Go ahead | ||
398 | (if (< (length args) 2) | ||
399 | (and (format #t "Usage: ~a <command> [options]~%" | ||
400 | *program-name*) | ||
401 | (exit 1)) | ||
402 | (let* ((command-name (cadr args)) | ||
403 | (command (assoc-ref *commands* command-name))) | ||
404 | (if command | ||
405 | (apply command (cddr args)) | ||
406 | (and (gnunet-info "~a command not found" command-name) | ||
407 | (exit 1)))))) \ No newline at end of file | ||