Commit | Line | Data |
---|---|---|
d3372da9 | 1 | #!/usr/bin/guile -s |
2 | !# | |
3 | ||
3af4536f FT |
4 | ; Dolda Connect - Modular multiuser Direct Connect-style client |
5 | ; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com> | |
6 | ; | |
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. | |
11 | ; | |
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. | |
16 | ; | |
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 | |
20 | ||
d3372da9 | 21 | (use-modules (dolcon ui)) |
275514c0 | 22 | (use-modules (ice-9 pretty-print) (ice-9 rdelim)) |
d3372da9 | 23 | |
24 | (define fnetnodes '()) | |
25 | ||
26 | (define (make-getopt opts optdesc) | |
27 | (let ((arg opts) (curpos 0) (rest '())) | |
28 | (lambda () | |
29 | (if (eq? arg '()) rest | |
30 | (let ((ret #f)) | |
31 | (while (not ret) | |
32 | (if (= curpos 0) | |
33 | (if (eq? (string-ref (car arg) 0) #\-) | |
34 | (set! curpos 1) | |
35 | (begin | |
36 | (set! rest (append rest (list (car arg)))) | |
37 | (set! arg (cdr arg)) | |
38 | (if (eq? arg '()) | |
39 | (set! ret #t))))) | |
40 | (if (> curpos 0) | |
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)))))) | |
44 | (if (eq? ret #t) rest | |
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)) #\:)) | |
48 | (let ((ret | |
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)))) | |
54 | (set! curpos 0) | |
55 | ret) | |
56 | (list ret)))))))))) | |
57 | ||
58 | (define (fn-getnames) | |
59 | (let ((resp (dc-ecmd "lsnodes")) (er #f)) | |
60 | (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200)) | |
61 | (let ((ires #f)) | |
62 | (while (begin (set! ires (dc-intresp resp)) ires) | |
63 | (if (assoc (car ires) fnetnodes) | |
5177317d | 64 | (set-cdr! (assoc (car ires) fnetnodes) (list-ref ires 5)) |
65 | (set! fnetnodes (cons (cons (car ires) (list-ref ires 5)) fnetnodes)))))))) | |
d3372da9 | 66 | |
67 | (define (fn-getname id) | |
68 | (if (not (assoc id fnetnodes)) | |
69 | (fn-getnames)) | |
70 | (if (assoc id fnetnodes) | |
71 | (cdr (assoc id fnetnodes)) | |
72 | (number->string id))) | |
73 | ||
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)) | |
77 | ; (begin | |
78 | ; (catch 'found | |
79 | ; (lambda () | |
80 | ; (let ((ires #f)) | |
81 | ; (while (begin (set! ires (dc-intresp resp)) ires) | |
82 | ; (if (= (car ires) id) | |
83 | ; (throw 'found (caddr ires))) | |
84 | ; )) | |
85 | ; (number->string id) | |
86 | ; ) | |
87 | ; (lambda (key ret) | |
88 | ; ret))) | |
89 | ; (number->string id))) | |
90 | ; ) | |
91 | ||
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)) | |
99 | (exit 0))) | |
100 | ((eq? (car arg) #\s) | |
101 | (set! dc-server (cdr arg))) | |
102 | ((eq? (car arg) #\d) | |
103 | (set! log-dir (cdr arg))) | |
104 | ) | |
105 | ) | |
106 | ) | |
d3372da9 | 107 | (if (not log-dir) (set! log-dir (string-append (getenv "HOME") "/dc/chatlog"))) |
108 | ||
109 | (dc-c&l #t dc-server #t) | |
110 | (dc-ecmd-assert 200 "notify" "fn:chat" "on" "fn:act" "on") | |
111 | ||
112 | (while #t | |
113 | (dc-select 10000) | |
114 | (while (let ((resp (dc-getresp))) | |
115 | (if resp | |
116 | (begin | |
117 | (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er)))) | |
118 | (cond | |
119 | ((equal? cmd ".notify") | |
120 | (case code | |
121 | ((600) | |
122 | (let ((ires (list->vector (dc-intresp resp)))) | |
123 | (if ires | |
124 | (let ((p (open-file | |
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))) | |
130 | "a"))) | |
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)))) | |
134 | (for-each | |
135 | (lambda (p) | |
87e4e72a | 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)) |
d3372da9 | 137 | (list p (current-output-port))) |
138 | (close-port p)) | |
139 | )) | |
140 | ) | |
23d33e0e | 141 | ; ((602) |
142 | ; (let ((ires (dc-intresp resp))) | |
143 | ; (if ires | |
144 | ; (let ((ent (assoc (car ires) fnetnodes))) | |
145 | ; (if ent | |
146 | ; (set-cdr! ent (cadr ires)) | |
147 | ; (set! fnetnodes (cons (cons (car ires) (cadr ires)) fnetnodes))))))) | |
d3372da9 | 148 | |
149 | ) | |
150 | ) | |
151 | ||
152 | ) | |
153 | ) | |
154 | #t) | |
155 | #f) | |
156 | ) | |
157 | #t | |
158 | ) | |
159 | ||
160 | ) | |
161 | ) | |
162 | ) | |
163 | ||
164 | (chatlog-main (command-line)) |