lib/guile/autodl

   1 #!/usr/bin/guile -s
   2 !#
   3
   4 (use-modules (dolcon ui))
   5 (use-modules (ice-9 pretty-print))
   6
   7 (define sr '())
   8 (define lastsearch 0)
   9 (define info-searcheta 0)
  10 (define info-numavail 0)
  11 (define info-numreal 0)
  12 (define info-numtotal 0)
  13 (define lastparse 0)
  14 (define srchid -1)
  15 (define session '())
  16 (define trans '())
  17 (define dpeers '())
  18 (define lastdl 0)
  19
  20 (define (logf msg)
  21   (write-line msg (current-output-port))
  22   (catch 'system-error (lambda ()
  23                          (fsync (current-output-port)))
  24          (lambda (key . err) #f))
  25   )
  26
  27 (define (make-getopt opts optdesc)
  28   (let ((arg opts) (curpos 0) (rest '()))
  29     (lambda ()
  30       (if (eq? arg '()) rest
  31           (let ((ret #f))
  32             (while (not ret)
  33                    (if (= curpos 0)
  34                        (if (eq? (string-ref (car arg) 0) #\-)
  35                            (set! curpos 1)
  36                            (begin
  37                              (set! rest (append rest (list (car arg))))
  38                              (set! arg (cdr arg))
  39                              (if (eq? arg '())
  40                                  (set! ret #t)))))
  41                    (if (> curpos 0)
  42                        (if (< curpos (string-length (car arg)))
  43                            (begin (set! ret (string-ref (car arg) curpos)) (set! curpos (+ curpos 1)))
  44                            (begin (set! curpos 0) (set! arg (cdr arg)) (if (eq? arg '()) (set! ret #t))))))
  45             (if (eq? ret #t) rest
  46                 (let ((opt (string-index optdesc ret)))
  47                   (if (eq? opt #f) (throw 'illegal-option ret)
  48                       (if (and (< opt (- (string-length optdesc) 1)) (eq? (string-ref optdesc (+ opt 1)) #\:))
  49                           (let ((ret
  50                                  (cons ret (let ((optarg
  51                                                   (if (< curpos (string-length (car arg)))
  52                                                       (substring (car arg) curpos)
  53                                                       (begin (set! arg (cdr arg)) (if (eq? arg '()) (throw 'requires-argument ret)) (car arg)))))
  54                                              (set! arg (cdr arg)) optarg))))
  55                             (set! curpos 0)
  56                             ret)
  57                           (list ret))))))))))
  58
  59 (define (ftime)
  60   (let ((ctime (gettimeofday)))
  61     (+ (car ctime) (/ (cdr ctime) 1000000))))
  62
  63 (define (wanttosearch)
  64   (> (- (current-time) lastsearch)
  65      (if (eq? (cdr (assoc 'search-mode session)) 'wait)
  66          7200
  67          (if (> (length trans) 0) 300 60)))
  68   )
  69
  70 (define defspeed '())
  71 (let ((matchlist (list
  72                   (cons (make-regexp "^[][{}() ]*BBB" regexp/icase) 100000))))
  73   (set! defspeed
  74         (lambda (sr)
  75           (catch 'ret
  76                  (lambda ()
  77                    (for-each (lambda (o)
  78                                (if (regexp-exec (car o) (cadr (cdr (assoc 'peer sr))))
  79                                    (throw 'ret (cdr o))))
  80                              matchlist)
  81                    15000)
  82                  (lambda (sig ret)
  83                    ret))
  84           )))
  85
  86 (define (sr-less? sr1 sr2)
  87   (let ((s1 (if (cdr (assoc 'speed sr1)) (cdr (assoc 'speed sr1)) (defspeed sr1)))
  88         (s2 (if (cdr (assoc 'speed sr2)) (cdr (assoc 'speed sr2)) (defspeed sr2))))
  89     (if (= s1 s2)
  90         (< (cdr (assoc 'resptime sr1)) (cdr (assoc 'resptime sr2)))
  91         (> s1 s2)))
  92   )
  93
  94 (define (srg-less? g1 g2)
  95   (or (> (length (cdr g1)) (length (cdr g2)))
  96       (and (= (length (cdr g1)) (length (cdr g2)))
  97            (> (car g1) (car g2))))
  98   )
  99
 100 (define (gettrbysize size)
 101   (catch 'ret
 102          (lambda ()
 103            (for-each (lambda (o)
 104                        (if (= (cdr (assoc 'size (cdr o))) size)
 105                            (throw 'ret (cdr o))))
 106                      trans)
 107            #f)
 108          (lambda (sig ret)
 109            ret))
 110   )
 111
 112 (define (download sr)
 113   (let ((resp #f))
 114     (let ((args (list "download"
 115                       (car (cdr (assoc 'peer sr)))
 116                       (cadr (cdr (assoc 'peer sr)))
 117                       (cdr (assoc 'filename sr))
 118                       (cdr (assoc 'size sr)))))
 119       (let ((hash (assoc 'hash sr)))
 120         (if (and hash (not (equal? (cdr hash) ""))) (set! args (append args (list "hash" (cdr hash))))))
 121       (let ((tag (assoc 'tag session)))
 122         (if tag (set! args (append args (list "tag" (cdr tag))))))
 123       (let ((uarg (assoc 'uarg session)))
 124         (if uarg (set! args (append args (list "user" (cdr uarg))))))
 125       (let ((xargs (assoc 'xargs session)))
 126         (if xargs (for-each (lambda (o)
 127                               (set! args (append args (list (car o) (cdr o)))))
 128                            (cdr xargs))))
 129       (set! resp (apply dc-ecmd-assert 200 args)))
 130     (let ((id (car (dc-intresp resp))))
 131       (set! trans
 132             (cons (cons id (list (assoc 'size sr)
 133                                  (assoc 'peer sr)
 134                                  (assoc 'filename sr)
 135                                  (assoc 'resptime sr)
 136                                  '(curpos . 0)
 137                                  '(state . wait)
 138                                  '(curspeed . #f)
 139                                  '(lastpos . 0)
 140                                  (cons 'id id)
 141                                  (cons 'lasttime (current-time))
 142                                  (cons 'lastprog (current-time))))
 143                   trans))
 144       (logf (string-append "downloading "
 145                            (cdr (assoc 'filename sr))
 146                            " from "
 147                            (cadr (cdr (assoc 'peer sr)))
 148                            ", "
 149                            (number->string (cdr (assoc 'size sr)))
 150                            " bytes (id "
 151                            (number->string id)
 152                            ", "
 153                            (number->string (cdr (assoc 'slots sr)))
 154                            " slots), timing out in "
 155                            (number->string (max 10 (* (cdr (assoc 'resptime sr)) 2)))
 156                            " seconds"))))
 157   (set! lastdl (current-time))
 158   )
 159
 160 (define (disablepeer peer)
 161   (let ((newglist '()) (numrem 0))
 162     (for-each (lambda (g)
 163                 (let ((newlist '()))
 164                   (for-each (lambda (o)
 165                               (if (not (equal? (cdr (assoc 'peer o)) peer))
 166                                   (set! newlist (cons o newlist))
 167                                   (set! numrem (+ numrem 1))))
 168                             (cdr g))
 169                   (if (not (eq? newlist '()))
 170                       (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
 171               sr)
 172     (set! sr (sort newglist srg-less?))
 173     (logf (string-append "disabled " (cadr peer) " and removed " (number->string numrem) " search results")))
 174   (let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
 175     (if dp
 176         (set-cdr! (assoc 'time dp) (current-time))
 177         (set! dpeers (cons (cons peer (list (cons 'time (current-time))
 178                                             (cons 'peer peer)))
 179                            dpeers))))
 180   )
 181
 182 (define (checktrans)
 183   (let ((time (current-time)))
 184     (for-each (lambda (o)
 185                 (if (and (memq (cdr (assoc 'state (cdr o))) '(wait hs))
 186                          (> (- time (cdr (assoc 'lastprog (cdr o)))) (max 10 (* (cdr (assoc 'resptime (cdr o))) 2))))
 187                     (begin (logf (string-append "transfer " (number->string (car o)) " timing out"))
 188                            (dc-ecmd-assert 200 "cancel" (car o))
 189                            (disablepeer (cdr (assoc 'peer (cdr o))))
 190                            (set! trans (assq-remove! trans (car o)))
 191                            (write-info-file)))
 192                 (if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
 193                          (> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
 194                     (begin (logf (string-append "transfer " (number->string (car o)) " seems to have stalled"))
 195                            (dc-ecmd-assert 200 "cancel" (car o))
 196                            (set! trans (assq-remove! trans (car o)))
 197                            (write-info-file)))
 198                 (if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
 199                          (> (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o)))) 20))
 200                     (begin (set-cdr! (assoc 'curspeed (cdr o))
 201                                      (/ (- (cdr (assoc 'curpos (cdr o))) (cdr (assoc 'lastpos (cdr o))))
 202                                         (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o))))))
 203                            (set-cdr! (assoc 'lastpos (cdr o)) (cdr (assoc 'curpos (cdr o))))
 204                            (set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o))))
 205                            (write-info-file))))
 206                 trans))
 207   )
 208
 209 (define (write-info-file)
 210   (if (assoc 'info-file session)
 211       (let ((op (open-output-file (cdr (assoc 'info-file session)))))
 212         (write (list (cons 'numdl (length trans))
 213                      (cons 'lastdl lastdl)
 214                      (cons 'availsr info-numavail)
 215                      (cons 'realsr info-numreal)
 216                      (cons 'totalsr info-numtotal)
 217                      (cons 'lastsrch lastsearch)
 218                      (cons 'srcheta info-searcheta)
 219                      (cons 'srchmode (cdr (assoc 'search-mode session))))
 220                op)
 221         (newline op)
 222         (close-port op))))
 223
 224 (define (parseresults)
 225   (logf (string-append "entering parseresults with "
 226                        (number->string
 227                         (apply + (map (lambda (o) (length (cdr o))) sr)))
 228                        " results in "
 229                        (number->string (length sr))
 230                        " sizes"))
 231   (let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
 232     (catch 'ret
 233            (lambda ()
 234              (and (eq? sr '()) (throw 'ret #f))
 235              (let ((numrem 0) (countrem 0) (newglist '()))
 236                (for-each (lambda (g)
 237                            (let ((newlist '()))
 238                              (for-each (lambda (o)
 239                                          (if (< (- (current-time) (cdr (assoc 'recvtime o))) 300)
 240                                              (set! newlist (cons o newlist))
 241                                              (set! countrem (+ countrem 1))))
 242                                        (cdr g))
 243                              (if (> (length newlist) 0)
 244                                  (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
 245                                  (set! numrem (+ numrem 1)))))
 246                          sr)
 247                (set! sr (sort newglist srg-less?))
 248                (if (> countrem 0)
 249                    (logf (string-append "removed " (number->string countrem) " time-outed results and " (number->string numrem) " entire sizes"))))
 250              (let ((numrem 0) (newlist '()))
 251                (for-each (lambda (o)
 252                            (if (> (- (current-time) (cdr (assoc 'time o))) 1800)
 253                                (set! numrem (+ numrem 1))
 254                                (set! newlist (cons o newlist))))
 255                          dpeers)
 256                (set! dpeers newlist)
 257                (logf (string-append "re-enabled " (number->string numrem) " disabled users")))
 258              (let ((numrem 0) (countrem 0) (newglist '()))
 259                (for-each (lambda (g)
 260                            (let ((newlist '()))
 261                              (for-each (lambda (o)
 262                                          (if (not (assoc (cdr (assoc 'peer o)) dpeers))
 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)
 272                    (logf (string-append "removed " (number->string countrem) " results with disabled peers and " (number->string numrem) " entire sizes"))))
 273              (and (eq? sr '()) (throw 'ret #f))
 274              (set! numtotal (apply + (map (lambda (o) (length (cdr o))) sr)))
 275              (let* ((maxsize (apply max (map (lambda (o) (length (cdr o))) sr)))
 276                     (minsize (/ maxsize 3)))
 277                (let ((numrem 0) (countrem 0))
 278                  (for-each (lambda (o) (if (< (length (cdr o)) minsize)
 279                                            (begin (set! countrem (+ countrem (length (cdr o))))
 280                                                   (set! numrem (+ numrem 1)))))
 281                            sr)
 282                  (if (> countrem 0)
 283                      (logf (string-append "will disregard " (number->string countrem) " results from " (number->string numrem) " sizes due to popularity lack")))
 284                  (set! numreal (- numtotal countrem)))
 285                (let ((numrem 0) (numrrem 0))
 286                  (for-each (lambda (g)
 287                              (for-each (lambda (o)
 288                                          (if (< (cdr (assoc 'slots o)) 1)
 289                                              (begin (set! numrem (+ numrem 1))
 290                                                     (if (>= (length (cdr g)) minsize)
 291                                                         (set! numrrem (+ numrrem 1))))))
 292                                        (cdr g)))
 293                            sr)
 294                  (if (> numrem 0)
 295                      (logf (string-append (number->string numrem) " results had no slots")))
 296                  (set! numavail (- numreal numrrem)))
 297                (for-each (lambda (g)
 298                            (if (>= (length (cdr g)) minsize)
 299                                (catch 'found
 300                                       (lambda ()
 301                                         (for-each (lambda (o)
 302                                                     (and (> (cdr (assoc 'slots o)) 0)
 303                                                          (throw 'found o)))
 304                                                   (cdr g)))
 305                                       (lambda (sig sr)
 306                                         (let ((tr (gettrbysize (cdr (assoc 'size sr)))))
 307                                           (if (not tr)
 308                                               (if (< (length trans) (cdr (assoc 'maxtrans session)))
 309                                                   (download sr))
 310                                               (if (and (cdr (assoc 'curspeed tr))
 311                                                        (not (equal? (cdr (assoc 'peer sr)) (cdr (assoc 'peer tr))))
 312                                                        (> (- (or (cdr (assoc 'speed sr)) (defspeed sr)) (cdr (assoc 'curspeed tr))) 10000))
 313                                                   (begin (logf (string-append "abandoning transfer "
 314                                                                               (number->string (cdr (assoc 'id tr)))
 315                                                                               " for possible faster sender"))
 316                                                          (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
 317                                                          (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
 318                                                          (download sr)))))))))
 319                          sr)
 320                )
 321              )
 322            (lambda (sig ret)
 323              (set! retval ret)
 324              ))
 325     (set! info-numavail numavail)
 326     (set! info-numreal numreal)
 327     (set! info-numtotal numtotal)
 328     (write-info-file)
 329     retval)
 330   )
 331
 332 (define (handlesr filename fnet peer size slots resptime hash)
 333   (if (eq? (cdr (assoc 'search-mode session)) 'wait)
 334       (begin (set-cdr! (assoc 'search-mode session) 'normal)
 335              (logf "reverting to normal mode")))
 336   (let ((cl (or (assoc size sr)
 337                 (let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
 338         (newsr (list
 339                 (cons 'filename filename)
 340                 (cons 'peer (list fnet peer))
 341                 (cons 'size size)
 342                 (cons 'slots slots)
 343                 (cons 'resptime resptime)
 344                 (cons 'speed (getspeed peer))
 345                 (cons 'hash hash)
 346                 (cons 'recvtime (current-time))
 347                 (cons 'dis #f)))
 348         (newlist '()))
 349     (for-each (lambda (o) (if (not (and (equal? (cdr (assoc 'filename o)) filename)
 350                                         (equal? (cdr (assoc 'peer o)) (list fnet peer))))
 351                               (set! newlist (cons o newlist))))
 352               (cdr cl))
 353     (set-cdr! cl (sort (cons newsr newlist) sr-less?))
 354     )
 355   )
 356
 357 ; XXX: Redefine to go through the server, once that is implemented
 358 (define (getspeed username)
 359   (catch 'system-error
 360          (lambda ()
 361            (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))))
 362              (do ((i 0 (+ i 1))) ((= i numents) (close-port port) (/ avg numents)) (set! avg (+ avg (string->number (read-line port)))))
 363            ))
 364          (lambda args
 365            #f
 366            )
 367          )
 368   )
 369
 370 (define (validate-session session)
 371   (catch 'wrong-type-arg
 372          (lambda ()
 373            (and
 374             (assoc 'sexpr session)
 375             (assoc 'prio session)
 376             (assoc 'maxtrans session)
 377             #t
 378             )
 379            )
 380          (lambda (key . args)
 381            (display "Session data is not an a-list\n" (current-error-port))
 382            #f)
 383          )
 384   )
 385
 386 (define (autodl-main args)
 387   (let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
 388     (let ((getopt (make-getopt (cdr args) "whs:S:e:p:t:a:I:E:x:")) (arg #f))
 389       (do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
 390         (cond ((eq? (car arg) #\h)
 391                (begin (display "usage: autodl [-s server] -S sessfile\n" (current-error-port))
 392                       (display "       autodl [-w] [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
 393                       (display "       autodl [-s server]\n" (current-error-port))
 394                       (display "       autodl -h\n" (current-error-port))
 395                       (exit 0)))
 396               ((eq? (car arg) #\s)
 397                (set! dc-server (cdr arg)))
 398               ((eq? (car arg) #\S)
 399                (let ((port (open-file (cdr arg)))) (set! session (read port)) (close-port port)))
 400               ((eq? (car arg) #\p)
 401                (let ((c (assoc 'prio session)))
 402                  (if c (set-cdr! c (cdr arg))
 403                      (set! session (cons (cons 'prio (cdr arg)) session)))))
 404               ((eq? (car arg) #\t)
 405                (let ((c (assoc 'tag session)))
 406                  (if c (set-cdr! c (cdr arg))
 407                      (set! session (cons (cons 'tag (cdr arg)) session)))))
 408               ((eq? (car arg) #\a)
 409                (let ((c (assoc 'uarg session)))
 410                  (if c (set-cdr! c (cdr arg))
 411                      (set! session (cons (cons 'uarg (cdr arg)) session)))))
 412               ((eq? (car arg) #\I)
 413                (let ((c (assoc 'info-file session)))
 414                  (if c (set-cdr! c (cdr arg))
 415                      (set! session (cons (cons 'info-file (cdr arg)) session)))))
 416               ((eq? (car arg) #\E)
 417                (let ((c (assoc 'estat-file session)))
 418                  (if c (set-cdr! c (cdr arg))
 419                      (set! session (cons (cons 'estat-file (cdr arg)) session)))))
 420               ((eq? (car arg) #\e)
 421                (set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session)))
 422               ((eq? (car arg) #\w)
 423                (set! session (cons '(search-mode . wait) session)))
 424               ((eq? (car arg) #\x)
 425                (let* ((c (assoc 'xargs session)) (p (string-index (cdr arg) #\=))
 426                       (recons (cons (substring (cdr arg) 0 p) (substring (cdr arg) (1+ p)))))
 427                  (if c (set-cdr! c (cons recons (cdr c)))
 428                      (set! session (cons (cons 'xargs (list recons)) session)))))
 429               )
 430         )
 431       )
 432     (if (eq? session '()) (begin (if (isatty? (current-input-port)) (display "Enter session data (s-expr):\n" (current-error-port))) (set! session (read))))
 433     (if (not (assoc 'prio session))
 434         (set! session (cons '(prio . 10) session)))
 435     (if (not (assoc 'maxtrans session))
 436         (set! session (cons '(maxtrans . 1) session)))
 437     (if (not (assoc 'search-mode session))
 438         (set! session (cons '(search-mode . normal) session)))
 439     (if (not (validate-session session)) (begin (display "Invalid session!\n" (current-error-port)) (exit 1)))
 440     (if (not dc-server) (set! dc-server (getenv "DCSERVER")))
 441     (if (not dc-server) (set! dc-server "localhost"))
 442     (catch 'system-error
 443            (lambda ()
 444              (dc-c&l #t dc-server #t))
 445            (lambda (key . args)
 446              (logf (string-append "could not connect to server: " (apply format #f (cadr args) (caddr args))))
 447              (exit 2)))
 448     (dc-ecmd-assert 200 "notify" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
 449     (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
 450     (catch 'sig
 451            (lambda ()
 452              (while #t
 453                     (if (and (not (= lastsearch -1)) (wanttosearch))
 454                         (begin
 455                           (if (not (= srchid -1))
 456                               (dc-ecmd "cansrch" srchid))
 457                           (let* ((resp (apply dc-ecmd-assert (append (list '(200 501 509) "search" "prio" (number->string (cdr (assoc 'prio session))) "all") (cdr (assoc 'sexpr session)))))
 458                                  (ires (dc-intresp resp))
 459                                  (eres (dc-extract resp)))
 460                             (case (cdr (assoc 'code eres))
 461                               ((200)
 462                                (begin (set! srchid (car ires))
 463                                       (logf (string-append "search scheduled in " (number->string (cadr ires)) " seconds (id " (number->string srchid) ")"))
 464                                       (set! info-searcheta (+ (current-time) (cadr ires)))
 465                                       (set! lastsearch -1)
 466                                       (write-info-file)))
 467                               ((501)
 468                                (begin (set! srchid -1)
 469                                       (logf (string-append "no fnetnodes available to search on"))
 470                                       (set! lastsearch (current-time))))
 471                               ((509)
 472                                (begin (logf "illegal search expression")
 473                                       (set! done #t)
 474                                       (set! retval 3)
 475                                       (throw 'sig 0)))))))
 476                     (checktrans)
 477                     (if (> (- (current-time) lastparse) 20)
 478                         (begin (parseresults)
 479                                (set! lastparse (current-time))))
 480                     (dc-select 10000)
 481                     (while (let ((resp (dc-getresp)))
 482                              (if resp
 483                                  (begin
 484                                    (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
 485                                      (cond
 486                                        ((equal? cmd ".notify")
 487                                         (case code
 488                                           ((611) ; Transfer state change
 489                                            (let ((ires (dc-intresp resp)) (tr #f))
 490                                              (if (and ires (assoc (car ires) trans))
 491                                                  (begin (set! tr (cdr (assoc (car ires) trans)))
 492                                                         (set-cdr! (assoc 'state tr)
 493                                                                   (cdr (assoc (cadr ires) '((0 . wait) (1 . hs) (2 . main) (3 . done)))))
 494                                                         (set-cdr! (assoc 'lastprog tr) (current-time))))))
 495                                           ((614) ; Transfer error
 496                                            (let ((ires (dc-intresp resp)))
 497                                              (if (and ires (assoc (car ires) trans))
 498                                                  (begin (logf (string-append "transfer " (number->string (car ires)) " encountered error " (number->string (cadr ires))))
 499                                                         (dc-ecmd-assert 200 "cancel" (car ires))
 500                                                         (let ((tr (cdr (assoc (car ires) trans))))
 501                                                           (disablepeer (cdr (assoc 'peer tr))))
 502                                                         (set! trans (assq-remove! trans (car ires)))))))
 503                                           ((615) ; Transfer progress
 504                                            (let ((ires (dc-intresp resp)) (tr #f))
 505                                              (if (and ires (assoc (car ires) trans))
 506                                                  (begin (set! tr (cdr (assoc (car ires) trans)))
 507                                                         (set-cdr! (assoc 'curpos tr) (cadr ires))
 508                                                         (set-cdr! (assoc 'lastprog tr) (current-time))))))
 509                                           ((617) ; Transfer destroyed
 510                                            (let* ((ires (dc-intresp resp)) (tr (and ires (assoc (car ires) trans))))
 511                                              (if tr
 512                                                  (begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
 513                                                             (begin (logf (string-append "transfer " (number->string (car ires)) " done (" (cadr ires) ")"))
 514                                                                    (set! trans (assq-remove! trans (car ires)))
 515                                                                    (set! done #t)
 516                                                                    (set! filterexit (cadr ires))
 517                                                                    (throw 'sig 0))
 518                                                             (begin (logf (string-append "transfer " (number->string (car ires)) " disappeared"))
 519                                                                    (set! trans (assq-remove! trans (car ires)))))))))
 520                                           ((620) ; Search rescheduled
 521                                            (let ((ires (dc-intresp resp)))
 522                                              (if (and ires (= (car ires) srchid))
 523                                                  (begin (set! info-searcheta (+ (current-time) (cadr ires)))
 524                                                         (logf (string-append "search rescheduled to T+" (number->string (cadr ires))))
 525                                                         (write-info-file)))))
 526                                           ((621) ; Search committed
 527                                            (let ((ires (dc-intresp resp)))
 528                                              (if (and ires (= (car ires) srchid))
 529                                                  (begin (logf "search committed")
 530                                                         (set! info-searcheta 0)
 531                                                         (set! lastsearch (current-time))
 532                                                         (write-info-file)))))
 533                                           ((622) ; Search result
 534                                            (let ((ires (list->vector (dc-intresp resp))))
 535                                              (if (and ires (= (vector-ref ires 0) srchid)) (apply handlesr (map (lambda (n) (vector-ref ires n)) '(1 2 3 4 5 7 8))))))
 536
 537                                           )
 538                                         )
 539
 540                                        )
 541                                      )
 542                                    #t)
 543                                  #f)
 544                              )
 545                            #t
 546                            )
 547                     )
 548              )
 549            (lambda (key sig)
 550              (logf (string-append "interrupted by signal " (number->string sig)))
 551              (if (not done)
 552                  (set! retval 1)))
 553            )
 554     (logf "quitting...")
 555     (catch 'sig
 556            (lambda ()
 557              (if (dc-connected)
 558                  (begin (for-each (lambda (o)
 559                                     (dc-qcmd (list "cancel" (car o))))
 560                                   trans)
 561                         (if (assoc 'info-file session)
 562                             (catch 'system-error
 563                                    (lambda ()
 564                                      (delete-file (cdr (assoc 'info-file session))))
 565                                    (lambda (key . args) #t)))
 566                         (if (and done (assoc 'tag session))
 567                             (dc-qcmd (list "filtercmd" "rmtag" (cdr (assoc 'tag session)))))
 568                         (if (not (= srchid -1))
 569                             (dc-qcmd (list "cansrch" srchid)))
 570                         (dc-qcmd '("quit"))
 571                         (while (dc-connected) (dc-select))
 572                         )))
 573            (lambda (key sig)
 574              (logf "forcing quit")))
 575     (if (assoc 'estat-file session)
 576         (let ((op (open-output-file (cdr (assoc 'estat-file session)))))
 577           (display filterexit op)
 578           (newline op)
 579           (close-port op)))
 580     (exit retval)
 581     )
 582   )
 583
 584 (setlocale LC_ALL "")
 585 (autodl-main (command-line))