| 1 | (define-module (dolcon util)) |
| 2 | (use-modules (dolcon ui)) |
| 3 | |
| 4 | (define fnetnodes '()) |
| 5 | (define loop-procs '()) |
| 6 | (define fn-procs '()) |
| 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) |
| 14 | (apply (lambda (id net name users state uid) |
| 15 | (cons id |
| 16 | (list (cons 'id id) |
| 17 | (cons 'net net) |
| 18 | (cons 'name name) |
| 19 | (cons 'users users) |
| 20 | (cons 'state (list-ref '(syn hs est dead) state)) |
| 21 | (cons 'uid uid)))) |
| 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))) |
| 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)))) |