Upgrade logf to use format.

[doldaconnect.git] / lib / guile / autodl

diff --git a/lib/guile/autodl b/lib/guile/autodl
index 281c236..d752f15 100755 (executable)
--- a/lib/guile/autodl
+++ b/lib/guile/autodl
@@ -17,8 +17,8 @@
 (define dpeers '())
 (define lastdl 0)
 
 (define dpeers '())
 (define lastdl 0)
 

-(define (logf msg)
-  (write-line msg (current-output-port))
+(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))
   (catch 'system-error (lambda ()
                         (fsync (current-output-port)))
         (lambda (key . err) #f))


@@ -122,6 +122,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))))))
        (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
       (set! resp (apply dc-ecmd-assert 200 args)))
     (let ((id (car (dc-intresp resp))))
       (set! trans


@@ -137,19 +141,13 @@
                                 (cons 'lasttime (current-time))
                                 (cons 'lastprog (current-time))))
                  trans))
                                 (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)))
+           (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))
   )
 
   (set! lastdl (current-time))
   )
 


@@ -166,7 +164,7 @@
                      (set! newglist (cons (cons (car g) (sort newlist sr-less?)) newglist)))))
              sr)
     (set! sr (sort newglist srg-less?))
                      (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))
   (let* ((dpa (assoc peer dpeers)) (dp (and (pair? dpa) (cdr dpa))))
     (if dp
        (set-cdr! (assoc 'time dp) (current-time))


@@ -180,14 +178,14 @@
     (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))))
     (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))

                           (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))
                           (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))

                           (dc-ecmd-assert 200 "cancel" (car o))
                           (set! trans (assq-remove! trans (car o)))
                           (write-info-file)))
                           (dc-ecmd-assert 200 "cancel" (car o))
                           (set! trans (assq-remove! trans (car o)))
                           (write-info-file)))


@@ -205,25 +203,21 @@
 (define (write-info-file)
   (if (assoc 'info-file session)
       (let ((op (open-output-file (cdr (assoc 'info-file session)))))
 (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)
        (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 ()
   (let ((retval #t) (numreal 0) (numtotal 0) (numavail 0))
     (catch 'ret
           (lambda ()


@@ -242,7 +236,7 @@
                         sr)
               (set! sr (sort newglist srg-less?))
               (if (> countrem 0)
                         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)
             (let ((numrem 0) (newlist '()))
               (for-each (lambda (o)
                           (if (> (- (current-time) (cdr (assoc 'time o))) 1800)


@@ -250,7 +244,7 @@
                               (set! newlist (cons o newlist))))
                         dpeers)
               (set! dpeers newlist)
                               (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 '()))
             (let ((numrem 0) (countrem 0) (newglist '()))
               (for-each (lambda (g)
                           (let ((newlist '()))


@@ -265,7 +259,7 @@
                         sr)
               (set! sr (sort newglist srg-less?))
               (if (> countrem 0)
                         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)))
             (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 +270,7 @@
                                                  (set! numrem (+ numrem 1)))))
                           sr)
                 (if (> countrem 0)
                                                  (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)
                 (set! numreal (- numtotal countrem)))
               (let ((numrem 0) (numrrem 0))
                 (for-each (lambda (g)


@@ -288,7 +282,7 @@
                                       (cdr g)))
                           sr)
                 (if (> numrem 0)
                                       (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)
                 (set! numavail (- numreal numrrem)))
               (for-each (lambda (g)
                           (if (>= (length (cdr g)) minsize)


@@ -306,9 +300,8 @@
                                              (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))
                                              (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)))

                                                         (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
                                                         (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
                                                         (download sr)))))))))
                                                         (dc-ecmd-assert 200 "cancel" (cdr (assoc 'id tr)))
                                                         (set! trans (assq-remove! trans (cdr (assoc 'id tr))))
                                                         (download sr)))))))))


@@ -380,8 +373,8 @@
   )
 
 (define (autodl-main args)
   )
 
 (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) "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))
       (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 +402,19 @@
               (let ((c (assoc 'info-file session)))
                 (if c (set-cdr! c (cdr arg))
                     (set! session (cons (cons 'info-file (cdr arg)) session)))))
               (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) #\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)))))

              )
        )
       )
              )
        )
       )


@@ -430,7 +432,7 @@
           (lambda ()
             (dc-c&l #t dc-server #t))
           (lambda (key . args)
           (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))))
+            (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))
             (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))


@@ -447,13 +449,15 @@
                            (case (cdr (assoc 'code eres))
                              ((200)
                               (begin (set! srchid (car ires))
                            (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)"
+                                           (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)
                                      (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")

                                      (set! lastsearch (current-time))))
                              ((509)
                               (begin (logf "illegal search expression")
                                      (set! lastsearch (current-time))))
                              ((509)
                               (begin (logf "illegal search expression")


@@ -482,7 +486,7 @@
                                          ((614) ; Transfer error
                                           (let ((ires (dc-intresp resp)))
                                             (if (and ires (assoc (car ires) trans))
                                          ((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))

                                                        (dc-ecmd-assert 200 "cancel" (car ires))
                                                        (let ((tr (cdr (assoc (car ires) trans))))
                                                          (disablepeer (cdr (assoc 'peer tr))))
                                                        (dc-ecmd-assert 200 "cancel" (car ires))
                                                        (let ((tr (cdr (assoc (car ires) trans))))
                                                          (disablepeer (cdr (assoc 'peer tr))))


@@ -497,17 +501,18 @@
                                           (let* ((ires (dc-intresp resp)) (tr (and ires (assoc (car ires) trans))))
                                             (if tr
                                                 (begin (if (eq? (cdr (assoc 'state (cdr tr))) 'done)
                                           (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))

                                                                   (set! trans (assq-remove! trans (car ires)))
                                                                   (set! done #t)
                                                                   (set! trans (assq-remove! trans (car ires)))
                                                                   (set! done #t)

+                                                                  (set! filterexit (cadr ires))

                                                                   (throw 'sig 0))
                                                                   (throw 'sig 0))

-                                                           (begin (logf (string-append "transfer " (number->string (car ires)) " disappeared"))
+                                                           (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)))
                                                                   (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))

                                                        (write-info-file)))))
                                          ((621) ; Search committed
                                           (let ((ires (dc-intresp resp)))
                                                        (write-info-file)))))
                                          ((621) ; Search committed
                                           (let ((ires (dc-intresp resp)))


@@ -533,7 +538,7 @@
                    )
             )
           (lambda (key sig)
                    )
             )
           (lambda (key sig)

-            (logf (string-append "interrupted by signal " (number->string sig)))
+            (logf "interrupted by signal ~a" sig)

             (if (not done)
                 (set! retval 1)))
           )
             (if (not done)
                 (set! retval 1)))
           )


@@ -558,6 +563,11 @@
                        )))
           (lambda (key sig)
             (logf "forcing quit")))
                        )))
           (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)
     )
   )
     (exit retval)
     )
   )