30b25c1c49ab041fb48d6f55d8ca7bfd0d031b79
[doldaconnect.git] / lib / guile / dolcon / util.scm
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
18 (define-module (dolcon util))
19 (use-modules (dolcon ui))
20
21 (define fnetnodes '())
22 (define loop-procs '())
23 (define fn-procs '())
24 (define msg-procs '())
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)
32                        (apply (lambda (id net name users state uid)
33                                 (cons id
34                                       (list (cons 'id id)
35                                             (cons 'net net)
36                                             (cons 'name name)
37                                             (cons 'users users)
38                                             (cons 'state (list-ref '(syn hs est dead) state))
39                                             (cons 'uid uid))))
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)))
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
75 (define dc-handle-fn
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)))
79            (ua (lambda (r a) (let* ((ires (dc-intresp r))
80                                     (hubform (assq (car ires) fnetnodes)))
81                                (if hubform
82                                    (begin (fn-updattr (car ires) a (cadr ires))
83                                           (notify a (cdr (assq (car ires) fnetnodes)))))))))
84       (dc-loop-reg ".notify" 601 (lambda (r er) (let* ((ires (dc-intresp r))
85                                                        (hubform (assq (car ires) fnetnodes)))
86                                                   (if hubform
87                                                       (begin (fn-updattr (car ires) 'state (list-ref '(syn hs est dead) (cadr ires)))
88                                                              (notify 'state (cdr hubform)))))))
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
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
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))))