Fixed double-free bug in filtercmd handler.
[doldaconnect.git] / lib / guile / autodl
CommitLineData
d3372da9 1#!/usr/bin/guile -s
2!#
3
3af4536f
FT
4; Dolda Connect - Modular multiuser Direct Connect-style client
5; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
6;
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.
11;
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.
16;
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
20
d3372da9 21(use-modules (dolcon ui))
275514c0 22(use-modules (ice-9 pretty-print) (ice-9 rdelim))
d3372da9 23
24(define sr '())
25(define lastsearch 0)
26(define info-searcheta 0)
27(define info-numavail 0)
28(define info-numreal 0)
29(define info-numtotal 0)
30(define lastparse 0)
31(define srchid -1)
32(define session '())
33(define trans '())
34(define dpeers '())
35(define lastdl 0)
e6485bff 36(define logport (current-output-port))
37(define infoport #f)
d3372da9 38
c6cc011b 39(define (logf fmt . msg)
e6485bff 40 (if logport
41 (begin
42 (apply format (cons* logport (string-append fmt "\n") msg))
43 (catch 'system-error (lambda ()
44 (fsync logport))
45 (lambda (key . err) #f))))
46 )
47
30806d5e 48(define (infomsg fmt . msg)
e6485bff 49 (if infoport
50 (begin
51 (apply format (cons* infoport (string-append fmt "\n") msg))
52 (catch 'system-error (lambda ()
53 (fsync infoport))
54 (lambda (key . err) #f))))
d3372da9 55 )
56
57(define (make-getopt opts optdesc)
58 (let ((arg opts) (curpos 0) (rest '()))
59 (lambda ()
60 (if (eq? arg '()) rest
61 (let ((ret #f))
62 (while (not ret)
63 (if (= curpos 0)
64 (if (eq? (string-ref (car arg) 0) #\-)
65 (set! curpos 1)
66 (begin
67 (set! rest (append rest (list (car arg))))
68 (set! arg (cdr arg))
69 (if (eq? arg '())
70 (set! ret #t)))))
71 (if (> curpos 0)
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))))))
75 (if (eq? ret #t) rest
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)) #\:))
79 (let ((ret
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))))
85 (set! curpos 0)
86 ret)
87 (list ret))))))))))
88
89(define (ftime)
90 (let ((ctime (gettimeofday)))
91 (+ (car ctime) (/ (cdr ctime) 1000000))))
92
93(define (wanttosearch)
94 (> (- (current-time) lastsearch)
d30cc4bc 95 (if (eq? (cdr (assoc 'search-mode session)) 'wait)
96 7200
97 (if (> (length trans) 0) 300 60)))
d3372da9 98 )
99
100(define defspeed '())
101(let ((matchlist (list
102 (cons (make-regexp "^[][{}() ]*BBB" regexp/icase) 100000))))
103 (set! defspeed
104 (lambda (sr)
105 (catch 'ret
106 (lambda ()
107 (for-each (lambda (o)
108 (if (regexp-exec (car o) (cadr (cdr (assoc 'peer sr))))
109 (throw 'ret (cdr o))))
110 matchlist)
111 15000)
112 (lambda (sig ret)
113 ret))
114 )))
115
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))))
119 (if (= s1 s2)
120 (< (cdr (assoc 'resptime sr1)) (cdr (assoc 'resptime sr2)))
121 (> s1 s2)))
122 )
123
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))))
128 )
129
130(define (gettrbysize size)
131 (catch 'ret
132 (lambda ()
133 (for-each (lambda (o)
134 (if (= (cdr (assoc 'size (cdr o))) size)
135 (throw 'ret (cdr o))))
136 trans)
137 #f)
138 (lambda (sig ret)
139 ret))
140 )
141
142(define (download sr)
143 (let ((resp #f))
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)))))
3b0de0fd 149 (let ((hash (assoc 'hash sr)))
150 (if (and hash (not (equal? (cdr hash) ""))) (set! args (append args (list "hash" (cdr hash))))))
d3372da9 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))))))
e838f46b 155 (let ((xargs (assoc 'xargs session)))
156 (if xargs (for-each (lambda (o)
157 (set! args (append args (list (car o) (cdr o)))))
158 (cdr xargs))))
d3372da9 159 (set! resp (apply dc-ecmd-assert 200 args)))
160 (let ((id (car (dc-intresp resp))))
161 (set! trans
162 (cons (cons id (list (assoc 'size sr)
163 (assoc 'peer sr)
164 (assoc 'filename sr)
165 (assoc 'resptime sr)
166 '(curpos . 0)
167 '(state . wait)
168 '(curspeed . #f)
169 '(lastpos . 0)
170 (cons 'id id)
171 (cons 'lasttime (current-time))
172 (cons 'lastprog (current-time))))
173 trans))
c6cc011b 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)))
e6485bff 177 (cdr (assoc 'size sr))
178 id
179 (cdr (assoc 'slots sr))
180 (max 10 (* (cdr (assoc 'resptime sr)) 2)))
181 (infomsg "dl ~a ~a" (cdr (assoc 'size sr)) id)))
d3372da9 182 (set! lastdl (current-time))
183 )
184
185(define (disablepeer peer)
186 (let ((newglist '()) (numrem 0))
187 (for-each (lambda (g)
188 (let ((newlist '()))
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))))
193 (cdr g))
194 (if (not (eq? newlist '()))
195 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
196 sr)
197 (set! sr (sort newglist srg-less?))
c6cc011b 198 (logf "disabled ~a and removed ~a search results" (cadr peer) numrem))
d3372da9 199 (let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
200 (if dp
201 (set-cdr! (assoc 'time dp) (current-time))
202 (set! dpeers (cons (cons peer (list (cons 'time (current-time))
203 (cons 'peer peer)))
204 dpeers))))
205 )
206
207(define (checktrans)
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))))
c6cc011b 212 (begin (logf "transfer ~a timing out" (car o))
e6485bff 213 (infomsg "dlstop ~a timeout" (car o))
d3372da9 214 (dc-ecmd-assert 200 "cancel" (car o))
215 (disablepeer (cdr (assoc 'peer (cdr o))))
ecd6e23d 216 (set! trans (assq-remove! trans (car o)))
217 (write-info-file)))
d3372da9 218 (if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
219 (> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
c6cc011b 220 (begin (logf "transfer ~a seems to have stalled" (car o))
e6485bff 221 (infomsg "dlstop ~a stall" (car o))
d3372da9 222 (dc-ecmd-assert 200 "cancel" (car o))
ecd6e23d 223 (set! trans (assq-remove! trans (car o)))
224 (write-info-file)))
d3372da9 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))))
ecd6e23d 231 (set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o))))
232 (write-info-file))))
d3372da9 233 trans))
234 )
235
236(define (write-info-file)
237 (if (assoc 'info-file session)
238 (let ((op (open-output-file (cdr (assoc 'info-file session)))))
d576878b 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))))
247 op)
d3372da9 248 (close-port op))))
249
250(define (parseresults)
c6cc011b 251 (logf "entering parseresults with ~a results in ~a sizes"
252 (apply + (map (lambda (o) (length (cdr o))) sr))
253 (number->string (length sr)))
d3372da9 254 (let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
255 (catch 'ret
256 (lambda ()
257 (and (eq? sr '()) (throw 'ret #f))
258 (let ((numrem 0) (countrem 0) (newglist '()))
259 (for-each (lambda (g)
260 (let ((newlist '()))
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))))
265 (cdr g))
266 (if (> (length newlist) 0)
267 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
268 (set! numrem (+ numrem 1)))))
269 sr)
270 (set! sr (sort newglist srg-less?))
271 (if (> countrem 0)
c6cc011b 272 (logf "removed ~a time-outed results and ~a entire sizes" countrem numrem)))
d3372da9 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))))
278 dpeers)
279 (set! dpeers newlist)
c6cc011b 280 (logf "re-enabled ~a disabled users" numrem))
d3372da9 281 (let ((numrem 0) (countrem 0) (newglist '()))
282 (for-each (lambda (g)
283 (let ((newlist '()))
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))))
288 (cdr g))
289 (if (> (length newlist) 0)
290 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
291 (set! numrem (+ numrem 1)))))
292 sr)
293 (set! sr (sort newglist srg-less?))
294 (if (> countrem 0)
c6cc011b 295 (logf "removed ~a results with disabled peers and ~a entire sizes" countrem numrem)))
d3372da9 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)))))
304 sr)
305 (if (> countrem 0)
c6cc011b 306 (logf "will disregard ~a results from ~a sizes due to popularity lack" countrem numrem))
d3372da9 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))))))
315 (cdr g)))
316 sr)
317 (if (> numrem 0)
c6cc011b 318 (logf "~a results had no slots" numrem))
d3372da9 319 (set! numavail (- numreal numrrem)))
320 (for-each (lambda (g)
321 (if (>= (length (cdr g)) minsize)
322 (catch 'found
323 (lambda ()
324 (for-each (lambda (o)
325 (and (> (cdr (assoc 'slots o)) 0)
326 (throw 'found o)))
327 (cdr g)))
328 (lambda (sig sr)
329 (let ((tr (gettrbysize (cdr (assoc 'size sr)))))
330 (if (not tr)
331 (if (< (length trans) (cdr (assoc 'maxtrans session)))
332 (download sr))
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))
c6cc011b 336 (begin (logf "abandoning transfer ~a for possible faster sender"
337 (cdr (assoc 'id tr)))
e6485bff 338 (infomsg "dlstop ~a tryother" (cdr (assoc 'id tr)))
d3372da9 339 (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
340 (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
341 (download sr)))))))))
342 sr)
343 )
344 )
345 (lambda (sig ret)
346 (set! retval ret)
347 ))
348 (set! info-numavail numavail)
349 (set! info-numreal numreal)
350 (set! info-numtotal numtotal)
34905adc 351 (infomsg "srs ~a ~a ~a" numtotal numreal numavail)
ecd6e23d 352 (write-info-file)
d3372da9 353 retval)
354 )
355
3b0de0fd 356(define (handlesr filename fnet peer size slots resptime hash)
2bb57f49 357 (if (eq? (cdr (assoc 'search-mode session)) 'wait)
358 (begin (set-cdr! (assoc 'search-mode session) 'normal)
e6485bff 359 (logf "reverting to normal mode")
360 (infomsg "searchmode normal")))
d3372da9 361 (let ((cl (or (assoc size sr)
362 (let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
363 (newsr (list
364 (cons 'filename filename)
365 (cons 'peer (list fnet peer))
366 (cons 'size size)
367 (cons 'slots slots)
368 (cons 'resptime resptime)
369 (cons 'speed (getspeed peer))
3b0de0fd 370 (cons 'hash hash)
d3372da9 371 (cons 'recvtime (current-time))
372 (cons 'dis #f)))
373 (newlist '()))
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))))
377 (cdr cl))
378 (set-cdr! cl (sort (cons newsr newlist) sr-less?))
379 )
380 )
381
382; XXX: Redefine to go through the server, once that is implemented
383(define (getspeed username)
384 (catch 'system-error
385 (lambda ()
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)))))
388 ))
389 (lambda args
390 #f
391 )
392 )
393 )
394
395(define (validate-session session)
396 (catch 'wrong-type-arg
397 (lambda ()
398 (and
399 (assoc 'sexpr session)
400 (assoc 'prio session)
401 (assoc 'maxtrans session)
402 #t
403 )
404 )
405 (lambda (key . args)
406 (display "Session data is not an a-list\n" (current-error-port))
407 #f)
408 )
409 )
410
411(define (autodl-main args)
aa82fda0 412 (let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
e6485bff 413 (let ((getopt (make-getopt (cdr args) "whis:S:e:p:t:a:I:E:x:")) (arg #f))
d3372da9 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))
d30cc4bc 417 (display " autodl [-w] [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
d3372da9 418 (display " autodl [-s server]\n" (current-error-port))
419 (display " autodl -h\n" (current-error-port))
420 (exit 0)))
421 ((eq? (car arg) #\s)
422 (set! dc-server (cdr arg)))
423 ((eq? (car arg) #\S)
424 (let ((port (open-file (cdr arg)))) (set! session (read port)) (close-port port)))
425 ((eq? (car arg) #\p)
426 (let ((c (assoc 'prio session)))
427 (if c (set-cdr! c (cdr arg))
428 (set! session (cons (cons 'prio (cdr arg)) session)))))
429 ((eq? (car arg) #\t)
430 (let ((c (assoc 'tag session)))
431 (if c (set-cdr! c (cdr arg))
432 (set! session (cons (cons 'tag (cdr arg)) session)))))
433 ((eq? (car arg) #\a)
434 (let ((c (assoc 'uarg session)))
435 (if c (set-cdr! c (cdr arg))
436 (set! session (cons (cons 'uarg (cdr arg)) session)))))
437 ((eq? (car arg) #\I)
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)))))
e6485bff 441 ((eq? (car arg) #\i)
442 (set! infoport logport)
443 (set! logport #f))
aa82fda0 444 ((eq? (car arg) #\E)
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)))))
d3372da9 448 ((eq? (car arg) #\e)
449 (set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session)))
d30cc4bc 450 ((eq? (car arg) #\w)
451 (set! session (cons '(search-mode . wait) session)))
e838f46b 452 ((eq? (car arg) #\x)
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)))))
d3372da9 457 )
458 )
459 )
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)))
d30cc4bc 465 (if (not (assoc 'search-mode session))
53acfa81 466 (set! session (cons '(search-mode . normal) session)))
d3372da9 467 (if (not (validate-session session)) (begin (display "Invalid session!\n" (current-error-port)) (exit 1)))
d3372da9 468 (catch 'system-error
469 (lambda ()
6d8a9842 470 (dc-c&l #f dc-server #t))
d3372da9 471 (lambda (key . args)
c6cc011b 472 (logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
d3372da9 473 (exit 2)))
c6a77cc5 474 (dc-ecmd-assert 200 "notify" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
d3372da9 475 (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
476 (catch 'sig
477 (lambda ()
478 (while #t
479 (if (and (not (= lastsearch -1)) (wanttosearch))
480 (begin
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))
487 ((200)
488 (begin (set! srchid (car ires))
c6cc011b 489 (logf "search scheduled in ~a seconds (id ~a)"
e6485bff 490 (cadr ires)
491 srchid)
492 (infomsg "search pending ~a" (cadr ires))
d3372da9 493 (set! info-searcheta (+ (current-time) (cadr ires)))
ecd6e23d 494 (set! lastsearch -1)
495 (write-info-file)))
d3372da9 496 ((501)
497 (begin (set! srchid -1)
c6cc011b 498 (logf "no fnetnodes available to search on")
e6485bff 499 (infomsg "nofns")
d3372da9 500 (set! lastsearch (current-time))))
501 ((509)
502 (begin (logf "illegal search expression")
503 (set! done #t)
504 (set! retval 3)
505 (throw 'sig 0)))))))
506 (checktrans)
507 (if (> (- (current-time) lastparse) 20)
508 (begin (parseresults)
509 (set! lastparse (current-time))))
d3372da9 510 (dc-select 10000)
511 (while (let ((resp (dc-getresp)))
512 (if resp
513 (begin
514 (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
515 (cond
516 ((equal? cmd ".notify")
517 (case code
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))
c6cc011b 528 (begin (logf "transfer ~a encountered error ~a" (car ires) (cadr ires))
e6485bff 529 (infomsg "dlstop ~a error ~a" (car ires) (cadr ires))
d3372da9 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))))
542 (if tr
543 (begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
c6cc011b 544 (begin (logf "transfer ~a done (~a)" (car ires) (cadr ires))
42a9c63a 545 (infomsg "dldone ~a" (car ires))
546 (infomsg "estat ~a" (cadr ires))
d3372da9 547 (set! trans (assq-remove! trans (car ires)))
548 (set! done #t)
2fc2772d 549 (set! filterexit (cadr ires))
d3372da9 550 (throw 'sig 0))
c6cc011b 551 (begin (logf "transfer ~a disappeared" (car ires))
e6485bff 552 (infomsg "dlstop ~a gone" (car ires))
d3372da9 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)))
c6cc011b 558 (logf "search rescheduled to T+~a" (cadr ires))
e6485bff 559 (infomsg "search pending ~a" (cadr ires))
d30cc4bc 560 (write-info-file)))))
d3372da9 561 ((621) ; Search committed
562 (let ((ires (dc-intresp resp)))
563 (if (and ires (= (car ires) srchid))
564 (begin (logf "search committed")
e6485bff 565 (infomsg "search commit")
d3372da9 566 (set! info-searcheta 0)
d30cc4bc 567 (set! lastsearch (current-time))
568 (write-info-file)))))
d3372da9 569 ((622) ; Search result
570 (let ((ires (list->vector (dc-intresp resp))))
3b0de0fd 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))))))
d3372da9 572
573 )
574 )
575
576 )
577 )
578 #t)
579 #f)
580 )
581 #t
582 )
583 )
584 )
585 (lambda (key sig)
c6cc011b 586 (logf "interrupted by signal ~a" sig)
d3372da9 587 (if (not done)
588 (set! retval 1)))
589 )
590 (logf "quitting...")
591 (catch 'sig
592 (lambda ()
593 (if (dc-connected)
594 (begin (for-each (lambda (o)
595 (dc-qcmd (list "cancel" (car o))))
596 trans)
597 (if (assoc 'info-file session)
598 (catch 'system-error
599 (lambda ()
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)))
606 (dc-qcmd '("quit"))
607 (while (dc-connected) (dc-select))
608 )))
609 (lambda (key sig)
610 (logf "forcing quit")))
aa82fda0 611 (if (assoc 'estat-file session)
612 (let ((op (open-output-file (cdr (assoc 'estat-file session)))))
fc068ee7 613 (display filterexit op)
aa82fda0 614 (newline op)
615 (close-port op)))
d3372da9 616 (exit retval)
617 )
618 )
619
620(setlocale LC_ALL "")
621(autodl-main (command-line))