[doldaconnect.git] / lib / guile / autodl

#!/usr/bin/guile -s
!#

(use-modules (dolcon ui))
(use-modules (ice-9 pretty-print))

(define sr '())
(define lastsearch 0)
(define info-searcheta 0)
(define info-numavail 0)
(define info-numreal 0)
(define info-numtotal 0)
(define lastparse 0)
(define srchid -1)
(define session '())
(define trans '())
(define dpeers '())
(define lastdl 0)

(define (logf fmt . msg)
  (apply format (cons* (current-output-port) (string-append fmt "\n") msg))
  (catch 'system-error (lambda ()
			 (fsync (current-output-port)))
	 (lambda (key . err) #f))
  )

(define (make-getopt opts optdesc)
  (let ((arg opts) (curpos 0) (rest '()))
    (lambda ()
      (if (eq? arg '()) rest
	  (let ((ret #f))
	    (while (not ret)
		   (if (= curpos 0)
		       (if (eq? (string-ref (car arg) 0) #\-)
			   (set! curpos 1)
			   (begin
			     (set! rest (append rest (list (car arg))))
			     (set! arg (cdr arg))
			     (if (eq? arg '())
				 (set! ret #t)))))
		   (if (> curpos 0)
		       (if (< curpos (string-length (car arg)))
			   (begin (set! ret (string-ref (car arg) curpos)) (set! curpos (+ curpos 1)))
			   (begin (set! curpos 0) (set! arg (cdr arg)) (if (eq? arg '()) (set! ret #t))))))
	    (if (eq? ret #t) rest
		(let ((opt (string-index optdesc ret)))
		  (if (eq? opt #f) (throw 'illegal-option ret)
		      (if (and (< opt (- (string-length optdesc) 1)) (eq? (string-ref optdesc (+ opt 1)) #\:))
			  (let ((ret
				 (cons ret (let ((optarg
						  (if (< curpos (string-length (car arg)))
						      (substring (car arg) curpos)
						      (begin (set! arg (cdr arg)) (if (eq? arg '()) (throw 'requires-argument ret)) (car arg)))))
					     (set! arg (cdr arg)) optarg))))
			    (set! curpos 0)
			    ret)
			  (list ret))))))))))

(define (ftime)
  (let ((ctime (gettimeofday)))
    (+ (car ctime) (/ (cdr ctime) 1000000))))

(define (wanttosearch)
  (> (- (current-time) lastsearch)
     (if (eq? (cdr (assoc 'search-mode session)) 'wait)
	 7200
	 (if (> (length trans) 0) 300 60)))
  )

(define defspeed '())
(let ((matchlist (list
		  (cons (make-regexp "^[][{}() ]*BBB" regexp/icase) 100000))))
  (set! defspeed
	(lambda (sr)
	  (catch 'ret
		 (lambda ()
		   (for-each (lambda (o)
			       (if (regexp-exec (car o) (cadr (cdr (assoc 'peer sr))))
				   (throw 'ret (cdr o))))
			     matchlist)
		   15000)
		 (lambda (sig ret)
		   ret))
	  )))

(define (sr-less? sr1 sr2)
  (let ((s1 (if (cdr (assoc 'speed sr1)) (cdr (assoc 'speed sr1)) (defspeed sr1)))
	(s2 (if (cdr (assoc 'speed sr2)) (cdr (assoc 'speed sr2)) (defspeed sr2))))
    (if (= s1 s2)
	(< (cdr (assoc 'resptime sr1)) (cdr (assoc 'resptime sr2)))
	(> s1 s2)))
  )

(define (srg-less? g1 g2)
  (or (> (length (cdr g1)) (length (cdr g2)))
      (and (= (length (cdr g1)) (length (cdr g2)))
	   (> (car g1) (car g2))))
  )

(define (gettrbysize size)
  (catch 'ret
	 (lambda ()
	   (for-each (lambda (o)
		       (if (= (cdr (assoc 'size (cdr o))) size)
			   (throw 'ret (cdr o))))
		     trans)
	   #f)
	 (lambda (sig ret)
	   ret))
  )

(define (download sr)
  (let ((resp #f))
    (let ((args (list "download"
		      (car (cdr (assoc 'peer sr)))
		      (cadr (cdr (assoc 'peer sr)))
		      (cdr (assoc 'filename sr))
		      (cdr (assoc 'size sr)))))
      (let ((hash (assoc 'hash sr)))
	(if (and hash (not (equal? (cdr hash) ""))) (set! args (append args (list "hash" (cdr hash))))))
      (let ((tag (assoc 'tag session)))
	(if tag (set! args (append args (list "tag" (cdr tag))))))
      (let ((uarg (assoc 'uarg session)))
	(if uarg (set! args (append args (list "user" (cdr uarg))))))
      (let ((xargs (assoc 'xargs session)))
	(if xargs (for-each (lambda (o)
			      (set! args (append args (list (car o) (cdr o)))))
			   (cdr xargs))))
      (set! resp (apply dc-ecmd-assert 200 args)))
    (let ((id (car (dc-intresp resp))))
      (set! trans
	    (cons (cons id (list (assoc 'size sr)
				 (assoc 'peer sr)
				 (assoc 'filename sr)
				 (assoc 'resptime sr)
				 '(curpos . 0)
				 '(state . wait)
				 '(curspeed . #f)
				 '(lastpos . 0)
				 (cons 'id id)
				 (cons 'lasttime (current-time))
				 (cons 'lastprog (current-time))))
		  trans))
      (logf "downloading ~a from ~a, ~a bytes (id ~a, ~a slots), timing out in ~a seconds"
	    (cdr (assoc 'filename sr))
	    (cadr (cdr (assoc 'peer sr)))
	    (number->string (cdr (assoc 'size sr)))
	    (number->string id)
	    (number->string (cdr (assoc 'slots sr)))
	    (number->string (max 10 (* (cdr (assoc 'resptime sr)) 2))))))
  (set! lastdl (current-time))
  )

(define (disablepeer peer)
  (let ((newglist '()) (numrem 0))
    (for-each (lambda (g)
		(let ((newlist '()))
		  (for-each (lambda (o)
			      (if (not (equal? (cdr (assoc 'peer o)) peer))
				  (set! newlist (cons o newlist))
				  (set! numrem (+ numrem 1))))
			    (cdr g))
		  (if (not (eq? newlist '()))
		      (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
	      sr)
    (set! sr (sort newglist srg-less?))
    (logf "disabled ~a and removed ~a search results" (cadr peer) numrem))
  (let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
    (if dp
	(set-cdr! (assoc 'time dp) (current-time))
	(set! dpeers (cons (cons peer (list (cons 'time (current-time))
					    (cons 'peer peer)))
			   dpeers))))
  )

(define (checktrans)
  (let ((time (current-time)))
    (for-each (lambda (o)
		(if (and (memq (cdr (assoc 'state (cdr o))) '(wait hs))
			 (> (- time (cdr (assoc 'lastprog (cdr o)))) (max 10 (* (cdr (assoc 'resptime (cdr o))) 2))))
		    (begin (logf "transfer ~a timing out" (car o))
			   (dc-ecmd-assert 200 "cancel" (car o))
			   (disablepeer (cdr (assoc 'peer (cdr o))))
			   (set! trans (assq-remove! trans (car o)))
			   (write-info-file)))
		(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
			 (> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
		    (begin (logf "transfer ~a seems to have stalled" (car o))
			   (dc-ecmd-assert 200 "cancel" (car o))
			   (set! trans (assq-remove! trans (car o)))
			   (write-info-file)))
		(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
			 (> (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o)))) 20))
		    (begin (set-cdr! (assoc 'curspeed (cdr o))
				     (/ (- (cdr (assoc 'curpos (cdr o))) (cdr (assoc 'lastpos (cdr o))))
					(- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o))))))
			   (set-cdr! (assoc 'lastpos (cdr o)) (cdr (assoc 'curpos (cdr o))))
			   (set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o))))
			   (write-info-file))))
		trans))
  )

(define (write-info-file)
  (if (assoc 'info-file session)
      (let ((op (open-output-file (cdr (assoc 'info-file session)))))
	(pretty-print (list (cons 'numdl (length trans))
			    (cons 'lastdl lastdl)
			    (cons 'availsr info-numavail)
			    (cons 'realsr info-numreal)
			    (cons 'totalsr info-numtotal)
			    (cons 'lastsrch lastsearch)
			    (cons 'srcheta info-searcheta)
			    (cons 'srchmode (cdr (assoc 'search-mode session))))
		      op)
	(close-port op))))

(define (parseresults)
  (logf "entering parseresults with ~a results in ~a sizes"
	(apply + (map (lambda (o) (length (cdr o))) sr))
	(number->string (length sr)))
  (let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
    (catch 'ret
	   (lambda ()
	     (and (eq? sr '()) (throw 'ret #f))
	     (let ((numrem 0) (countrem 0) (newglist '()))
	       (for-each (lambda (g)
			   (let ((newlist '()))
			     (for-each (lambda (o)
					 (if (< (- (current-time) (cdr (assoc 'recvtime o))) 300)
					     (set! newlist (cons o newlist))
					     (set! countrem (+ countrem 1))))
				       (cdr g))
			     (if (> (length newlist) 0)
				 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
				 (set! numrem (+ numrem 1)))))
			 sr)
	       (set! sr (sort newglist srg-less?))
	       (if (> countrem 0)
		   (logf "removed ~a time-outed results and ~a entire sizes" countrem numrem)))
	     (let ((numrem 0) (newlist '()))
	       (for-each (lambda (o)
			   (if (> (- (current-time) (cdr (assoc 'time o))) 1800)
			       (set! numrem (+ numrem 1))
			       (set! newlist (cons o newlist))))
			 dpeers)
	       (set! dpeers newlist)
	       (logf "re-enabled ~a disabled users" numrem))
	     (let ((numrem 0) (countrem 0) (newglist '()))
	       (for-each (lambda (g)
			   (let ((newlist '()))
			     (for-each (lambda (o)
					 (if (not (assoc (cdr (assoc 'peer o)) dpeers))
					     (set! newlist (cons o newlist))
					     (set! countrem (+ countrem 1))))
				       (cdr g))
			     (if (> (length newlist) 0)
				 (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
				 (set! numrem (+ numrem 1)))))
			 sr)
	       (set! sr (sort newglist srg-less?))
	       (if (> countrem 0)
		   (logf "removed ~a results with disabled peers and ~a entire sizes" countrem numrem)))
	     (and (eq? sr '()) (throw 'ret #f))
	     (set! numtotal (apply + (map (lambda (o) (length (cdr o))) sr)))
	     (let* ((maxsize (apply max (map (lambda (o) (length (cdr o))) sr)))
		    (minsize (/ maxsize 3)))
	       (let ((numrem 0) (countrem 0))
		 (for-each (lambda (o) (if (< (length (cdr o)) minsize)
					   (begin (set! countrem (+ countrem (length (cdr o))))
						  (set! numrem (+ numrem 1)))))
			   sr)
		 (if (> countrem 0)
		     (logf "will disregard ~a results from ~a sizes due to popularity lack" countrem numrem))
		 (set! numreal (- numtotal countrem)))
	       (let ((numrem 0) (numrrem 0))
		 (for-each (lambda (g)
			     (for-each (lambda (o)
					 (if (< (cdr (assoc 'slots o)) 1)
					     (begin (set! numrem (+ numrem 1))
						    (if (>= (length (cdr g)) minsize)
							(set! numrrem (+ numrrem 1))))))
				       (cdr g)))
			   sr)
		 (if (> numrem 0)
		     (logf "~a results had no slots" numrem))
		 (set! numavail (- numreal numrrem)))
	       (for-each (lambda (g)
			   (if (>= (length (cdr g)) minsize)
			       (catch 'found
				      (lambda ()
					(for-each (lambda (o)
						    (and (> (cdr (assoc 'slots o)) 0)
							 (throw 'found o)))
						  (cdr g)))
				      (lambda (sig sr)
					(let ((tr (gettrbysize (cdr (assoc 'size sr)))))
					  (if (not tr)
					      (if (< (length trans) (cdr (assoc 'maxtrans session)))
						  (download sr))
					      (if (and (cdr (assoc 'curspeed tr))
						       (not (equal? (cdr (assoc 'peer sr)) (cdr (assoc 'peer tr))))
						       (> (- (or (cdr (assoc 'speed sr)) (defspeed sr)) (cdr (assoc 'curspeed tr))) 10000))
						  (begin (logf "abandoning transfer ~a for possible faster sender"
									      (cdr (assoc 'id tr)))
							 (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
							 (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
							 (download sr)))))))))
			 sr)
	       )
	     )
	   (lambda (sig ret)
	     (set! retval ret)
	     ))
    (set! info-numavail numavail)
    (set! info-numreal numreal)
    (set! info-numtotal numtotal)
    (write-info-file)
    retval)
  )

(define (handlesr filename fnet peer size slots resptime hash)
  (if (eq? (cdr (assoc 'search-mode session)) 'wait)
      (begin (set-cdr! (assoc 'search-mode session) 'normal)
	     (logf "reverting to normal mode")))
  (let ((cl (or (assoc size sr)
		(let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
	(newsr (list
		(cons 'filename filename)
		(cons 'peer (list fnet peer))
		(cons 'size size)
		(cons 'slots slots)
		(cons 'resptime resptime)
		(cons 'speed (getspeed peer))
		(cons 'hash hash)
		(cons 'recvtime (current-time))
		(cons 'dis #f)))
	(newlist '()))
    (for-each (lambda (o) (if (not (and (equal? (cdr (assoc 'filename o)) filename)
					(equal? (cdr (assoc 'peer o)) (list fnet peer))))
			      (set! newlist (cons o newlist))))
	      (cdr cl))
    (set-cdr! cl (sort (cons newsr newlist) sr-less?))
    )
  )

; XXX: Redefine to go through the server, once that is implemented
(define (getspeed username)
  (catch 'system-error
	 (lambda ()
	   (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))))
	     (do ((i 0 (+ i 1))) ((= i numents) (close-port port) (/ avg numents)) (set! avg (+ avg (string->number (read-line port)))))
	   ))
	 (lambda args
	   #f
	   )
	 )
  )

(define (validate-session session)
  (catch 'wrong-type-arg
	 (lambda ()
	   (and
	    (assoc 'sexpr session)
	    (assoc 'prio session)
	    (assoc 'maxtrans session)
	    #t
	    )
	   )
	 (lambda (key . args)
	   (display "Session data is not an a-list\n" (current-error-port))
	   #f)
	 )
  )

(define (autodl-main args)
  (let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
    (let ((getopt (make-getopt (cdr args) "whs:S:e:p:t:a:I:E:x:")) (arg #f))
      (do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
	(cond ((eq? (car arg) #\h)
	       (begin (display "usage: autodl [-s server] -S sessfile\n" (current-error-port))
		      (display "       autodl [-w] [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
		      (display "       autodl [-s server]\n" (current-error-port))
		      (display "       autodl -h\n" (current-error-port))
		      (exit 0)))
	      ((eq? (car arg) #\s)
	       (set! dc-server (cdr arg)))
	      ((eq? (car arg) #\S)
	       (let ((port (open-file (cdr arg)))) (set! session (read port)) (close-port port)))
	      ((eq? (car arg) #\p)
	       (let ((c (assoc 'prio session)))
		 (if c (set-cdr! c (cdr arg))
		     (set! session (cons (cons 'prio (cdr arg)) session)))))
	      ((eq? (car arg) #\t)
	       (let ((c (assoc 'tag session)))
		 (if c (set-cdr! c (cdr arg))
		     (set! session (cons (cons 'tag (cdr arg)) session)))))
	      ((eq? (car arg) #\a)
	       (let ((c (assoc 'uarg session)))
		 (if c (set-cdr! c (cdr arg))
		     (set! session (cons (cons 'uarg (cdr arg)) session)))))
	      ((eq? (car arg) #\I)
	       (let ((c (assoc 'info-file session)))
		 (if c (set-cdr! c (cdr arg))
		     (set! session (cons (cons 'info-file (cdr arg)) session)))))
	      ((eq? (car arg) #\E)
	       (let ((c (assoc 'estat-file session)))
		 (if c (set-cdr! c (cdr arg))
		     (set! session (cons (cons 'estat-file (cdr arg)) session)))))
	      ((eq? (car arg) #\e)
	       (set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session)))
	      ((eq? (car arg) #\w)
	       (set! session (cons '(search-mode . wait) session)))
	      ((eq? (car arg) #\x)
	       (let* ((c (assoc 'xargs session)) (p (string-index (cdr arg) #\=))
		      (recons (cons (substring (cdr arg) 0 p) (substring (cdr arg) (1+ p)))))
		 (if c (set-cdr! c (cons recons (cdr c)))
		     (set! session (cons (cons 'xargs (list recons)) session)))))
	      )
	)
      )
    (if (eq? session '()) (begin (if (isatty? (current-input-port)) (display "Enter session data (s-expr):\n" (current-error-port))) (set! session (read))))
    (if (not (assoc 'prio session))
	(set! session (cons '(prio . 10) session)))
    (if (not (assoc 'maxtrans session))
	(set! session (cons '(maxtrans . 1) session)))
    (if (not (assoc 'search-mode session))
	(set! session (cons '(search-mode . normal) session)))
    (if (not (validate-session session)) (begin (display "Invalid session!\n" (current-error-port)) (exit 1)))
    (if (not dc-server) (set! dc-server (getenv "DCSERVER")))
    (if (not dc-server) (set! dc-server "localhost"))
    (catch 'system-error
	   (lambda ()
	     (dc-c&l #t dc-server #t))
	   (lambda (key . args)
	     (logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
	     (exit 2)))
    (dc-ecmd-assert 200 "notify" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
    (for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
    (catch 'sig
	   (lambda ()
	     (while #t
		    (if (and (not (= lastsearch -1)) (wanttosearch))
			(begin
			  (if (not (= srchid -1))
			      (dc-ecmd "cansrch" srchid))
			  (let* ((resp (apply dc-ecmd-assert (append (list '(200 501 509) "search" "prio" (number->string (cdr (assoc 'prio session))) "all") (cdr (assoc 'sexpr session)))))
				 (ires (dc-intresp resp))
				 (eres (dc-extract resp)))
			    (case (cdr (assoc 'code eres))
			      ((200)
			       (begin (set! srchid (car ires))
				      (logf "search scheduled in ~a seconds (id ~a)"
					    (number->string (cadr ires))
					    (number->string srchid))
				      (set! info-searcheta (+ (current-time) (cadr ires)))
				      (set! lastsearch -1)
				      (write-info-file)))
			      ((501)
			       (begin (set! srchid -1)
				      (logf "no fnetnodes available to search on")
				      (set! lastsearch (current-time))))
			      ((509)
			       (begin (logf "illegal search expression")
				      (set! done #t)
				      (set! retval 3)
				      (throw 'sig 0)))))))
		    (checktrans)
		    (if (> (- (current-time) lastparse) 20)
			(begin (parseresults)
			       (set! lastparse (current-time))))
		    (dc-select 10000)
		    (while (let ((resp (dc-getresp)))
			     (if resp
				 (begin
				   (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
				     (cond
				       ((equal? cmd ".notify")
					(case code
					  ((611) ; Transfer state change
					   (let ((ires (dc-intresp resp)) (tr #f))
					     (if (and ires (assoc (car ires) trans))
						 (begin (set! tr (cdr (assoc (car ires) trans)))
							(set-cdr! (assoc 'state tr)
								  (cdr (assoc (cadr ires) '((0 . wait) (1 . hs) (2 . main) (3 . done)))))
							(set-cdr! (assoc 'lastprog tr) (current-time))))))
					  ((614) ; Transfer error
					   (let ((ires (dc-intresp resp)))
					     (if (and ires (assoc (car ires) trans))
						 (begin (logf "transfer ~a encountered error ~a" (car ires) (cadr ires))
							(dc-ecmd-assert 200 "cancel" (car ires))
							(let ((tr (cdr (assoc (car ires) trans))))
							  (disablepeer (cdr (assoc 'peer tr))))
							(set! trans (assq-remove! trans (car ires)))))))
					  ((615) ; Transfer progress
					   (let ((ires (dc-intresp resp)) (tr #f))
					     (if (and ires (assoc (car ires) trans))
						 (begin (set! tr (cdr (assoc (car ires) trans)))
							(set-cdr! (assoc 'curpos tr) (cadr ires))
							(set-cdr! (assoc 'lastprog tr) (current-time))))))
					  ((617) ; Transfer destroyed
					   (let* ((ires (dc-intresp resp)) (tr (and ires (assoc (car ires) trans))))
					     (if tr
						 (begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
							    (begin (logf "transfer ~a done (~a)" (car ires) (cadr ires))
								   (set! trans (assq-remove! trans (car ires)))
								   (set! done #t)
								   (set! filterexit (cadr ires))
								   (throw 'sig 0))
							    (begin (logf "transfer ~a disappeared" (car ires))
								   (set! trans (assq-remove! trans (car ires)))))))))
					  ((620) ; Search rescheduled
					   (let ((ires (dc-intresp resp)))
					     (if (and ires (= (car ires) srchid))
						 (begin (set! info-searcheta (+ (current-time) (cadr ires)))
							(logf "search rescheduled to T+~a" (cadr ires))
							(write-info-file)))))
					  ((621) ; Search committed
					   (let ((ires (dc-intresp resp)))
					     (if (and ires (= (car ires) srchid))
						 (begin (logf "search committed")
							(set! info-searcheta 0)
							(set! lastsearch (current-time))
							(write-info-file)))))
					  ((622) ; Search result
					   (let ((ires (list->vector (dc-intresp resp))))
					     (if (and ires (= (vector-ref ires 0) srchid)) (apply handlesr (map (lambda (n) (vector-ref ires n)) '(1 2 3 4 5 7 8))))))
					  
					  )
					)
				       
				       )
				     )
				   #t)
				 #f)
			     )
			   #t
			   )
		    )
	     )
	   (lambda (key sig)
	     (logf "interrupted by signal ~a" sig)
	     (if (not done)
		 (set! retval 1)))
	   )
    (logf "quitting...")
    (catch 'sig
	   (lambda ()
	     (if (dc-connected)
		 (begin (for-each (lambda (o)
				    (dc-qcmd (list "cancel" (car o))))
				  trans)
			(if (assoc 'info-file session)
			    (catch 'system-error
				   (lambda ()
				     (delete-file (cdr (assoc 'info-file session))))
				   (lambda (key . args) #t)))
			(if (and done (assoc 'tag session))
			    (dc-qcmd (list "filtercmd" "rmtag" (cdr (assoc 'tag session)))))
			(if (not (= srchid -1))
			    (dc-qcmd (list "cansrch" srchid)))
			(dc-qcmd '("quit"))
			(while (dc-connected) (dc-select))
			)))
	   (lambda (key sig)
	     (logf "forcing quit")))
    (if (assoc 'estat-file session)
	(let ((op (open-output-file (cdr (assoc 'estat-file session)))))
	  (display filterexit op)
	  (newline op)
	  (close-port op)))
    (exit retval)
    )
  )

(setlocale LC_ALL "")
(autodl-main (command-line))
Commit	Line	Data
d3372da9	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
c6cc011b	20	(define (logf fmt . msg)
c6cc011b	21	(apply format (cons* (current-output-port) (string-append fmt "\n") msg))
d3372da9	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)
d30cc4bc	65	(if (eq? (cdr (assoc 'search-mode session)) 'wait)
	66	7200
	67	(if (> (length trans) 0) 300 60)))
d3372da9	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)))))
3b0de0fd	119	(let ((hash (assoc 'hash sr)))
3b0de0fd	120	(if (and hash (not (equal? (cdr hash) ""))) (set! args (append args (list "hash" (cdr hash))))))
d3372da9	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))))))
e838f46b	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))))
d3372da9	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))
c6cc011b	144	(logf "downloading ~a from ~a, ~a bytes (id ~a, ~a slots), timing out in ~a seconds"
	145	(cdr (assoc 'filename sr))
	146	(cadr (cdr (assoc 'peer sr)))
	147	(number->string (cdr (assoc 'size sr)))
	148	(number->string id)
	149	(number->string (cdr (assoc 'slots sr)))
	150	(number->string (max 10 (* (cdr (assoc 'resptime sr)) 2))))))
d3372da9	151	(set! lastdl (current-time))
	152	)
	153
	154	(define (disablepeer peer)
	155	(let ((newglist '()) (numrem 0))
	156	(for-each (lambda (g)
	157	(let ((newlist '()))
	158	(for-each (lambda (o)
	159	(if (not (equal? (cdr (assoc 'peer o)) peer))
	160	(set! newlist (cons o newlist))
	161	(set! numrem (+ numrem 1))))
	162	(cdr g))
	163	(if (not (eq? newlist '()))
	164	(set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
	165	sr)
	166	(set! sr (sort newglist srg-less?))
c6cc011b	167	(logf "disabled ~a and removed ~a search results" (cadr peer) numrem))
d3372da9	168	(let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
	169	(if dp
	170	(set-cdr! (assoc 'time dp) (current-time))
	171	(set! dpeers (cons (cons peer (list (cons 'time (current-time))
	172	(cons 'peer peer)))
	173	dpeers))))
	174	)
	175
	176	(define (checktrans)
	177	(let ((time (current-time)))
	178	(for-each (lambda (o)
	179	(if (and (memq (cdr (assoc 'state (cdr o))) '(wait hs))
	180	(> (- time (cdr (assoc 'lastprog (cdr o)))) (max 10 (* (cdr (assoc 'resptime (cdr o))) 2))))
c6cc011b	181	(begin (logf "transfer ~a timing out" (car o))
d3372da9	182	(dc-ecmd-assert 200 "cancel" (car o))
d3372da9	183	(disablepeer (cdr (assoc 'peer (cdr o))))
ecd6e23d	184	(set! trans (assq-remove! trans (car o)))
ecd6e23d	185	(write-info-file)))
d3372da9	186	(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
d3372da9	187	(> (- time (cdr (assoc 'lastprog (cdr o)))) 60))
c6cc011b	188	(begin (logf "transfer ~a seems to have stalled" (car o))
d3372da9	189	(dc-ecmd-assert 200 "cancel" (car o))
ecd6e23d	190	(set! trans (assq-remove! trans (car o)))
ecd6e23d	191	(write-info-file)))
d3372da9	192	(if (and (eq? (cdr (assoc 'state (cdr o))) 'main)
	193	(> (- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o)))) 20))
	194	(begin (set-cdr! (assoc 'curspeed (cdr o))
	195	(/ (- (cdr (assoc 'curpos (cdr o))) (cdr (assoc 'lastpos (cdr o))))
	196	(- (cdr (assoc 'lastprog (cdr o))) (cdr (assoc 'lasttime (cdr o))))))
	197	(set-cdr! (assoc 'lastpos (cdr o)) (cdr (assoc 'curpos (cdr o))))
ecd6e23d	198	(set-cdr! (assoc 'lasttime (cdr o)) (cdr (assoc 'lastprog (cdr o))))
ecd6e23d	199	(write-info-file))))
d3372da9	200	trans))
	201	)
	202
	203	(define (write-info-file)
	204	(if (assoc 'info-file session)
	205	(let ((op (open-output-file (cdr (assoc 'info-file session)))))
d576878b	206	(pretty-print (list (cons 'numdl (length trans))
	207	(cons 'lastdl lastdl)
	208	(cons 'availsr info-numavail)
	209	(cons 'realsr info-numreal)
	210	(cons 'totalsr info-numtotal)
	211	(cons 'lastsrch lastsearch)
	212	(cons 'srcheta info-searcheta)
	213	(cons 'srchmode (cdr (assoc 'search-mode session))))
	214	op)
d3372da9	215	(close-port op))))
	216
	217	(define (parseresults)
c6cc011b	218	(logf "entering parseresults with ~a results in ~a sizes"
	219	(apply + (map (lambda (o) (length (cdr o))) sr))
	220	(number->string (length sr)))
d3372da9	221	(let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
	222	(catch 'ret
	223	(lambda ()
	224	(and (eq? sr '()) (throw 'ret #f))
	225	(let ((numrem 0) (countrem 0) (newglist '()))
	226	(for-each (lambda (g)
	227	(let ((newlist '()))
	228	(for-each (lambda (o)
	229	(if (< (- (current-time) (cdr (assoc 'recvtime o))) 300)
	230	(set! newlist (cons o newlist))
	231	(set! countrem (+ countrem 1))))
	232	(cdr g))
	233	(if (> (length newlist) 0)
	234	(set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
	235	(set! numrem (+ numrem 1)))))
	236	sr)
	237	(set! sr (sort newglist srg-less?))
	238	(if (> countrem 0)
c6cc011b	239	(logf "removed ~a time-outed results and ~a entire sizes" countrem numrem)))
d3372da9	240	(let ((numrem 0) (newlist '()))
	241	(for-each (lambda (o)
	242	(if (> (- (current-time) (cdr (assoc 'time o))) 1800)
	243	(set! numrem (+ numrem 1))
	244	(set! newlist (cons o newlist))))
	245	dpeers)
	246	(set! dpeers newlist)
c6cc011b	247	(logf "re-enabled ~a disabled users" numrem))
d3372da9	248	(let ((numrem 0) (countrem 0) (newglist '()))
	249	(for-each (lambda (g)
	250	(let ((newlist '()))
	251	(for-each (lambda (o)
	252	(if (not (assoc (cdr (assoc 'peer o)) dpeers))
	253	(set! newlist (cons o newlist))
	254	(set! countrem (+ countrem 1))))
	255	(cdr g))
	256	(if (> (length newlist) 0)
	257	(set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist))
	258	(set! numrem (+ numrem 1)))))
	259	sr)
	260	(set! sr (sort newglist srg-less?))
	261	(if (> countrem 0)
c6cc011b	262	(logf "removed ~a results with disabled peers and ~a entire sizes" countrem numrem)))
d3372da9	263	(and (eq? sr '()) (throw 'ret #f))
	264	(set! numtotal (apply + (map (lambda (o) (length (cdr o))) sr)))
	265	(let* ((maxsize (apply max (map (lambda (o) (length (cdr o))) sr)))
	266	(minsize (/ maxsize 3)))
	267	(let ((numrem 0) (countrem 0))
	268	(for-each (lambda (o) (if (< (length (cdr o)) minsize)
	269	(begin (set! countrem (+ countrem (length (cdr o))))
	270	(set! numrem (+ numrem 1)))))
	271	sr)
	272	(if (> countrem 0)
c6cc011b	273	(logf "will disregard ~a results from ~a sizes due to popularity lack" countrem numrem))
d3372da9	274	(set! numreal (- numtotal countrem)))
	275	(let ((numrem 0) (numrrem 0))
	276	(for-each (lambda (g)
	277	(for-each (lambda (o)
	278	(if (< (cdr (assoc 'slots o)) 1)
	279	(begin (set! numrem (+ numrem 1))
	280	(if (>= (length (cdr g)) minsize)
	281	(set! numrrem (+ numrrem 1))))))
	282	(cdr g)))
	283	sr)
	284	(if (> numrem 0)
c6cc011b	285	(logf "~a results had no slots" numrem))
d3372da9	286	(set! numavail (- numreal numrrem)))
	287	(for-each (lambda (g)
	288	(if (>= (length (cdr g)) minsize)
	289	(catch 'found
	290	(lambda ()
	291	(for-each (lambda (o)
	292	(and (> (cdr (assoc 'slots o)) 0)
	293	(throw 'found o)))
	294	(cdr g)))
	295	(lambda (sig sr)
	296	(let ((tr (gettrbysize (cdr (assoc 'size sr)))))
	297	(if (not tr)
	298	(if (< (length trans) (cdr (assoc 'maxtrans session)))
	299	(download sr))
	300	(if (and (cdr (assoc 'curspeed tr))
	301	(not (equal? (cdr (assoc 'peer sr)) (cdr (assoc 'peer tr))))
	302	(> (- (or (cdr (assoc 'speed sr)) (defspeed sr)) (cdr (assoc 'curspeed tr))) 10000))
c6cc011b	303	(begin (logf "abandoning transfer ~a for possible faster sender"
c6cc011b	304	(cdr (assoc 'id tr)))
d3372da9	305	(dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
	306	(set! trans (assq-remove! trans (cdr (assoc 'id tr))))
	307	(download sr)))))))))
	308	sr)
	309	)
	310	)
	311	(lambda (sig ret)
	312	(set! retval ret)
	313	))
	314	(set! info-numavail numavail)
	315	(set! info-numreal numreal)
	316	(set! info-numtotal numtotal)
ecd6e23d	317	(write-info-file)
d3372da9	318	retval)
	319	)
	320
3b0de0fd	321	(define (handlesr filename fnet peer size slots resptime hash)
2bb57f49	322	(if (eq? (cdr (assoc 'search-mode session)) 'wait)
	323	(begin (set-cdr! (assoc 'search-mode session) 'normal)
	324	(logf "reverting to normal mode")))
d3372da9	325	(let ((cl (or (assoc size sr)
	326	(let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
	327	(newsr (list
	328	(cons 'filename filename)
	329	(cons 'peer (list fnet peer))
	330	(cons 'size size)
	331	(cons 'slots slots)
	332	(cons 'resptime resptime)
	333	(cons 'speed (getspeed peer))
3b0de0fd	334	(cons 'hash hash)
d3372da9	335	(cons 'recvtime (current-time))
	336	(cons 'dis #f)))
	337	(newlist '()))
	338	(for-each (lambda (o) (if (not (and (equal? (cdr (assoc 'filename o)) filename)
	339	(equal? (cdr (assoc 'peer o)) (list fnet peer))))
	340	(set! newlist (cons o newlist))))
	341	(cdr cl))
	342	(set-cdr! cl (sort (cons newsr newlist) sr-less?))
	343	)
	344	)
	345
	346	; XXX: Redefine to go through the server, once that is implemented
	347	(define (getspeed username)
	348	(catch 'system-error
	349	(lambda ()
	350	(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))))
	351	(do ((i 0 (+ i 1))) ((= i numents) (close-port port) (/ avg numents)) (set! avg (+ avg (string->number (read-line port)))))
	352	))
	353	(lambda args
	354	#f
	355	)
	356	)
	357	)
	358
	359	(define (validate-session session)
	360	(catch 'wrong-type-arg
	361	(lambda ()
	362	(and
	363	(assoc 'sexpr session)
	364	(assoc 'prio session)
	365	(assoc 'maxtrans session)
	366	#t
	367	)
	368	)
	369	(lambda (key . args)
	370	(display "Session data is not an a-list\n" (current-error-port))
	371	#f)
	372	)
	373	)
	374
	375	(define (autodl-main args)
aa82fda0	376	(let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
e838f46b	377	(let ((getopt (make-getopt (cdr args) "whs:S:e:p:t:a:I:E:x:")) (arg #f))
d3372da9	378	(do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
	379	(cond ((eq? (car arg) #\h)
	380	(begin (display "usage: autodl [-s server] -S sessfile\n" (current-error-port))
d30cc4bc	381	(display " autodl [-w] [-s server] -e search-expression [-p prio] [-t tag] [-a userarg]\n" (current-error-port))
d3372da9	382	(display " autodl [-s server]\n" (current-error-port))
	383	(display " autodl -h\n" (current-error-port))
	384	(exit 0)))
	385	((eq? (car arg) #\s)
	386	(set! dc-server (cdr arg)))
	387	((eq? (car arg) #\S)
	388	(let ((port (open-file (cdr arg)))) (set! session (read port)) (close-port port)))
	389	((eq? (car arg) #\p)
	390	(let ((c (assoc 'prio session)))
	391	(if c (set-cdr! c (cdr arg))
	392	(set! session (cons (cons 'prio (cdr arg)) session)))))
	393	((eq? (car arg) #\t)
	394	(let ((c (assoc 'tag session)))
	395	(if c (set-cdr! c (cdr arg))
	396	(set! session (cons (cons 'tag (cdr arg)) session)))))
	397	((eq? (car arg) #\a)
	398	(let ((c (assoc 'uarg session)))
	399	(if c (set-cdr! c (cdr arg))
	400	(set! session (cons (cons 'uarg (cdr arg)) session)))))
	401	((eq? (car arg) #\I)
	402	(let ((c (assoc 'info-file session)))
	403	(if c (set-cdr! c (cdr arg))
	404	(set! session (cons (cons 'info-file (cdr arg)) session)))))
aa82fda0	405	((eq? (car arg) #\E)
	406	(let ((c (assoc 'estat-file session)))
	407	(if c (set-cdr! c (cdr arg))
	408	(set! session (cons (cons 'estat-file (cdr arg)) session)))))
d3372da9	409	((eq? (car arg) #\e)
d3372da9	410	(set! session (cons (cons 'sexpr (dc-lexsexpr (cdr arg))) session)))
d30cc4bc	411	((eq? (car arg) #\w)
d30cc4bc	412	(set! session (cons '(search-mode . wait) session)))
e838f46b	413	((eq? (car arg) #\x)
	414	(let* ((c (assoc 'xargs session)) (p (string-index (cdr arg) #\=))
	415	(recons (cons (substring (cdr arg) 0 p) (substring (cdr arg) (1+ p)))))
	416	(if c (set-cdr! c (cons recons (cdr c)))
	417	(set! session (cons (cons 'xargs (list recons)) session)))))
d3372da9	418	)
	419	)
	420	)
	421	(if (eq? session '()) (begin (if (isatty? (current-input-port)) (display "Enter session data (s-expr):\n" (current-error-port))) (set! session (read))))
	422	(if (not (assoc 'prio session))
	423	(set! session (cons '(prio . 10) session)))
	424	(if (not (assoc 'maxtrans session))
	425	(set! session (cons '(maxtrans . 1) session)))
d30cc4bc	426	(if (not (assoc 'search-mode session))
53acfa81	427	(set! session (cons '(search-mode . normal) session)))
d3372da9	428	(if (not (validate-session session)) (begin (display "Invalid session!\n" (current-error-port)) (exit 1)))
	429	(if (not dc-server) (set! dc-server (getenv "DCSERVER")))
	430	(if (not dc-server) (set! dc-server "localhost"))
	431	(catch 'system-error
	432	(lambda ()
	433	(dc-c&l #t dc-server #t))
	434	(lambda (key . args)
c6cc011b	435	(logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
d3372da9	436	(exit 2)))
c6a77cc5	437	(dc-ecmd-assert 200 "notify" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
d3372da9	438	(for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
	439	(catch 'sig
	440	(lambda ()
	441	(while #t
	442	(if (and (not (= lastsearch -1)) (wanttosearch))
	443	(begin
	444	(if (not (= srchid -1))
	445	(dc-ecmd "cansrch" srchid))
	446	(let* ((resp (apply dc-ecmd-assert (append (list '(200 501 509) "search" "prio" (number->string (cdr (assoc 'prio session))) "all") (cdr (assoc 'sexpr session)))))
	447	(ires (dc-intresp resp))
	448	(eres (dc-extract resp)))
	449	(case (cdr (assoc 'code eres))
	450	((200)
	451	(begin (set! srchid (car ires))
c6cc011b	452	(logf "search scheduled in ~a seconds (id ~a)"
	453	(number->string (cadr ires))
	454	(number->string srchid))
d3372da9	455	(set! info-searcheta (+ (current-time) (cadr ires)))
ecd6e23d	456	(set! lastsearch -1)
ecd6e23d	457	(write-info-file)))
d3372da9	458	((501)
d3372da9	459	(begin (set! srchid -1)
c6cc011b	460	(logf "no fnetnodes available to search on")
d3372da9	461	(set! lastsearch (current-time))))
	462	((509)
	463	(begin (logf "illegal search expression")
	464	(set! done #t)
	465	(set! retval 3)
	466	(throw 'sig 0)))))))
	467	(checktrans)
	468	(if (> (- (current-time) lastparse) 20)
	469	(begin (parseresults)
	470	(set! lastparse (current-time))))
d3372da9	471	(dc-select 10000)
	472	(while (let ((resp (dc-getresp)))
	473	(if resp
	474	(begin
	475	(let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
	476	(cond
	477	((equal? cmd ".notify")
	478	(case code
	479	((611) ; Transfer state change
	480	(let ((ires (dc-intresp resp)) (tr #f))
	481	(if (and ires (assoc (car ires) trans))
	482	(begin (set! tr (cdr (assoc (car ires) trans)))
	483	(set-cdr! (assoc 'state tr)
	484	(cdr (assoc (cadr ires) '((0 . wait) (1 . hs) (2 . main) (3 . done)))))
	485	(set-cdr! (assoc 'lastprog tr) (current-time))))))
	486	((614) ; Transfer error
	487	(let ((ires (dc-intresp resp)))
	488	(if (and ires (assoc (car ires) trans))
c6cc011b	489	(begin (logf "transfer ~a encountered error ~a" (car ires) (cadr ires))
d3372da9	490	(dc-ecmd-assert 200 "cancel" (car ires))
	491	(let ((tr (cdr (assoc (car ires) trans))))
	492	(disablepeer (cdr (assoc 'peer tr))))
	493	(set! trans (assq-remove! trans (car ires)))))))
	494	((615) ; Transfer progress
	495	(let ((ires (dc-intresp resp)) (tr #f))
	496	(if (and ires (assoc (car ires) trans))
	497	(begin (set! tr (cdr (assoc (car ires) trans)))
	498	(set-cdr! (assoc 'curpos tr) (cadr ires))
	499	(set-cdr! (assoc 'lastprog tr) (current-time))))))
	500	((617) ; Transfer destroyed
	501	(let* ((ires (dc-intresp resp)) (tr (and ires (assoc (car ires) trans))))
	502	(if tr
	503	(begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
c6cc011b	504	(begin (logf "transfer ~a done (~a)" (car ires) (cadr ires))
d3372da9	505	(set! trans (assq-remove! trans (car ires)))
d3372da9	506	(set! done #t)
2fc2772d	507	(set! filterexit (cadr ires))
d3372da9	508	(throw 'sig 0))
c6cc011b	509	(begin (logf "transfer ~a disappeared" (car ires))
d3372da9	510	(set! trans (assq-remove! trans (car ires)))))))))
	511	((620) ; Search rescheduled
	512	(let ((ires (dc-intresp resp)))
	513	(if (and ires (= (car ires) srchid))
	514	(begin (set! info-searcheta (+ (current-time) (cadr ires)))
c6cc011b	515	(logf "search rescheduled to T+~a" (cadr ires))
d30cc4bc	516	(write-info-file)))))
d3372da9	517	((621) ; Search committed
	518	(let ((ires (dc-intresp resp)))
	519	(if (and ires (= (car ires) srchid))
	520	(begin (logf "search committed")
	521	(set! info-searcheta 0)
d30cc4bc	522	(set! lastsearch (current-time))
d30cc4bc	523	(write-info-file)))))
d3372da9	524	((622) ; Search result
d3372da9	525	(let ((ires (list->vector (dc-intresp resp))))
3b0de0fd	526	(if (and ires (= (vector-ref ires 0) srchid)) (apply handlesr (map (lambda (n) (vector-ref ires n)) '(1 2 3 4 5 7 8))))))
d3372da9	527
	528	)
	529	)
	530
	531	)
	532	)
	533	#t)
	534	#f)
	535	)
	536	#t
	537	)
	538	)
	539	)
	540	(lambda (key sig)
c6cc011b	541	(logf "interrupted by signal ~a" sig)
d3372da9	542	(if (not done)
	543	(set! retval 1)))
	544	)
	545	(logf "quitting...")
	546	(catch 'sig
	547	(lambda ()
	548	(if (dc-connected)
	549	(begin (for-each (lambda (o)
	550	(dc-qcmd (list "cancel" (car o))))
	551	trans)
	552	(if (assoc 'info-file session)
	553	(catch 'system-error
	554	(lambda ()
	555	(delete-file (cdr (assoc 'info-file session))))
	556	(lambda (key . args) #t)))
	557	(if (and done (assoc 'tag session))
	558	(dc-qcmd (list "filtercmd" "rmtag" (cdr (assoc 'tag session)))))
	559	(if (not (= srchid -1))
	560	(dc-qcmd (list "cansrch" srchid)))
	561	(dc-qcmd '("quit"))
	562	(while (dc-connected) (dc-select))
	563	)))
	564	(lambda (key sig)
	565	(logf "forcing quit")))
aa82fda0	566	(if (assoc 'estat-file session)
aa82fda0	567	(let ((op (open-output-file (cdr (assoc 'estat-file session)))))
fc068ee7	568	(display filterexit op)
aa82fda0	569	(newline op)
aa82fda0	570	(close-port op)))
d3372da9	571	(exit retval)
	572	)
	573	)
	574
	575	(setlocale LC_ALL "")
	576	(autodl-main (command-line))