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 '()) |
d3372da9 | 25 | |
26 | (define-public dc-fn-update | |
27 | (lambda () | |
28 | (set! fnetnodes | |
29 | (let ((resp (dc-ecmd "lsnodes")) (er #f)) | |
30 | (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assq 'code er)) 200)) | |
31 | (map (lambda (o) | |
c5233277 | 32 | (apply (lambda (id net name users state uid) |
d3372da9 | 33 | (cons id |
34 | (list (cons 'id id) | |
35 | (cons 'net net) | |
36 | (cons 'name name) | |
37 | (cons 'users users) | |
c5233277 | 38 | (cons 'state (list-ref '(syn hs est dead) state)) |
39 | (cons 'uid uid)))) | |
d3372da9 | 40 | o)) |
41 | (dc-intall resp)) | |
42 | '()))) | |
43 | fnetnodes)) | |
44 | ||
45 | (define-public dc-fn-getattrib | |
46 | (lambda (id attrib) | |
47 | (if (not (assq id fnetnodes)) | |
48 | (dc-fn-update)) | |
49 | (let ((aform (assq id fnetnodes))) | |
50 | (if aform | |
51 | (cdr (assq attrib (cdr aform))) | |
52 | #f)))) | |
53 | ||
54 | (define-public dc-fn-getname | |
55 | (lambda (id) | |
56 | (dc-fn-getattrib id 'name))) | |
57 | ||
58 | (define-public dc-getfnetnodes | |
59 | (lambda () | |
60 | (map (lambda (o) (car o)) | |
61 | fnetnodes))) | |
c5233277 | 62 | |
63 | (define fn-updattr | |
64 | (lambda (id attr val) | |
65 | (let ((aform (assq id fnetnodes))) | |
66 | (if aform | |
67 | (set-cdr! (assq attr (cdr aform)) val) | |
68 | #f)))) | |
69 | ||
70 | (define-public dc-fnproc-reg | |
71 | (lambda (event proc) | |
72 | (set! fn-procs (cons (list event proc) | |
73 | fn-procs)))) | |
74 | ||
aff8e2e1 | 75 | (define dc-handle-fn |
c5233277 | 76 | (lambda () |
77 | (dc-fn-update) | |
78 | (let* ((notify (lambda (event data) (for-each (lambda (o) (if (eq? event (car o)) ((cadr o) data))) fn-procs))) | |
a7b765eb | 79 | (ua (lambda (r a) (let* ((ires (dc-intresp r)) |
80 | (hubform (assq (car ires) fnetnodes))) | |
bf21dd04 | 81 | (if hubform |
82 | (begin (fn-updattr (car ires) a (cadr ires)) | |
83 | (notify a (cdr (assq (car ires) fnetnodes))))))))) | |
e6848bc1 | 84 | (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r)) |
1a893343 | 85 | (hubform (assq (car ires) fnetnodes))) |
e6848bc1 | 86 | (if hubform |
87 | (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires))) | |
1a893343 | 88 | (notify 'state (cdr hubform))))))) |
c5233277 | 89 | (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name))) |
90 | (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users))) | |
91 | (dc-loop-reg ".notify" 604 (lambda (r er) | |
92 | (let* ((ires (dc-intresp r)) | |
93 | (new (list (cons 'id (car ires)) | |
94 | (cons 'net (cadr ires)) | |
95 | (cons 'name "") | |
96 | (cons 'users 0) | |
97 | (cons 'state 'syn)))) | |
98 | (set! fnetnodes | |
99 | (cons (cons (car ires) new) | |
100 | fnetnodes)) | |
101 | (notify 'creat new)))) | |
102 | (dc-loop-reg ".notify" 603 (lambda (r er) | |
103 | (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes))) | |
104 | (notify 'dstr (cdr nform)) | |
105 | (set! fnetnodes (delq nform fnetnodes)))))))) | |
106 | ||
aff8e2e1 FT |
107 | (define-public dc-msgproc-reg |
108 | (lambda (proc) | |
109 | (set! msg-procs (cons proc msg-procs)))) | |
110 | ||
111 | (define dc-handle-msg | |
112 | (lambda () | |
113 | (dc-loop-reg ".notify" 640 (lambda (r er) | |
114 | (let ((sender (cadadr (assq 'resp er))) | |
115 | (message (cddadr (assq 'resp er)))) | |
116 | (for-each (lambda (o) (o sender message)) | |
117 | msg-procs)))))) | |
118 | ||
119 | (define-public dc-util-handle | |
120 | (lambda what | |
121 | (for-each (lambda (o) | |
122 | (case o | |
123 | ((fn) (dc-handle-fn)) | |
124 | ((msg) (dc-handle-msg)))) | |
125 | what))) | |
126 | ||
c5233277 | 127 | (define-public dc-loop-reg |
128 | (lambda (cmd code proc) | |
129 | (set! loop-procs (cons (cons (cons cmd code) proc) | |
130 | loop-procs)))) | |
131 | ||
132 | (define-public dc-loop | |
133 | (lambda () | |
134 | (while #t | |
135 | (dc-select 10000) | |
136 | (while (let ((resp (dc-getresp))) | |
137 | (if resp | |
138 | (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er)))) | |
139 | (for-each | |
140 | (lambda (o) | |
141 | (if (and (or (not (caar o)) (equal? cmd (caar o))) | |
142 | (or (not (cdar o)) (equal? code (cdar o)))) | |
143 | ((cdr o) resp er))) | |
144 | loop-procs)) | |
145 | #f)) | |
146 | #f) | |
147 | (for-each (lambda (o) | |
148 | (if (equal? (caar o) ".periodic") | |
149 | ((cdr o)))) | |
150 | loop-procs)))) |