Use public IDs.
[doldaconnect.git] / lib / guile / chatlog
CommitLineData
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))