[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 msg)
  (write-line msg (current-output-port))
  (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))))))
      (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 (string-append "downloading "
			   (cdr (assoc 'filename sr))
			   " from "
			   (cadr (cdr (assoc 'peer sr)))
			   ", "
			   (number->string (cdr (assoc 'size sr)))
			   " bytes (id "
			   (number->string id)
			   ", "
			   (number->string (cdr (assoc 'slots sr)))
			   " slots), timing out in "
			   (number->string (max 10 (* (cdr (assoc 'resptime sr)) 2)))
			   " seconds"))))
  (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 (string-append "disabled " (cadr peer) " and removed " (number->string numrem) " search results")))
  (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 (string-append "transfer " (number->string (car o)) " timing out"))
			   (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 (string-append "transfer " (number->string (car o)) " seems to have stalled"))
			   (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)))))
	(write (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))
	       op)
	(newline op)
	(close-port op))))

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