#!/usr/bin/guile -s
!#
+; Dolda Connect - Modular multiuser Direct Connect-style client
+; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
+;
+; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
(use-modules (dolcon ui))
(use-modules (ice-9 pretty-print))
(define trans '())
(define dpeers '())
(define lastdl 0)
+(define logport (current-output-port))
+(define infoport #f)
(define (logf fmt . msg)
- (apply format (cons* (current-output-port) (string-append fmt "\n") msg))
- (catch 'system-error (lambda ()
- (fsync (current-output-port)))
- (lambda (key . err) #f))
+ (if logport
+ (begin
+ (apply format (cons* logport (string-append fmt "\n") msg))
+ (catch 'system-error (lambda ()
+ (fsync logport))
+ (lambda (key . err) #f))))
+ )
+
+(define (infomsg fmt . msg)
+ (if infoport
+ (begin
+ (apply format (cons* infoport (string-append fmt "\n") msg))
+ (catch 'system-error (lambda ()
+ (fsync infoport))
+ (lambda (key . err) #f))))
)
(define (make-getopt opts optdesc)
(logf "downloading ~a from ~a, ~a bytes (id ~a, ~a slots), timing out in ~a seconds"
(cdr (assoc 'filename sr))
(cadr (cdr (assoc 'peer sr)))
- (number->string (cdr (assoc 'size sr)))
- (number->string id)
- (number->string (cdr (assoc 'slots sr)))
- (number->string (max 10 (* (cdr (assoc 'resptime sr)) 2))))))
+ (cdr (assoc 'size sr))
+ id
+ (cdr (assoc 'slots sr))
+ (max 10 (* (cdr (assoc 'resptime sr)) 2)))
+ (infomsg "dl ~a ~a" (cdr (assoc 'size sr)) id)))
(set! lastdl (current-time))
)
(if (and (memq (cdr (assoc 'state (cdr o))) '(wait hs))
(> (- time (cdr (assoc 'lastprog (cdr o)))) (max 10 (* (cdr (assoc 'resptime (cdr o))) 2))))
(begin (logf "transfer ~a timing out" (car o))
+ (infomsg "dlstop ~a timeout" (car o))
(dc-ecmd-assert 200 "cancel" (car o))
(disablepeer (cdr (assoc 'peer (cdr o))))
(set! trans (assq-remove! trans (car o)))
(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
(> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
(begin (logf "transfer ~a seems to have stalled" (car o))
+ (infomsg "dlstop ~a stall" (car o))
(dc-ecmd-assert 200 "cancel" (car o))
(set! trans (assq-remove! trans (car o)))
(write-info-file)))
(> (- (or (cdr (assoc 'speed sr)) (defspeed sr)) (cdr (assoc 'curspeed tr))) 10000))
(begin (logf "abandoning transfer ~a for possible faster sender"
(cdr (assoc 'id tr)))
+ (infomsg "dlstop ~a tryother" (cdr (assoc 'id tr)))
(dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
(set! trans (assq-remove! trans (cdr (assoc 'id tr))))
(download sr)))))))))
(set! info-numavail numavail)
(set! info-numreal numreal)
(set! info-numtotal numtotal)
+ (infomsg "srs ~a ~a ~a" numtotal numreal numavail)
(write-info-file)
retval)
)
(define (handlesr filename fnet peer size slots resptime hash)
(if (eq? (cdr (assoc 'search-mode session)) 'wait)
(begin (set-cdr! (assoc 'search-mode session) 'normal)
- (logf "reverting to normal mode")))
+ (logf "reverting to normal mode")
+ (infomsg "searchmode normal")))
(let ((cl (or (assoc size sr)
(let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
(newsr (list
(define (autodl-main args)
(let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
- (let ((getopt (make-getopt (cdr args) "whs:S:e:p:t:a:I:E:x:")) (arg #f))
+ (let ((getopt (make-getopt (cdr args) "whis:S:e:p:t:a:I:E:x:")) (arg #f))
(do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
(cond ((eq? (car arg) #\h)
(begin (display "usage: autodl [-s server] -S sessfile\n" (current-error-port))
(let ((c (assoc 'info-file session)))
(if c (set-cdr! c (cdr arg))
(set! session (cons (cons 'info-file (cdr arg)) session)))))
+ ((eq? (car arg) #\i)
+ (set! infoport logport)
+ (set! logport #f))
((eq? (car arg) #\E)
(let ((c (assoc 'estat-file session)))
(if c (set-cdr! c (cdr arg))
(if (not (assoc 'search-mode session))
(set! session (cons '(search-mode . normal) session)))
(if (not (validate-session session)) (begin (display "Invalid session!\n" (current-error-port)) (exit 1)))
- (if (not dc-server) (set! dc-server (getenv "DCSERVER")))
- (if (not dc-server) (set! dc-server "localhost"))
(catch 'system-error
(lambda ()
- (dc-c&l #t dc-server #t))
+ (dc-c&l #f dc-server #t))
(lambda (key . args)
(logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
(exit 2)))
((200)
(begin (set! srchid (car ires))
(logf "search scheduled in ~a seconds (id ~a)"
- (number->string (cadr ires))
- (number->string srchid))
+ (cadr ires)
+ srchid)
+ (infomsg "search pending ~a" (cadr ires))
(set! info-searcheta (+ (current-time) (cadr ires)))
(set! lastsearch -1)
(write-info-file)))
((501)
(begin (set! srchid -1)
(logf "no fnetnodes available to search on")
+ (infomsg "nofns")
(set! lastsearch (current-time))))
((509)
(begin (logf "illegal search expression")
(let ((ires (dc-intresp resp)))
(if (and ires (assoc (car ires) trans))
(begin (logf "transfer ~a encountered error ~a" (car ires) (cadr ires))
+ (infomsg "dlstop ~a error ~a" (car ires) (cadr ires))
(dc-ecmd-assert 200 "cancel" (car ires))
(let ((tr (cdr (assoc (car ires) trans))))
(disablepeer (cdr (assoc 'peer tr))))
(if tr
(begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
(begin (logf "transfer ~a done (~a)" (car ires) (cadr ires))
+ (infomsg "dldone ~a" (car ires))
+ (infomsg "estat ~a" (cadr ires))
(set! trans (assq-remove! trans (car ires)))
(set! done #t)
(set! filterexit (cadr ires))
(throw 'sig 0))
(begin (logf "transfer ~a disappeared" (car ires))
+ (infomsg "dlstop ~a gone" (car ires))
(set! trans (assq-remove! trans (car ires)))))))))
((620) ; Search rescheduled
(let ((ires (dc-intresp resp)))
(if (and ires (= (car ires) srchid))
(begin (set! info-searcheta (+ (current-time) (cadr ires)))
(logf "search rescheduled to T+~a" (cadr ires))
+ (infomsg "search pending ~a" (cadr ires))
(write-info-file)))))
((621) ; Search committed
(let ((ires (dc-intresp resp)))
(if (and ires (= (car ires) srchid))
(begin (logf "search committed")
+ (infomsg "search commit")
(set! info-searcheta 0)
(set! lastsearch (current-time))
(write-info-file)))))
Dolda2000 GitWeb / doldaconnect.git / blobdiff