X-Git-Url: http://git.dolda2000.com/gitweb/?a=blobdiff_plain;f=lib%2Fguile%2Fautodl;h=ff21b84cfb30c0afa8a97c2991eaa856ee75156c;hb=3af4536f80baf4ff661a577f8206b611ad07bab1;hp=632e7efc818cb54f6a9bfd8f6a6366ef67447986;hpb=53acfa815f80dfb087324da165546e60a4d27f8c;p=doldaconnect.git

diff --git a/lib/guile/autodl b/lib/guile/autodl
index 632e7ef..ff21b84 100755
--- a/lib/guile/autodl
+++ b/lib/guile/autodl
@@ -1,6 +1,23 @@
 #!/usr/bin/guile -s
 !#
 
+;  Dolda Connect - Modular multiuser Direct Connect-style client
+;  Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
+;  
+;  This program is free software; you can redistribute it and/or modify
+;  it under the terms of the GNU General Public License as published by
+;  the Free Software Foundation; either version 2 of the License, or
+;  (at your option) any later version.
+;  
+;  This program is distributed in the hope that it will be useful,
+;  but WITHOUT ANY WARRANTY; without even the implied warranty of
+;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;  GNU General Public License for more details.
+;  
+;  You should have received a copy of the GNU General Public License
+;  along with this program; if not, write to the Free Software
+;  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
 (use-modules (dolcon ui))
 (use-modules (ice-9 pretty-print))
 
