Commit | Line | Data |
---|---|---|
3af4536f FT |
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 | ||
d3372da9 | 18 | (define-module (dolcon util)) |
19 | (use-modules (dolcon ui)) | |
20 | ||
21 | (define fnetnodes '()) | |
c5233277 | 22 | (define loop-procs '()) |
23 | (define fn-procs '()) | |
aff8e2e1 | 24 | (define msg-procs '()) |
43779f53 | 25 | (define timeouts '()) |
d3372da9 | 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) | |
c5233277 | 33 | (apply (lambda (id net name users state uid) |
d3372da9 | 34 | (cons id |
35 | (list (cons 'id id) | |
36 | (cons 'net net) | |
37 | (cons 'name name) | |
38 | (cons 'users users) | |
c5233277 | 39 | (cons 'state (list-ref '(syn hs est dead) state)) |
40 | (cons 'uid uid)))) | |
d3372da9 | 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))) | |
c5233277 | 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 | ||
aff8e2e1 | 76 | (define dc-handle-fn |
c5233277 | 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))) | |
a7b765eb | 80 | (ua (lambda (r a) (let* ((ires (dc-intresp r)) |
81 | (hubform (assq (car ires) fnetnodes))) | |
bf21dd04 | 82 | (if hubform |
83 | (begin (fn-updattr (car ires) a (cadr ires)) | |
84 | (notify a (cdr (assq (car ires) fnetnodes))))))))) | |
e6848bc1 | 85 | (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r)) |
1a893343 | 86 | (hubform (assq (car ires) fnetnodes))) |
e6848bc1 | 87 | (if hubform |
88 | (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires))) | |
1a893343 | 89 | (notify 'state (cdr hubform))))))) |
c5233277 | 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 | ||
aff8e2e1 FT |
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 | ||
43779f53 FT |
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 | ||
c5233277 | 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 | |
43779f53 FT |
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))))))) | |
c5233277 | 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) | |
43779f53 FT |
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))) | |
c5233277 | 166 | (for-each (lambda (o) |
167 | (if (equal? (caar o) ".periodic") | |
168 | ((cdr o)))) | |
169 | loop-procs)))) |