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