Port Scheme programs to Guile 1.8.
[doldaconnect.git] / lib / guile / chatlog
CommitLineData
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))