The hublist at dchublist.com finally fixed their bogus XML, so now we use them by...
[doldaconnect.git] / lib / guile / dolcon / util.scm
... / ...
CommitLineData
1; Dolda Connect - Modular multiuser Direct Connect-style client
2; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com>
3;
4; This program is free software; you can redistribute it and/or modify
5; it under the terms of the GNU General Public License as published by
6; the Free Software Foundation; either version 2 of the License, or
7; (at your option) any later version.
8;
9; This program is distributed in the hope that it will be useful,
10; but WITHOUT ANY WARRANTY; without even the implied warranty of
11; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12; GNU General Public License for more details.
13;
14; You should have received a copy of the GNU General Public License
15; along with this program; if not, write to the Free Software
16; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
18(define-module (dolcon util))
19(use-modules (dolcon ui))
20
21(define fnetnodes '())
22(define loop-procs '())
23(define fn-procs '())
24(define msg-procs '())
25(define timeouts '())
26
27(define-public dc-fn-update
28 (lambda ()
29 (set! fnetnodes
30 (let ((resp (dc-ecmd "lsnodes")) (er #f))
31 (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assq 'code er)) 200))
32 (map (lambda (o)
33 (apply (lambda (id net name users state uid)
34 (cons id
35 (list (cons 'id id)
36 (cons 'net net)
37 (cons 'name name)
38 (cons 'users users)
39 (cons 'state (list-ref '(syn hs est dead) state))
40 (cons 'uid uid))))
41 o))
42 (dc-intall resp))
43 '())))
44 fnetnodes))
45
46(define-public dc-fn-getattrib
47 (lambda (id attrib)
48 (if (not (assq id fnetnodes))
49 (dc-fn-update))
50 (let ((aform (assq id fnetnodes)))
51 (if aform
52 (cdr (assq attrib (cdr aform)))
53 #f))))
54
55(define-public dc-fn-getname
56 (lambda (id)
57 (dc-fn-getattrib id 'name)))
58
59(define-public dc-getfnetnodes
60 (lambda ()
61 (map (lambda (o) (car o))
62 fnetnodes)))
63
64(define fn-updattr
65 (lambda (id attr val)
66 (let ((aform (assq id fnetnodes)))
67 (if aform
68 (set-cdr! (assq attr (cdr aform)) val)
69 #f))))
70
71(define-public dc-fnproc-reg
72 (lambda (event proc)
73 (set! fn-procs (cons (list event proc)
74 fn-procs))))
75
76(define dc-handle-fn
77 (lambda ()
78 (dc-fn-update)
79 (let* ((notify (lambda (event data) (for-each (lambda (o) (if (eq? event (car o)) ((cadr o) data))) fn-procs)))
80 (ua (lambda (r a) (let* ((ires (dc-intresp r))
81 (hubform (assq (car ires) fnetnodes)))
82 (if hubform
83 (begin (fn-updattr (car ires) a (cadr ires))
84 (notify a (cdr (assq (car ires) fnetnodes)))))))))
85 (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r))
86 (hubform (assq (car ires) fnetnodes)))
87 (if hubform
88 (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires)))
89 (notify 'state (cdr hubform)))))))
90 (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name)))
91 (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users)))
92 (dc-loop-reg ".notify" 604 (lambda (r er)
93 (let* ((ires (dc-intresp r))
94 (new (list (cons 'id (car ires))
95 (cons 'net (cadr ires))
96 (cons 'name "")
97 (cons 'users 0)
98 (cons 'state 'syn))))
99 (set! fnetnodes
100 (cons (cons (car ires) new)
101 fnetnodes))
102 (notify 'creat new))))
103 (dc-loop-reg ".notify" 603 (lambda (r er)
104 (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes)))
105 (notify 'dstr (cdr nform))
106 (set! fnetnodes (delq nform fnetnodes))))))))
107
108(define-public dc-msgproc-reg
109 (lambda (proc)
110 (set! msg-procs (cons proc msg-procs))))
111
112(define dc-handle-msg
113 (lambda ()
114 (dc-loop-reg ".notify" 640 (lambda (r er)
115 (let ((sender (cadadr (assq 'resp er)))
116 (message (cddadr (assq 'resp er))))
117 (for-each (lambda (o) (o sender message))
118 msg-procs))))))
119
120(define-public dc-util-handle
121 (lambda what
122 (for-each (lambda (o)
123 (case o
124 ((fn) (dc-handle-fn))
125 ((msg) (dc-handle-msg))))
126 what)))
127
128(define-public dc-timeout
129 (lambda (rel timeout proc)
130 (let* ((tf (gettimeofday))
131 (t (+ (car tf) (/ (cdr tf) 1000000))))
132 (set! timeouts (merge timeouts (list (cons (if rel (+ timeout t) timeout) proc))
133 (lambda (a b) (< (car a) (car b))))))))
134
135(define-public dc-loop-reg
136 (lambda (cmd code proc)
137 (set! loop-procs (cons (cons (cons cmd code) proc)
138 loop-procs))))
139
140(define-public dc-loop
141 (lambda ()
142 (while #t
143 (dc-select (if (eq? timeouts '())
144 10000
145 (let* ((tf (gettimeofday))
146 (t (+ (car tf) (/ (cdr tf) 1000000)))
147 (dt (- (caar timeouts) t)))
148 (if (< dt 0) 0 (truncate (inexact->exact (* dt 1000)))))))
149 (while (let ((resp (dc-getresp)))
150 (if resp
151 (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er))))
152 (for-each
153 (lambda (o)
154 (if (and (or (not (caar o)) (equal? cmd (caar o)))
155 (or (not (cdar o)) (equal? code (cdar o))))
156 ((cdr o) resp er)))
157 loop-procs))
158 #f))
159 #f)
160 (while (and (not (eq? timeouts '()))
161 (let* ((tf (gettimeofday))
162 (t (+ (car tf) (/ (cdr tf) 1000000))))
163 (>= t (caar timeouts))))
164 ((cdar timeouts))
165 (set! timeouts (cdr timeouts)))
166 (for-each (lambda (o)
167 (if (equal? (caar o) ".periodic")
168 ((cdr o))))
169 loop-procs))))