4 ; Dolda Connect - Modular multiuser Direct Connect-style client
5 ; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
7 ; This program is free software; you can redistribute it and/or modify
8 ; it under the terms of the GNU General Public License as published by
9 ; the Free Software Foundation; either version 2 of the License, or
10 ; (at your option) any later version.
12 ; This program is distributed in the hope that it will be useful,
13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ; GNU General Public License for more details.
17 ; You should have received a copy of the GNU General Public License
18 ; along with this program; if not, write to the Free Software
19 ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 (use-modules (dolcon ui))
22 (use-modules (ice-9 pretty-print) (ice-9 rdelim))
26 (define info-searcheta 0)
27 (define info-numavail 0)
28 (define info-numreal 0)
29 (define info-numtotal 0)
36 (define logport (current-output-port))
39 (define (logf fmt . msg)
42 (apply format (cons* logport (string-append fmt "\n") msg))
43 (catch 'system-error (lambda ()
45 (lambda (key . err) #f))))
48 (define (infomsg fmt . msg)
51 (apply format (cons* infoport (string-append fmt "\n") msg))
52 (catch 'system-error (lambda ()
54 (lambda (key . err) #f))))
57 (define (make-getopt opts optdesc)
58 (let ((arg opts) (curpos 0) (rest '()))
60 (if (eq? arg '()) rest
64 (if (eq? (string-ref (car arg) 0) #\-)
67 (set! rest (append rest (list (car arg))))
72 (if (< curpos (string-length (car arg)))
73 (begin (set! ret (string-ref (car arg) curpos)) (set! curpos (+ curpos 1)))
74 (begin (set! curpos 0) (set! arg (cdr arg)) (if (eq? arg '()) (set! ret #t))))))
76 (let ((opt (string-index optdesc ret)))
77 (if (eq? opt #f) (throw 'illegal-option ret)
78 (if (and (< opt (- (string-length optdesc) 1)) (eq? (string-ref optdesc (+ opt 1)) #\:))
80 (cons ret (let ((optarg
81 (if (< curpos (string-length (car arg)))
82 (substring (car arg) curpos)
83 (begin (set! arg (cdr arg)) (if (eq? arg '()) (throw 'requires-argument ret)) (car arg)))))
84 (set! arg (cdr arg)) optarg))))
90 (let ((ctime (gettimeofday)))
91 (+ (car ctime) (/ (cdr ctime) 1000000))))
93 (define (wanttosearch)
94 (> (- (current-time) lastsearch)
95 (if (eq? (cdr (assoc 'search-mode session)) 'wait)
97 (if (> (length trans) 0) 300 60)))
100 (define defspeed '())
101 (let ((matchlist (list
102 (cons (make-regexp "^[][{}() ]*BBB" regexp/icase) 100000))))
107 (for-each (lambda (o)
108 (if (regexp-exec (car o) (cadr (cdr (assoc 'peer sr))))
109 (throw 'ret (cdr o))))
116 (define (sr-less? sr1 sr2)
117 (let ((s1 (if (cdr (assoc 'speed sr1)) (cdr (assoc 'speed sr1)) (defspeed sr1)))
118 (s2 (if (cdr (assoc 'speed sr2)) (cdr (assoc 'speed sr2)) (defspeed sr2))))
120 (< (cdr (assoc 'resptime sr1)) (cdr (assoc 'resptime sr2)))
124 (define (srg-less? g1 g2)
125 (or (> (length (cdr g1)) (length (cdr g2)))
126 (and (= (length (cdr g1)) (length (cdr g2)))
127 (> (car g1) (car g2))))
130 (define (gettrbysize size)
133 (for-each (lambda (o)
134 (if (= (cdr (assoc 'size (cdr o))) size)
135 (throw 'ret (cdr o))))
142 (define (download sr)
144 (let ((args (list "download"
145 (car (cdr (assoc 'peer sr)))
146 (cadr (cdr (assoc 'peer sr)))
147 (cdr (assoc 'filename sr))
148 (cdr (assoc 'size sr)))))
149 (let ((hash (assoc 'hash sr)))
150 (if (and hash (not (equal? (cdr hash) ""))) (set! args (append args (list "hash" (cdr hash))))))
151 (let ((tag (assoc 'tag session)))
152 (if tag (set! args (append args (list "tag" (cdr tag))))))
153 (let ((uarg (assoc 'uarg session)))
154 (if uarg (set! args (append args (list "user" (cdr uarg))))))
155 (let ((xargs (assoc 'xargs session)))
156 (if xargs (for-each (lambda (o)
157 (set! args (append args (list (car o) (cdr o)))))
159 (set! resp (apply dc-ecmd-assert 200 args)))
160 (let ((id (car (dc-intresp resp))))
162 (cons (cons id (list (assoc 'size sr)
171 (cons 'lasttime (current-time))
172 (cons 'lastprog (current-time))))
174 (logf "downloading ~a from ~a, ~a bytes (id ~a, ~a slots), timing out in ~a seconds"
175 (cdr (assoc 'filename sr))
176 (cadr (cdr (assoc 'peer sr)))
177 (cdr (assoc 'size sr))
179 (cdr (assoc 'slots sr))
180 (max 10 (* (cdr (assoc 'resptime sr)) 2)))
181 (infomsg "dl ~a ~a" (cdr (assoc 'size sr)) id)))
182 (set! lastdl (current-time))
185 (define (disablepeer peer)
186 (let ((newglist '()) (numrem 0))
187 (for-each (lambda (g)
189 (for-each (lambda (o)
190 (if (not (equal? (cdr (assoc 'peer o)) peer))
191 (set! newlist (cons o newlist))
192 (set! numrem (+ numrem 1))))
194 (if (not (eq? newlist '()))
195 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
197 (set! sr (sort newglist srg-less?))
198 (logf "disabled ~a and removed ~a search results" (cadr peer) numrem))
199 (let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
201 (set-cdr! (assoc 'time dp) (current-time))
202 (set! dpeers (cons (cons peer (list (cons 'time (current-time))
208 (let ((time (current-time)))
209 (for-each (lambda (o)
210 (if (and (memq (cdr (assoc 'state (cdr o))) '(wait hs))
211 (> (- time (cdr (assoc 'lastprog (cdr o)))) (max 10 (* (cdr (assoc 'resptime (cdr o))) 2))))
212 (begin (logf "transfer ~a timing out" (car o))
213 (infomsg "dlstop ~a timeout" (car o))
214 (dc-ecmd-assert 200 "cancel" (car o))
215 (disablepeer (cdr (assoc 'peer (cdr o))))
216 (set! trans (assq-remove! trans (car o)))
218 (if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
219 (> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
220 (begin (logf "transfer ~a seems to have stalled" (car o))
221 (infomsg "dlstop ~a stall" (car o))
222 (dc-ecmd-assert 200 "cancel" (car o))
223 (set! trans (assq-remove! trans (car o)))
225 (if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
226 (> (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o)))) 20))
227 (begin (set-cdr! (assoc 'curspeed (cdr o))
228 (/ (- (cdr (assoc 'curpos (cdr o))) (cdr (assoc 'lastpos (cdr o))))
229 (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o))))))
230 (set-cdr! (assoc 'lastpos (cdr o)) (cdr (assoc 'curpos (cdr o))))
231 (set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o))))
236 (define (write-info-file)
237 (if (assoc 'info-file session)
238 (let ((op (open-output-file (cdr (assoc 'info-file session)))))
239 (pretty-print (list (cons 'numdl (length trans))
240 (cons 'lastdl lastdl)
241 (cons 'availsr info-numavail)
242 (cons 'realsr info-numreal)
243 (cons 'totalsr info-numtotal)
244 (cons 'lastsrch lastsearch)
245 (cons 'srcheta info-searcheta)
246 (cons 'srchmode (cdr (assoc 'search-mode session))))
250 (define (parseresults)
251 (logf "entering parseresults with ~a results in ~a sizes"
252 (apply + (map (lambda (o) (length (cdr o))) sr))
253 (number->string (length sr)))
254 (let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
257 (and (eq? sr '()) (throw 'ret #f))
258 (let ((numrem 0) (countrem 0) (newglist '()))
259 (for-each (lambda (g)
261 (for-each (lambda (o)
262 (if (< (- (current-time) (cdr (assoc 'recvtime o))) 300)
263 (set! newlist (cons o newlist))
264 (set! countrem (+ countrem 1))))
266 (if (> (length newlist) 0)
267 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
268 (set! numrem (+ numrem 1)))))
270 (set! sr (sort newglist srg-less?))
272 (logf "removed ~a time-outed results and ~a entire sizes" countrem numrem)))
273 (let ((numrem 0) (newlist '()))
274 (for-each (lambda (o)
275 (if (> (- (current-time) (cdr (assoc 'time o))) 1800)
276 (set! numrem (+ numrem 1))
277 (set! newlist (cons o newlist))))
279 (set! dpeers newlist)
280 (logf "re-enabled ~a disabled users" numrem))
281 (let ((numrem 0) (countrem 0) (newglist '()))
282 (for-each (lambda (g)
284 (for-each (lambda (o)
285 (if (not (assoc (cdr (assoc 'peer o)) dpeers))
286 (set! newlist (cons o newlist))
287 (set! countrem (+ countrem 1))))
289 (if (> (length newlist) 0)
290 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
291 (set! numrem (+ numrem 1)))))
293 (set! sr (sort newglist srg-less?))
295 (logf "removed ~a results with disabled peers and ~a entire sizes" countrem numrem)))
296 (and (eq? sr '()) (throw 'ret #f))
297 (set! numtotal (apply + (map (lambda (o) (length (cdr o))) sr)))
298 (let* ((maxsize (apply max (map (lambda (o) (length (cdr o))) sr)))
299 (minsize (/ maxsize 3)))
300 (let ((numrem 0) (countrem 0))
301 (for-each (lambda (o) (if (< (length (cdr o)) minsize)
302 (begin (set! countrem (+ countrem (length (cdr o))))
303 (set! numrem (+ numrem 1)))))
306 (logf "will disregard ~a results from ~a sizes due to popularity lack" countrem numrem))
307 (set! numreal (- numtotal countrem)))
308 (let ((numrem 0) (numrrem 0))
309 (for-each (lambda (g)
310 (for-each (lambda (o)
311 (if (< (cdr (assoc 'slots o)) 1)
312 (begin (set! numrem (+ numrem 1))
313 (if (>= (length (cdr g)) minsize)
314 (set! numrrem (+ numrrem 1))))))
318 (logf "~a results had no slots" numrem))
319 (set! numavail (- numreal numrrem)))
320 (for-each (lambda (g)
321 (if (>= (length (cdr g)) minsize)
324 (for-each (lambda (o)
325 (and (> (cdr (assoc 'slots o)) 0)
329 (let ((tr (gettrbysize (cdr (assoc 'size sr)))))
331 (if (< (length trans) (cdr (assoc 'maxtrans session)))
333 (if (and (cdr (assoc 'curspeed tr))
334 (not (equal? (cdr (assoc 'peer sr)) (cdr (assoc 'peer tr))))
335 (> (- (or (cdr (assoc 'speed sr)) (defspeed sr)) (cdr (assoc 'curspeed tr))) 10000))
336 (begin (logf "abandoning transfer ~a for possible faster sender"
337 (cdr (assoc 'id tr)))
338 (infomsg "dlstop ~a tryother" (cdr (assoc 'id tr)))
339 (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
340 (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
341 (download sr)))))))))
348 (set! info-numavail numavail)
349 (set! info-numreal numreal)
350 (set! info-numtotal numtotal)
351 (infomsg "srs ~a ~a ~a" numtotal numreal numavail)
356 (define (handlesr filename fnet peer size slots resptime hash)
357 (if (eq? (cdr (assoc 'search-mode session)) 'wait)
358 (begin (set-cdr! (assoc 'search-mode session) 'normal)
359 (logf "reverting to normal mode")
360 (infomsg "searchmode normal")))
361 (let ((cl (or (assoc size sr)
362 (let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
364 (cons 'filename filename)
365 (cons 'peer (list fnet peer))
368 (cons 'resptime resptime)
369 (cons 'speed (getspeed peer))
371 (cons 'recvtime (current-time))
374 (for-each (lambda (o) (if (not (and (equal? (cdr (assoc 'filename o)) filename)
375 (equal? (cdr (assoc 'peer o)) (list fnet peer))))
376 (set! newlist (cons o newlist))))
378 (set-cdr! cl (sort (cons newsr newlist) sr-less?))
382 ; XXX: Redefine to go through the server, once that is implemented
383 (define (getspeed username)
386 (let* ((port (open-input-file (string-append (getenv "HOME") "/dc/users/" username))) (avg 0) (numdls (string->number (read-line port))) (max (string->number (read-line port))) (numents (string->number (read-line port))))
387 (do ((i 0 (+ i 1))) ((= i numents) (close-port port) (/ avg numents)) (set! avg (+ avg (string->number (read-line port)))))
395 (define (validate-session session)
396 (catch 'wrong-type-arg
399 (assoc 'sexpr session)
400 (assoc 'prio session)
401 (assoc 'maxtrans session)
406 (display "Session data is not an a-list\n" (current-error-port))
411 (define (autodl-main args)
412 (let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
413 (let ((getopt (make-getopt (cdr args) "whis:S:e:p:t:a:I:E:x:")) (arg #f))
414 (do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
415 (cond ((eq? (car arg) #\h)
416 (begin (display "usage: autodl [-s server] -S sessfile\n" (current-error-port))
417 (display " autodl [-w] [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
418 (display " autodl [-s server]\n" (current-error-port))
419 (display " autodl -h\n" (current-error-port))
422 (set! dc-server (cdr arg)))
424 (let ((port (open-file (cdr arg)))) (set! session (read port)) (close-port port)))
426 (let ((c (assoc 'prio session)))
427 (if c (set-cdr! c (cdr arg))
428 (set! session (cons (cons 'prio (cdr arg)) session)))))
430 (let ((c (assoc 'tag session)))
431 (if c (set-cdr! c (cdr arg))
432 (set! session (cons (cons 'tag (cdr arg)) session)))))
434 (let ((c (assoc 'uarg session)))
435 (if c (set-cdr! c (cdr arg))
436 (set! session (cons (cons 'uarg (cdr arg)) session)))))
438 (let ((c (assoc 'info-file session)))
439 (if c (set-cdr! c (cdr arg))
440 (set! session (cons (cons 'info-file (cdr arg)) session)))))
442 (set! infoport logport)
445 (let ((c (assoc 'estat-file session)))
446 (if c (set-cdr! c (cdr arg))
447 (set! session (cons (cons 'estat-file (cdr arg)) session)))))
449 (set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session)))
451 (set! session (cons '(search-mode . wait) session)))
453 (let* ((c (assoc 'xargs session)) (p (string-index (cdr arg) #\=))
454 (recons (cons (substring (cdr arg) 0 p) (substring (cdr arg) (1+ p)))))
455 (if c (set-cdr! c (cons recons (cdr c)))
456 (set! session (cons (cons 'xargs (list recons)) session)))))
460 (if (eq? session '()) (begin (if (isatty? (current-input-port)) (display "Enter session data (s-expr):\n" (current-error-port))) (set! session (read))))
461 (if (not (assoc 'prio session))
462 (set! session (cons '(prio . 10) session)))
463 (if (not (assoc 'maxtrans session))
464 (set! session (cons '(maxtrans . 1) session)))
465 (if (not (assoc 'search-mode session))
466 (set! session (cons '(search-mode . normal) session)))
467 (if (not (validate-session session)) (begin (display "Invalid session!\n" (current-error-port)) (exit 1)))
470 (dc-c&l #f dc-server #t))
472 (logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
474 (dc-ecmd-assert 200 "notify" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
475 (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
479 (if (and (not (= lastsearch -1)) (wanttosearch))
481 (if (not (= srchid -1))
482 (dc-ecmd "cansrch" srchid))
483 (let* ((resp (apply dc-ecmd-assert (append (list '(200 501 509) "search" "prio" (number->string (cdr (assoc 'prio session))) "all") (cdr (assoc 'sexpr session)))))
484 (ires (dc-intresp resp))
485 (eres (dc-extract resp)))
486 (case (cdr (assoc 'code eres))
488 (begin (set! srchid (car ires))
489 (logf "search scheduled in ~a seconds (id ~a)"
492 (infomsg "search pending ~a" (cadr ires))
493 (set! info-searcheta (+ (current-time) (cadr ires)))
497 (begin (set! srchid -1)
498 (logf "no fnetnodes available to search on")
500 (set! lastsearch (current-time))))
502 (begin (logf "illegal search expression")
507 (if (> (- (current-time) lastparse) 20)
508 (begin (parseresults)
509 (set! lastparse (current-time))))
511 (while (let ((resp (dc-getresp)))
514 (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
516 ((equal? cmd ".notify")
518 ((611) ; Transfer state change
519 (let ((ires (dc-intresp resp)) (tr #f))
520 (if (and ires (assoc (car ires) trans))
521 (begin (set! tr (cdr (assoc (car ires) trans)))
522 (set-cdr! (assoc 'state tr)
523 (cdr (assoc (cadr ires) '((0 . wait) (1 . hs) (2 . main) (3 . done)))))
524 (set-cdr! (assoc 'lastprog tr) (current-time))))))
525 ((614) ; Transfer error
526 (let ((ires (dc-intresp resp)))
527 (if (and ires (assoc (car ires) trans))
528 (begin (logf "transfer ~a encountered error ~a" (car ires) (cadr ires))
529 (infomsg "dlstop ~a error ~a" (car ires) (cadr ires))
530 (dc-ecmd-assert 200 "cancel" (car ires))
531 (let ((tr (cdr (assoc (car ires) trans))))
532 (disablepeer (cdr (assoc 'peer tr))))
533 (set! trans (assq-remove! trans (car ires)))))))
534 ((615) ; Transfer progress
535 (let ((ires (dc-intresp resp)) (tr #f))
536 (if (and ires (assoc (car ires) trans))
537 (begin (set! tr (cdr (assoc (car ires) trans)))
538 (set-cdr! (assoc 'curpos tr) (cadr ires))
539 (set-cdr! (assoc 'lastprog tr) (current-time))))))
540 ((617) ; Transfer destroyed
541 (let* ((ires (dc-intresp resp)) (tr (and ires (assoc (car ires) trans))))
543 (begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
544 (begin (logf "transfer ~a done (~a)" (car ires) (cadr ires))
545 (infomsg "dldone ~a" (car ires))
546 (infomsg "estat ~a" (cadr ires))
547 (set! trans (assq-remove! trans (car ires)))
549 (set! filterexit (cadr ires))
551 (begin (logf "transfer ~a disappeared" (car ires))
552 (infomsg "dlstop ~a gone" (car ires))
553 (set! trans (assq-remove! trans (car ires)))))))))
554 ((620) ; Search rescheduled
555 (let ((ires (dc-intresp resp)))
556 (if (and ires (= (car ires) srchid))
557 (begin (set! info-searcheta (+ (current-time) (cadr ires)))
558 (logf "search rescheduled to T+~a" (cadr ires))
559 (infomsg "search pending ~a" (cadr ires))
560 (write-info-file)))))
561 ((621) ; Search committed
562 (let ((ires (dc-intresp resp)))
563 (if (and ires (= (car ires) srchid))
564 (begin (logf "search committed")
565 (infomsg "search commit")
566 (set! info-searcheta 0)
567 (set! lastsearch (current-time))
568 (write-info-file)))))
569 ((622) ; Search result
570 (let ((ires (list->vector (dc-intresp resp))))
571 (if (and ires (= (vector-ref ires 0) srchid)) (apply handlesr (map (lambda (n) (vector-ref ires n)) '(1 2 3 4 5 7 8))))))
586 (logf "interrupted by signal ~a" sig)
594 (begin (for-each (lambda (o)
595 (dc-qcmd (list "cancel" (car o))))
597 (if (assoc 'info-file session)
600 (delete-file (cdr (assoc 'info-file session))))
601 (lambda (key . args) #t)))
602 (if (and done (assoc 'tag session))
603 (dc-qcmd (list "filtercmd" "rmtag" (cdr (assoc 'tag session)))))
604 (if (not (= srchid -1))
605 (dc-qcmd (list "cansrch" srchid)))
607 (while (dc-connected) (dc-select))
610 (logf "forcing quit")))
611 (if (assoc 'estat-file session)
612 (let ((op (open-output-file (cdr (assoc 'estat-file session)))))
613 (display filterexit op)
620 (setlocale LC_ALL "")
621 (autodl-main (command-line))