d3372da9 |
1 | #!/usr/bin/guile -s |
2 | !# |
3 | |
4 | (use-modules (dolcon ui)) |
5 | (use-modules (ice-9 pretty-print)) |
6 | |
7 | (define fnetnodes '()) |
8 | |
9 | (define (make-getopt opts optdesc) |
10 | (let ((arg opts) (curpos 0) (rest '())) |
11 | (lambda () |
12 | (if (eq? arg '()) rest |
13 | (let ((ret #f)) |
14 | (while (not ret) |
15 | (if (= curpos 0) |
16 | (if (eq? (string-ref (car arg) 0) #\-) |
17 | (set! curpos 1) |
18 | (begin |
19 | (set! rest (append rest (list (car arg)))) |
20 | (set! arg (cdr arg)) |
21 | (if (eq? arg '()) |
22 | (set! ret #t))))) |
23 | (if (> curpos 0) |
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)))))) |
27 | (if (eq? ret #t) rest |
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)) #\:)) |
31 | (let ((ret |
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)))) |
37 | (set! curpos 0) |
38 | ret) |
39 | (list ret)))))))))) |
40 | |
41 | (define (fn-getnames) |
42 | (let ((resp (dc-ecmd "lsnodes")) (er #f)) |
43 | (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assoc 'code er)) 200)) |
44 | (let ((ires #f)) |
45 | (while (begin (set! ires (dc-intresp resp)) ires) |
46 | (if (assoc (car ires) fnetnodes) |
5177317d |
47 | (set-cdr! (assoc (car ires) fnetnodes) (list-ref ires 5)) |
48 | (set! fnetnodes (cons (cons (car ires) (list-ref ires 5)) fnetnodes)))))))) |
d3372da9 |
49 | |
50 | (define (fn-getname id) |
51 | (if (not (assoc id fnetnodes)) |
52 | (fn-getnames)) |
53 | (if (assoc id fnetnodes) |
54 | (cdr (assoc id fnetnodes)) |
55 | (number->string id))) |
56 | |
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)) |
60 | ; (begin |
61 | ; (catch 'found |
62 | ; (lambda () |
63 | ; (let ((ires #f)) |
64 | ; (while (begin (set! ires (dc-intresp resp)) ires) |
65 | ; (if (= (car ires) id) |
66 | ; (throw 'found (caddr ires))) |
67 | ; )) |
68 | ; (number->string id) |
69 | ; ) |
70 | ; (lambda (key ret) |
71 | ; ret))) |
72 | ; (number->string id))) |
73 | ; ) |
74 | |
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)) |
82 | (exit 0))) |
83 | ((eq? (car arg) #\s) |
84 | (set! dc-server (cdr arg))) |
85 | ((eq? (car arg) #\d) |
86 | (set! log-dir (cdr arg))) |
87 | ) |
88 | ) |
89 | ) |
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"))) |
93 | |
94 | (dc-c&l #t dc-server #t) |
95 | (dc-ecmd-assert 200 "notify" "fn:chat" "on" "fn:act" "on") |
96 | |
97 | (while #t |
98 | (dc-select 10000) |
99 | (while (let ((resp (dc-getresp))) |
100 | (if resp |
101 | (begin |
102 | (let* ((er (dc-extract resp)) (code (cdr (assoc 'code er))) (cmd (cdr (assoc 'cmd er)))) |
103 | (cond |
104 | ((equal? cmd ".notify") |
105 | (case code |
106 | ((600) |
107 | (let ((ires (list->vector (dc-intresp resp)))) |
108 | (if ires |
109 | (let ((p (open-file |
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))) |
115 | "a"))) |
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)))) |
119 | (for-each |
120 | (lambda (p) |
87e4e72a |
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)) |
d3372da9 |
122 | (list p (current-output-port))) |
123 | (close-port p)) |
124 | )) |
125 | ) |
126 | ((602) |
127 | (let ((ires (dc-intresp resp))) |
128 | (if ires |
129 | (let ((ent (assoc (car ires) fnetnodes))) |
130 | (if ent |
131 | (set-cdr! ent (cadr ires)) |
132 | (set! fnetnodes (cons (cons (car ires) (cadr ires)) fnetnodes))))))) |
133 | |
134 | ) |
135 | ) |
136 | |
137 | ) |
138 | ) |
139 | #t) |
140 | #f) |
141 | ) |
142 | #t |
143 | ) |
144 | |
145 | ) |
146 | ) |
147 | ) |
148 | |
149 | (chatlog-main (command-line)) |