src/fs/gnunet-download-manager.scm

   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))))))