@@ -16,12 +33,25 @@
 (define trans '())
 (define dpeers '())
 (define lastdl 0)
+(define logport (current-output-port))
+(define infoport #f)
+
+(define (logf fmt . msg)
+  (if logport
+      (begin
+	(apply format (cons* logport (string-append fmt "\n") msg))
+	(catch 'system-error (lambda ()
+			       (fsync logport))
+	       (lambda (key . err) #f))))
+  )
 
-(define (logf msg)
-  (write-line msg (current-output-port))
-  (catch 'system-error (lambda ()
-			 (fsync (current-output-port)))
-	 (lambda (key . err) #f))
+(define (infomsg fmt . msg)
+  (if infoport
+      (begin
+	(apply format (cons* infoport (string-append fmt "\n") msg))
+	(catch 'system-error (lambda ()
+			       (fsync infoport))
+	       (lambda (key . err) #f))))
   )
 
 (define (make-getopt opts optdesc)
@@ -122,6 +152,10 @@
 	(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
@@ -137,19 +171,14 @@
 				 (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"))))
+      (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)))
+	    (cdr (assoc 'size sr))
+	    id
+	    (cdr (assoc 'slots sr))
+	    (max 10 (* (cdr (assoc 'resptime sr)) 2)))
+      (infomsg "dl ~a ~a" (cdr (assoc 'size sr)) id)))
   (set! lastdl (current-time))
   )
 
@@ -166,7 +195,7 @@
 		      (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")))
+    (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))
@@ -180,14 +209,16 @@
     (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"))
+		    (begin (logf "transfer ~a timing out" (car o))
+			   (infomsg "dlstop ~a timeout" (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 (string-append "transfer " (number->string (car o)) " seems to have stalled"))
+		    (begin (logf "transfer ~a seems to have stalled" (car o))
+			   (infomsg "dlstop ~a stall" (car o))
 			   (dc-ecmd-assert 200 "cancel" (car o))
 			   (set! trans (assq-remove! trans (car o)))
 			   (write-info-file)))
@@ -205,25 +236,21 @@
 (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)
-		     (cons 'srchmode (cdr (assoc 'search-mode session))))
-	       op)
-	(newline op)
+	(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 (string-append "entering parseresults with "
-		       (number->string
-			(apply + (map (lambda (o) (length (cdr o))) sr)))
-		       " results in "
-		       (number->string (length sr))
-		       " sizes"))
+  (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 ()
@@ -242,7 +269,7 @@
 			 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"))))
+		   (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)
@@ -250,7 +277,7 @@
 			       (set! newlist (cons o newlist))))
 			 dpeers)
 	       (set! dpeers newlist)
-	       (logf (string-append "re-enabled " (number->string numrem) " disabled users")))
+	       (logf "re-enabled ~a disabled users" numrem))
 	     (let ((numrem 0) (countrem 0) (newglist '()))
 	       (for-each (lambda (g)
 			   (let ((newlist '()))
@@ -265,7 +292,7 @@
 			 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"))))
+		   (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)))
@@ -276,7 +303,7 @@
 						  (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")))
+		     (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)
@@ -288,7 +315,7 @@
 				       (cdr g)))
 			   sr)
 		 (if (> numrem 0)
-		     (logf (string-append (number->string numrem) " results had no slots")))
+		     (logf "~a results had no slots" numrem))
 		 (set! numavail (- numreal numrrem)))
 	       (for-each (lambda (g)
 			   (if (>= (length (cdr g)) minsize)
@@ -306,9 +333,9 @@
 					      (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"))
+						  (begin (logf "abandoning transfer ~a for possible faster sender"
+									      (cdr (assoc 'id tr)))
+							 (infomsg "dlstop ~a tryother" (cdr (assoc 'id tr)))
 							 (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
 							 (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
 							 (download sr)))))))))
@@ -321,6 +348,7 @@
     (set! info-numavail numavail)
     (set! info-numreal numreal)
     (set! info-numtotal numtotal)
+    (infomsg "srs ~a ~a ~a" numtotal numreal numavail)
     (write-info-file)
     retval)
   )
@@ -328,7 +356,8 @@
 (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")))
+	     (logf "reverting to normal mode")
+	     (infomsg "searchmode normal")))
   (let ((cl (or (assoc size sr)
 		(let ((newp (cons size '()))) (set! sr (append sr (list newp))) newp)))
 	(newsr (list
@@ -380,8 +409,8 @@
   )
 
 (define (autodl-main args)
-  (let ((dc-server #f) (done #f) (retval 0))
-    (let ((getopt (make-getopt (cdr args) "whs:S:e:p:t:a:I:")) (arg #f))
+  (let ((dc-server #f) (done #f) (retval 0) (filterexit ""))
+    (let ((getopt (make-getopt (cdr args) "whis: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))
@@ -409,10 +438,22 @@
 	       (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) #\i)
+	       (set! infoport logport)
+	       (set! logport #f))
+	      ((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)))))
 	      )
 	)
       )
@@ -424,15 +465,13 @@
     (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))
+	     (dc-c&l #f dc-server #t))
 	   (lambda (key . args)
-	     (logf (string-append "could not connect to server: " (apply format #f (cadr args) (caddr args))))
+	     (logf "could not connect to server: ~a" (apply format #f (cadr args) (caddr args)))
 	     (exit 2)))
-    (dc-ecmd-assert 200 "notify" "all" "on")
+    (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 ()
@@ -447,13 +486,17 @@
 			    (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) ")"))
+				      (logf "search scheduled in ~a seconds (id ~a)"
+					    (cadr ires)
+					    srchid)
+				      (infomsg "search pending ~a" (cadr ires))
 				      (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"))
+				      (logf "no fnetnodes available to search on")
+				      (infomsg "nofns")
 				      (set! lastsearch (current-time))))
 			      ((509)
 			       (begin (logf "illegal search expression")
@@ -482,7 +525,8 @@
 					  ((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))))
+						 (begin (logf "transfer ~a encountered error ~a" (car ires) (cadr ires))
+							(infomsg "dlstop ~a 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))))
@@ -497,22 +541,28 @@
 					   (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"))
+							    (begin (logf "transfer ~a done (~a)" (car ires) (cadr ires))
+								   (infomsg "dldone ~a" (car ires))
+								   (infomsg "estat ~a" (cadr ires))
 								   (set! trans (assq-remove! trans (car ires)))
 								   (set! done #t)
+								   (set! filterexit (cadr ires))
 								   (throw 'sig 0))
-							    (begin (logf (string-append "transfer " (number->string (car ires)) " disappeared"))
+							    (begin (logf "transfer ~a disappeared" (car ires))
+								   (infomsg "dlstop ~a gone" (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 (string-append "search rescheduled to T+" (number->string (cadr ires))))
+							(logf "search rescheduled to T+~a" (cadr ires))
+							(infomsg "search pending ~a" (cadr ires))
 							(write-info-file)))))
 					  ((621) ; Search committed
 					   (let ((ires (dc-intresp resp)))
 					     (if (and ires (= (car ires) srchid))
 						 (begin (logf "search committed")
+							(infomsg "search commit")
 							(set! info-searcheta 0)
 							(set! lastsearch (current-time))
 							(write-info-file)))))
@@ -533,7 +583,7 @@
 		    )
 	     )
 	   (lambda (key sig)
-	     (logf (string-append "interrupted by signal " (number->string sig)))
+	     (logf "interrupted by signal ~a" sig)
 	     (if (not done)
 		 (set! retval 1)))
 	   )
@@ -558,6 +608,11 @@
 			)))
 	   (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)
     )
   )