#!/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))
(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)
(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 '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))
)
(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))
(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)))
(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 ()
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)
(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 '()))
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)))
(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)
(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)
(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)))))))))
(set! info-numavail numavail)
(set! info-numreal numreal)
(set! info-numtotal numtotal)
+ (infomsg "srs ~a ~a ~a" numtotal numreal numavail)
(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")))
+ (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
(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:")) (arg #f))
+ (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))
(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 '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 (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" "trans:act" "on" "trans:prog" "on" "srch:act" "on")
(for-each (lambda (sig) (sigaction sig (lambda (sig) (throw 'sig sig)))) (list SIGINT SIGTERM SIGHUP))
(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")
((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))))
(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 (" (cadr ires) ")"))
+ (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)))))
)
)
(lambda (key sig)
- (logf (string-append "interrupted by signal " (number->string sig)))
+ (logf "interrupted by signal ~a" sig)
(if (not done)
(set! retval 1)))
)
Dolda2000 GitWeb / doldaconnect.git / blobdiff