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