4 ; Dolda Connect - Modular multiuser Direct Connect-style client
5 ; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
7 ; This program is free software; you can redistribute it and/or modify
8 ; it under the terms of the GNU General Public License as published by
9 ; the Free Software Foundation; either version 2 of the License, or
10 ; (at your option) any later version.
12 ; This program is distributed in the hope that it will be useful,
13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ; GNU General Public License for more details.
17 ; You should have received a copy of the GNU General Public License
18 ; along with this program; if not, write to the Free Software
19 ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 (use-modules (dolcon ui))
22 (use-modules (ice-9 pretty-print) (ice-9 rdelim))
24 (define fnetnodes '())
26 (define (make-getopt opts optdesc)
27 (let ((arg opts) (curpos 0) (rest '()))
29 (if (eq? arg '()) rest
33 (if (eq? (string-ref (car arg) 0) #\-)
36 (set! rest (append rest (list (car arg))))
41 (if (< curpos (string-length (car arg)))
42 (begin (set! ret (string-ref (car arg) curpos)) (set! curpos (+ curpos 1)))
43 (begin (set! curpos 0) (set! arg (cdr arg)) (if (eq? arg '()) (set! ret #t))))))
45 (let ((opt (string-index optdesc ret)))
46 (if (eq? opt #f) (throw 'illegal-option ret)
47 (if (and (< opt (- (string-length optdesc) 1)) (eq? (string-ref optdesc (+ opt 1)) #\:))
49 (cons ret (let ((optarg
50 (if (< curpos (string-length (car arg)))
51 (substring (car arg) curpos)
52 (begin (set! arg (cdr arg)) (if (eq? arg '()) (throw 'requires-argument ret)) (car arg)))))
53 (set! arg (cdr arg)) optarg))))
59 (let ((resp (dc-ecmd "lsnodes")) (er #f))
60 (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200))
62 (while (begin (set! ires (dc-intresp resp)) ires)
63 (if (assoc (car ires) fnetnodes)
64 (set-cdr! (assoc (car ires) fnetnodes) (list-ref ires 5))
65 (set! fnetnodes (cons (cons (car ires) (list-ref ires 5)) fnetnodes))))))))
67 (define (fn-getname id)
68 (if (not (assoc id fnetnodes))
70 (if (assoc id fnetnodes)
71 (cdr (assoc id fnetnodes))
74 ;(define (fn-getname id)
75 ; (let ((resp (dc-ecmd "lsnodes")) (er #f))
76 ; (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200))
81 ; (while (begin (set! ires (dc-intresp resp)) ires)
82 ; (if (= (car ires) id)
83 ; (throw 'found (caddr ires)))
89 ; (number->string id)))
92 (define (chatlog-main args)
93 (let ((dc-server #f) (log-dir #f) (last-fn #f))
94 (let ((getopt (make-getopt (cdr args) "hs:S:e:")) (arg #f))
95 (do ((arg (getopt) (getopt))) ((not (and (pair? arg) (char? (car arg)))) (set! args arg))
96 (cond ((eq? (car arg) #\h)
97 (begin (display "usage: chatlog [-s server] [-d log-dir]\n" (current-error-port))
98 (display " chatlog -h\n" (current-error-port))
101 (set! dc-server (cdr arg)))
103 (set! log-dir (cdr arg)))
107 (if (not log-dir) (set! log-dir (string-append (getenv "HOME") "/dc/chatlog")))
109 (dc-c&l #t dc-server #t)
110 (dc-ecmd-assert 200 "notify" "fn:chat" "on" "fn:act" "on")
114 (while (let ((resp (dc-getresp)))
117 (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er))))
119 ((equal? cmd ".notify")
122 (let ((ires (list->vector (dc-intresp resp))))
125 (string-append log-dir "/"
126 (let ((fixedname (list->string
127 (map (lambda (c) (if (eq? c #\/) #\_ c))
128 (string->list (fn-getname (vector-ref ires 0)))))))
129 (if (= (string-length fixedname) 0) "noname" fixedname)))
131 (if (not (eq? (vector-ref ires 0) last-fn))
132 (begin (write-line (string-append " -- " (fn-getname (vector-ref ires 0)) ":"))
133 (set! last-fn (vector-ref ires 0))))
136 (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))
137 (list p (current-output-port)))
142 ; (let ((ires (dc-intresp resp)))
144 ; (let ((ent (assoc (car ires) fnetnodes)))
146 ; (set-cdr! ent (cadr ires))
147 ; (set! fnetnodes (cons (cons (car ires) (cadr ires)) fnetnodes)))))))
164 (chatlog-main (command-line))