d3372da9 |
1 | (define-module (dolcon util)) |
2 | (use-modules (dolcon ui)) |
3 | |
4 | (define fnetnodes '()) |
c5233277 |
5 | (define loop-procs '()) |
6 | (define fn-procs '()) |
d3372da9 |
7 | |
8 | (define-public dc-fn-update |
9 | (lambda () |
10 | (set! fnetnodes |
11 | (let ((resp (dc-ecmd "lsnodes")) (er #f)) |
12 | (if (and resp (begin (set! er (dc-extract resp)) er) (= (cdr (assq 'code er)) 200)) |
13 | (map (lambda (o) |
c5233277 |
14 | (apply (lambda (id net name users state uid) |
d3372da9 |
15 | (cons id |
16 | (list (cons 'id id) |
17 | (cons 'net net) |
18 | (cons 'name name) |
19 | (cons 'users users) |
c5233277 |
20 | (cons 'state (list-ref '(syn hs est dead) state)) |
21 | (cons 'uid uid)))) |
d3372da9 |
22 | o)) |
23 | (dc-intall resp)) |
24 | '()))) |
25 | fnetnodes)) |
26 | |
27 | (define-public dc-fn-getattrib |
28 | (lambda (id attrib) |
29 | (if (not (assq id fnetnodes)) |
30 | (dc-fn-update)) |
31 | (let ((aform (assq id fnetnodes))) |
32 | (if aform |
33 | (cdr (assq attrib (cdr aform))) |
34 | #f)))) |
35 | |
36 | (define-public dc-fn-getname |
37 | (lambda (id) |
38 | (dc-fn-getattrib id 'name))) |
39 | |
40 | (define-public dc-getfnetnodes |
41 | (lambda () |
42 | (map (lambda (o) (car o)) |
43 | fnetnodes))) |
c5233277 |
44 | |
45 | (define fn-updattr |
46 | (lambda (id attr val) |
47 | (let ((aform (assq id fnetnodes))) |
48 | (if aform |
49 | (set-cdr! (assq attr (cdr aform)) val) |
50 | #f)))) |
51 | |
52 | (define-public dc-fnproc-reg |
53 | (lambda (event proc) |
54 | (set! fn-procs (cons (list event proc) |
55 | fn-procs)))) |
56 | |
57 | (define-public dc-handle-fn |
58 | (lambda () |
59 | (dc-fn-update) |
60 | (let* ((notify (lambda (event data) (for-each (lambda (o) (if (eq? event (car o)) ((cadr o) data))) fn-procs))) |
61 | (ua (lambda (r a) (let ((ires (dc-intresp r))) |
62 | (fn-updattr (car ires) a (cadr ires)) |
63 | (notify a (cdr (assq (car ires) fnetnodes))))))) |
64 | (dc-loop-reg ".notify" 601 (lambda (r er) (let ((ires (dc-intresp r))) |
65 | (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires))) |
66 | (notify 'state (cdr (assq (car ires) fnetnodes)))))) |
67 | (dc-loop-reg ".notify" 602 (lambda (r er) (ua r 'name))) |
68 | (dc-loop-reg ".notify" 605 (lambda (r er) (ua r 'users))) |
69 | (dc-loop-reg ".notify" 604 (lambda (r er) |
70 | (let* ((ires (dc-intresp r)) |
71 | (new (list (cons 'id (car ires)) |
72 | (cons 'net (cadr ires)) |
73 | (cons 'name "") |
74 | (cons 'users 0) |
75 | (cons 'state 'syn)))) |
76 | (set! fnetnodes |
77 | (cons (cons (car ires) new) |
78 | fnetnodes)) |
79 | (notify 'creat new)))) |
80 | (dc-loop-reg ".notify" 603 (lambda (r er) |
81 | (let* ((ires (dc-intresp r)) (nform (assq (car ires) fnetnodes))) |
82 | (notify 'dstr (cdr nform)) |
83 | (set! fnetnodes (delq nform fnetnodes)))))))) |
84 | |
85 | (define-public dc-loop-reg |
86 | (lambda (cmd code proc) |
87 | (set! loop-procs (cons (cons (cons cmd code) proc) |
88 | loop-procs)))) |
89 | |
90 | (define-public dc-loop |
91 | (lambda () |
92 | (while #t |
93 | (dc-select 10000) |
94 | (while (let ((resp (dc-getresp))) |
95 | (if resp |
96 | (let* ((er (dc-extract resp)) (code (cdr (assq 'code er))) (cmd (cdr (assq 'cmd er)))) |
97 | (for-each |
98 | (lambda (o) |
99 | (if (and (or (not (caar o)) (equal? cmd (caar o))) |
100 | (or (not (cdar o)) (equal? code (cdar o)))) |
101 | ((cdr o) resp er))) |
102 | loop-procs)) |
103 | #f)) |
104 | #f) |
105 | (for-each (lambda (o) |
106 | (if (equal? (caar o) ".periodic") |
107 | ((cdr o)))) |
108 | loop-procs)))) |