#!/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)
+ (if logport
+ (begin
+ (apply format (cons* logport (string-append fmt "\n") msg))
+ (catch 'system-error (lambda ()
+ (fsync logport))
+ (lambda (key . err) #f))))
+ )
-(define (logf msg)
- (write-line msg (current-output-port))
- (catch 'system-error (lambda ()
- (fsync (current-output-port)))
- (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)
(define (wanttosearch)
(> (- (current-time) lastsearch)
- (if (> (length trans) 0) 300 60))
+ (if (eq? (cdr (assoc 'search-mode session)) 'wait)
+ 7200
+ (if (> (length trans) 0) 300 60)))
)
(define defspeed '())
(cadr (cdr (assoc 'peer sr)))
(cdr (assoc 'filename sr))
(cdr (assoc 'size sr)))))
+ (let ((hash (assoc 'hash sr)))
+ (if (and hash (not (equal? (cdr hash) ""))) (set! args (append args (list "hash" (cdr hash))))))
(let ((tag (assoc 'tag session)))
(if tag (set! args (append args (list "tag" (cdr tag))))))
(let ((uarg (assoc 'uarg session)))
(if uarg (set! args (append args (list "user" (cdr uarg))))))
+ (let ((xargs (assoc 'xargs session)))
+ (if xargs (for-each (lambda (o)
+ (set! args (append args (list (car o) (cdr o)))))
+ (cdr xargs))))
(set! resp (apply dc-ecmd-assert 200 args)))
(let ((id (car (dc-intresp resp))))
(set! trans
(cons 'lasttime (current-time))
(cons 'lastprog (current-time))))
trans))
- (logf (string-append "downloading "
- (cdr (assoc 'filename sr))
- " from "
- (cadr (cdr (assoc 'peer sr)))
- ", "
- (number->string (cdr (assoc 'size sr)))
- " bytes (id "
- (number->string id)
- ", "
- (number->string (cdr (assoc 'slots sr)))
- " slots), timing out in "
- (number->string (max 10 (* (cdr (assoc 'resptime sr)) 2)))
- " seconds"))))
+ (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)))
+ (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))
)
(set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
sr)
(set! sr (sort newglist srg-less?))
- (logf (string-append "disabled " (cadr peer) " and removed " (number->string numrem) " search results")))
+ (logf "disabled ~a and removed ~a search results" (cadr peer) numrem))
(let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
(if dp
(set-cdr! (assoc 'time dp) (current-time))
(for-each (lambda (o)
(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 (string-append "transfer " (number->string (car o)) " timing out"))
+ (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)))))
+ (set! trans (assq-remove! trans (car o)))
+ (write-info-file)))
(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
(> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
- (begin (logf (string-append "transfer " (number->string (car o)) " seems to have stalled"))
+ (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)))))
+ (set! trans (assq-remove! trans (car o)))
+ (write-info-file)))
(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
(> (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o)))) 20))
(begin (set-cdr! (assoc 'curspeed (cdr o))
(/ (- (cdr (assoc 'curpos (cdr o))) (cdr (assoc 'lastpos (cdr o))))
(- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o))))))
(set-cdr! (assoc 'lastpos (cdr o)) (cdr (assoc 'curpos (cdr o))))
- (set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o)))))))
+ (set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o))))
+ (write-info-file))))
trans))
)
(define (write-info-file)
(if (assoc 'info-file session)
(let ((op (open-output-file (cdr (assoc 'info-file session)))))
- (write (list (cons 'numdl (length trans))
- (cons 'lastdl lastdl)
- (cons 'availsr info-numavail)
- (cons 'realsr info-numreal)
- (cons 'totalsr info-numtotal)
- (cons 'lastsrch lastsearch)
- (cons 'srcheta info-searcheta))
- op)
- (newline op)
+ (pretty-print (list (cons 'numdl (length trans))
+ (cons 'lastdl lastdl)
+ (cons 'availsr info-numavail)
+ (cons 'realsr info-numreal)
+ (cons 'totalsr info-numtotal)
+ (cons 'lastsrch lastsearch)
+ (cons 'srcheta info-searcheta)
+ (cons 'srchmode (cdr (assoc 'search-mode session))))
+ op)
(close-port op))))
(define (parseresults)
- (logf (string-append "entering parseresults with "
- (number->string
- (apply + (map (lambda (o) (length (cdr o))) sr)))
- " results in "
- (number->string (length sr))
- " sizes"))
+ (logf "entering parseresults with ~a results in ~a sizes"
+ (apply + (map (lambda (o) (length (cdr o))) sr))
+ (number->string (length sr)))
(let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
(catch 'ret
(lambda ()
sr)
(set! sr (sort newglist srg-less?))
(if (> countrem 0)
- (logf (string-append "removed " (number->string countrem) " time-outed results and " (number->string numrem) " entire sizes"))))
+ (logf "removed ~a time-outed results and ~a entire sizes" countrem numrem)))
(let ((numrem 0) (newlist '()))
(for-each (lambda (o)
(if (> (- (current-time) (cdr (assoc 'time o))) 1800)
(set! newlist (cons o newlist))))
dpeers)
(set! dpeers newlist)
- (logf (string-append "re-enabled " (number->string numrem) " disabled users")))
+ (logf "re-enabled ~a disabled users" numrem))
(let ((numrem 0) (countrem 0) (newglist '()))
(for-each (lambda (g)
(let ((newlist '()))
sr)
(set! sr (sort newglist srg-less?))
(if (> countrem 0)
- (logf (string-append "removed " (number->string countrem) " results with disabled peers and " (number->string numrem) " entire sizes"))))
+ (logf "removed ~a results with disabled peers and ~a entire sizes" countrem numrem)))
(and (eq? sr '()) (throw 'ret #f))
(set! numtotal (apply + (map (lambda (o) (length (cdr o))) sr)))
(let* ((maxsize (apply max (map (lambda (o) (length (cdr o))) sr)))
(set! numrem (+ numrem 1)))))
sr)
(if (> countrem 0)
- (logf (string-append "will disregard " (number->string countrem) " results from " (number->string numrem) " sizes due to popularity lack")))
+ (logf "will disregard ~a results from ~a sizes due to popularity lack" countrem numrem))
(set! numreal (- numtotal countrem)))
(let ((numrem 0) (numrrem 0))
(for-each (lambda (g)
(cdr g)))
sr)
(if (> numrem 0)
- (logf (string-append (number->string numrem) " results had no slots")))
+ (logf "~a results had no slots" numrem))
(set! numavail (- numreal numrrem)))
(for-each (lambda (g)
(if (>= (length (cdr g)) minsize)
(if (and (cdr (assoc 'curspeed tr))
(not (equal? (cdr (assoc 'peer sr)) (cdr (assoc 'peer tr))))
(> (- (or (cdr (assoc 'speed sr)) (defspeed sr)) (cdr (assoc 'curspeed tr))) 10000))
- (begin (logf (string-append "abandoning transfer "
- (number->string (cdr (assoc 'id tr)))
- " for possible faster sender"))
+ (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)
+(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")
+ (infomsg "searchmode normal")))
(let ((cl (or (assoc size sr)
(let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
(newsr (list
(cons 'slots slots)
(cons 'resptime resptime)
(cons 'speed (getspeed peer))
+ (cons 'hash hash)
(cons 'recvtime (current-time))
(cons 'dis #f)))
(newlist '()))
)
(define (autodl-main args)
- (let ((dc-server #f) (done #f) (retval 0))
- (let ((getopt (make-getopt (cdr args) "hs:S:e:p:t:a:I:")) (arg #f))
+ (let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
+ (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))
- (display " autodl [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
+ (display " autodl [-w] [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
(display " autodl [-s server]\n" (current-error-port))
(display " autodl -h\n" (current-error-port))
(exit 0)))
(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))
+ (set! session (cons (cons 'estat-file (cdr arg)) session)))))
((eq? (car arg) #\e)
(set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session)))
+ ((eq? (car arg) #\w)
+ (set! session (cons '(search-mode . wait) session)))
+ ((eq? (car arg) #\x)
+ (let* ((c (assoc 'xargs session)) (p (string-index (cdr arg) #\=))
+ (recons (cons (substring (cdr arg) 0 p) (substring (cdr arg) (1+ p)))))
+ (if c (set-cdr! c (cons recons (cdr c)))
+ (set! session (cons (cons 'xargs (list recons)) session)))))
)
)
)
(set! session (cons '(prio . 10) session)))
(if (not (assoc 'maxtrans session))
(set! session (cons '(maxtrans . 1) session)))
+ (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 (string-append "could not connect to server: " (apply format #f (cadr args) (caddr args))))
+ (logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
(exit 2)))
- (dc-ecmd-assert 200 "notify" "all" "on")
+ (dc-ecmd-assert 200 "notify" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
(for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
(catch 'sig
(lambda ()
(case (cdr (assoc 'code eres))
((200)
(begin (set! srchid (car ires))
- (logf (string-append "search scheduled in " (number->string (cadr ires)) " seconds (id " (number->string srchid) ")"))
+ (logf "search scheduled in ~a seconds (id ~a)"
+ (cadr ires)
+ srchid)
+ (infomsg "search pending ~a" (cadr ires))
(set! info-searcheta (+ (current-time) (cadr ires)))
- (set! lastsearch -1)))
+ (set! lastsearch -1)
+ (write-info-file)))
((501)
(begin (set! srchid -1)
- (logf (string-append "no fnetnodes available to search on"))
+ (logf "no fnetnodes available to search on")
+ (infomsg "nofns")
(set! lastsearch (current-time))))
((509)
(begin (logf "illegal search expression")
(if (> (- (current-time) lastparse) 20)
(begin (parseresults)
(set! lastparse (current-time))))
- (write-info-file)
(dc-select 10000)
(while (let ((resp (dc-getresp)))
(if resp
((614) ; Transfer error
(let ((ires (dc-intresp resp)))
(if (and ires (assoc (car ires) trans))
- (begin (logf (string-append "transfer " (number->string (car ires)) " encountered error " (number->string (cadr ires))))
+ (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))))
(let* ((ires (dc-intresp resp)) (tr (and ires (assoc (car ires) trans))))
(if tr
(begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
- (begin (logf (string-append "transfer " (number->string (car ires)) " 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 (string-append "transfer " (number->string (car ires)) " disappeared"))
+ (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 (string-append "search rescheduled to T+" (number->string (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))))))
+ (set! lastsearch (current-time))
+ (write-info-file)))))
((622) ; Search result
(let ((ires (list->vector (dc-intresp resp))))
- (if (and ires (= (vector-ref ires 0) srchid)) (apply handlesr (map (lambda (n) (vector-ref ires n)) '(1 2 3 4 5 7))))))
+ (if (and ires (= (vector-ref ires 0) srchid)) (apply handlesr (map (lambda (n) (vector-ref ires n)) '(1 2 3 4 5 7 8))))))
)
)
)
)
(lambda (key sig)
- (logf (string-append "interrupted by signal " (number->string sig)))
+ (logf "interrupted by signal ~a" sig)
(if (not done)
(set! retval 1)))
)
)))
(lambda (key sig)
(logf "forcing quit")))
+ (if (assoc 'estat-file session)
+ (let ((op (open-output-file (cdr (assoc 'estat-file session)))))
+ (display filterexit op)
+ (newline op)
+ (close-port op)))
(exit retval)
)
)
Dolda2000 GitWeb / doldaconnect.git / blobdiff