| 1 | #!/usr/bin/guile -s |
| 2 | !# |
| 3 | |
| 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 | |
| 21 | (use-modules (dolcon ui)) |
| 22 | (use-modules (ice-9 pretty-print) (ice-9 rdelim)) |
| 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) |
| 36 | (define logport (current-output-port)) |
| 37 | (define infoport #f) |
| 38 | |
| 39 | (define (logf fmt . msg) |
| 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 | |
| 48 | (define (infomsg fmt . msg) |
| 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)))) |
| 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) |
| 95 | (if (eq? (cdr (assoc 'search-mode session)) 'wait) |
| 96 | 7200 |
| 97 | (if (> (length trans) 0) 300 60))) |
| 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))))) |
| 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))))) |
| 158 | (cdr xargs)))) |
| 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)) |
| 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)) |
| 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))) |
| 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?)) |
| 198 | (logf "disabled ~a and removed ~a search results" (cadr peer) numrem)) |
| 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)))) |
| 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))) |
| 217 | (write-info-file))) |
| 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))) |
| 224 | (write-info-file))) |
| 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)))) |
| 232 | (write-info-file)))) |
| 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))))) |
| 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) |
| 248 | (close-port op)))) |
| 249 | |
| 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)) |
| 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) |
| 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)))) |
| 278 | dpeers) |
| 279 | (set! dpeers newlist) |
| 280 | (logf "re-enabled ~a disabled users" numrem)) |
| 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) |
| 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))))) |
| 304 | sr) |
| 305 | (if (> countrem 0) |
| 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)))))) |
| 315 | (cdr g))) |
| 316 | sr) |
| 317 | (if (> numrem 0) |
| 318 | (logf "~a results had no slots" numrem)) |
| 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)) |
| 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))))))))) |
| 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) |
| 351 | (infomsg "srs ~a ~a ~a" numtotal numreal numavail) |
| 352 | (write-info-file) |
| 353 | retval) |
| 354 | ) |
| 355 | |
| 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))) |
| 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)) |
| 370 | (cons 'hash hash) |
| 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) |
| 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)) |
| 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))))) |
| 441 | ((eq? (car arg) #\i) |
| 442 | (set! infoport logport) |
| 443 | (set! logport #f)) |
| 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))))) |
| 448 | ((eq? (car arg) #\e) |
| 449 | (set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session))) |
| 450 | ((eq? (car arg) #\w) |
| 451 | (set! session (cons '(search-mode . wait) session))) |
| 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))))) |
| 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))) |
| 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))) |
| 468 | (catch 'system-error |
| 469 | (lambda () |
| 470 | (dc-c&l #f dc-server #t)) |
| 471 | (lambda (key . args) |
| 472 | (logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args))) |
| 473 | (exit 2))) |
| 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)) |
| 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)) |
| 489 | (logf "search scheduled in ~a seconds (id ~a)" |
| 490 | (cadr ires) |
| 491 | srchid) |
| 492 | (infomsg "search pending ~a" (cadr ires)) |
| 493 | (set! info-searcheta (+ (current-time) (cadr ires))) |
| 494 | (set! lastsearch -1) |
| 495 | (write-info-file))) |
| 496 | ((501) |
| 497 | (begin (set! srchid -1) |
| 498 | (logf "no fnetnodes available to search on") |
| 499 | (infomsg "nofns") |
| 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)))) |
| 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)) |
| 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)))) |
| 542 | (if tr |
| 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))) |
| 548 | (set! done #t) |
| 549 | (set! filterexit (cadr ires)) |
| 550 | (throw 'sig 0)) |
| 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)))))) |
| 572 | |
| 573 | ) |
| 574 | ) |
| 575 | |
| 576 | ) |
| 577 | ) |
| 578 | #t) |
| 579 | #f) |
| 580 | ) |
| 581 | #t |
| 582 | ) |
| 583 | ) |
| 584 | ) |
| 585 | (lambda (key sig) |
| 586 | (logf "interrupted by signal ~a" sig) |
| 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"))) |
| 611 | (if (assoc 'estat-file session) |
| 612 | (let ((op (open-output-file (cdr (assoc 'estat-file session))))) |
| 613 | (display filterexit op) |
| 614 | (newline op) |
| 615 | (close-port op))) |
| 616 | (exit retval) |
| 617 | ) |
| 618 | ) |
| 619 | |
| 620 | (setlocale LC_ALL "") |
| 621 | (autodl-main (command-line)) |