Use public IDs.
[doldaconnect.git] / lib / guile / chatlog
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)
47                      (set-cdr! (assoc (car ires) fnetnodes) (list-ref ires 5))
48                      (set! fnetnodes (cons (cons (car ires) (list-ref ires 5)) fnetnodes))))))))
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)
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)))
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))