4 (use-modules (dolcon ui))
5 (use-modules (ice-9 pretty-print))
9 (define (make-getopt opts optdesc)
10 (let ((arg opts) (curpos 0) (rest '()))
12 (if (eq? arg '()) rest
16 (if (eq? (string-ref (car arg) 0) #\-)
19 (set! rest (append rest (list (car arg))))
24 (if (< curpos (string-length (car arg)))
25 (begin (set! ret (string-ref (car arg) curpos)) (set! curpos (+ curpos 1)))
26 (begin (set! curpos 0) (set! arg (cdr arg)) (if (eq? arg '()) (set! ret #t))))))
28 (let ((opt (string-index optdesc ret)))
29 (if (eq? opt #f) (throw 'illegal-option ret)
30 (if (and (< opt (- (string-length optdesc) 1)) (eq? (string-ref optdesc (+ opt 1)) #\:))
32 (cons ret (let ((optarg
33 (if (< curpos (string-length (car arg)))
34 (substring (car arg) curpos)
35 (begin (set! arg (cdr arg)) (if (eq? arg '()) (throw 'requires-argument ret)) (car arg)))))
36 (set! arg (cdr arg)) optarg))))
42 (let ((resp (dc-ecmd "lsnodes")) (er #f))
43 (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200))
45 (while (begin (set! ires (dc-intresp resp)) ires)
46 (if (assoc (car ires) fnetnodes)
47 (set-cdr! (assoc (car ires) fnetnodes) (list-ref ires 5))
48 (set! fnetnodes (cons (cons (car ires) (list-ref ires 5)) fnetnodes))))))))
50 (define (fn-getname id)
51 (if (not (assoc id fnetnodes))
53 (if (assoc id fnetnodes)
54 (cdr (assoc id fnetnodes))
57 ;(define (fn-getname id)
58 ; (let ((resp (dc-ecmd "lsnodes")) (er #f))
59 ; (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200))
64 ; (while (begin (set! ires (dc-intresp resp)) ires)
65 ; (if (= (car ires) id)
66 ; (throw 'found (caddr ires)))
72 ; (number->string id)))
75 (define (chatlog-main args)
76 (let ((dc-server #f) (log-dir #f) (last-fn #f))
77 (let ((getopt (make-getopt (cdr args) "hs:S:e:")) (arg #f))
78 (do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
79 (cond ((eq? (car arg) #\h)
80 (begin (display "usage: chatlog [-s server] [-d log-dir]\n" (current-error-port))
81 (display " chatlog -h\n" (current-error-port))
84 (set! dc-server (cdr arg)))
86 (set! log-dir (cdr arg)))
90 (if (not dc-server) (set! dc-server (getenv "DCSERVER")))
91 (if (not dc-server) (set! dc-server "localhost"))
92 (if (not log-dir) (set! log-dir (string-append (getenv "HOME") "/dc/chatlog")))
94 (dc-c&l #t dc-server #t)
95 (dc-ecmd-assert 200 "notify" "fn:chat" "on" "fn:act" "on")
99 (while (let ((resp (dc-getresp)))
102 (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
104 ((equal? cmd ".notify")
107 (let ((ires (list->vector (dc-intresp resp))))
110 (string-append log-dir "/"
111 (let ((fixedname (list->string
112 (map (lambda (c) (if (eq? c #\/) #\_ c))
113 (string->list (fn-getname (vector-ref ires 0)))))))
114 (if (= (string-length fixedname) 0) "noname" fixedname)))
116 (if (not (eq? (vector-ref ires 0) last-fn))
117 (begin (write-line (string-append " -- " (fn-getname (vector-ref ires 0)) ":"))
118 (set! last-fn (vector-ref ires 0))))
121 (write-line (string-append (strftime "%H:%M:%S" (localtime (current-time))) (if (eq? (vector-ref ires 1) 0) "!" ":") " <" (vector-ref ires 3) "> " (vector-ref ires 4)) p))
122 (list p (current-output-port)))
127 (let ((ires (dc-intresp resp)))
129 (let ((ent (assoc (car ires) fnetnodes)))
131 (set-cdr! ent (cadr ires))
132 (set! fnetnodes (cons (cons (car ires) (cadr ires)) fnetnodes)))))))
149 (chatlog-main (command-line))